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 C      write(iout,*) "zaczynam liczyc energie"
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C      write(iout,*) "skonczylem ipoty"
 122
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 C           write(iout,*) "skonczylem ipoty"
 128 cmc
 129 cmc Sep-06: egb takes care of dynamic ss bonds too
 130 cmc
 131 c      if (dyn_ss) call dyn_set_nss
 132
 133 c      print *,"Processor",myrank," computed USCSC"
 134 #ifdef TIMING
 135       time01=MPI_Wtime()
 136 #endif
 137       call vec_and_deriv
 138 #ifdef TIMING
 139       time_vec=time_vec+MPI_Wtime()-time01
 140 #endif
 141 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 142       if (ipot.lt.6) then
 143 #ifdef SPLITELE
 144          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 145      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 146      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 147      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 148 #else
 149          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 150      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 151      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 152      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 153 #endif
 154             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 155          else
 156             ees=0.0d0
 157             evdw1=0.0d0
 158             eel_loc=0.0d0
 159             eello_turn3=0.0d0
 160             eello_turn4=0.0d0
 161          endif
 162       else
 163 c        write (iout,*) "Soft-spheer ELEC potential"
 164         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 165      &   eello_turn4)
 166       endif
 167 c      print *,"Processor",myrank," computed UELEC"
 168 C
 169 C Calculate excluded-volume interaction energy between peptide groups
 170 C and side chains.
 171 C
 172       if (ipot.lt.6) then
 173        if(wscp.gt.0d0) then
 174         call escp(evdw2,evdw2_14)
 175        else
 176         evdw2=0
 177         evdw2_14=0
 178        endif
 179       else
 180 c        write (iout,*) "Soft-sphere SCP potential"
 181         call escp_soft_sphere(evdw2,evdw2_14)
 182       endif
 183 c
 184 c Calculate the bond-stretching energy
 185 c
 186       call ebond(estr)
 187 C
 188 C Calculate the disulfide-bridge and other energy and the contributions
 189 C from other distance constraints.
 190 cd    print *,'Calling EHPB'
 191       call edis(ehpb)
 192 cd    print *,'EHPB exitted succesfully.'
 193 C
 194 C Calculate the virtual-bond-angle energy.
 195 C
 196       if (wang.gt.0d0) then
 197         call ebend(ebe)
 198       else
 199         ebe=0
 200       endif
 201 c      print *,"Processor",myrank," computed UB"
 202 C
 203 C Calculate the SC local energy.
 204 C
 205       call esc(escloc)
 206 c      print *,"Processor",myrank," computed USC"
 207 C
 208 C Calculate the virtual-bond torsional energy.
 209 C
 210 cd    print *,'nterm=',nterm
 211       if (wtor.gt.0) then
 212        call etor(etors,edihcnstr)
 213       else
 214        etors=0
 215        edihcnstr=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utor"
 218 C
 219 C 6/23/01 Calculate double-torsional energy
 220 C
 221       if (wtor_d.gt.0) then
 222        call etor_d(etors_d)
 223       else
 224        etors_d=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utord"
 227 C
 228 C 21/5/07 Calculate local sicdechain correlation energy
 229 C
 230       if (wsccor.gt.0.0d0) then
 231         call eback_sc_corr(esccor)
 232       else
 233         esccor=0.0d0
 234       endif
 235 c      print *,"Processor",myrank," computed Usccorr"
 236 C
 237 C 12/1/95 Multi-body terms
 238 C
 239       n_corr=0
 240       n_corr1=0
 241       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 242      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 243          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 244 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 245 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 246       else
 247          ecorr=0.0d0
 248          ecorr5=0.0d0
 249          ecorr6=0.0d0
 250          eturn6=0.0d0
 251       endif
 252       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 253          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 254 cd         write (iout,*) "multibody_hb ecorr",ecorr
 255       endif
 256 c      print *,"Processor",myrank," computed Ucorr"
 257 C
 258 C If performing constraint dynamics, call the constraint energy
 259 C  after the equilibration time
 260       if(usampl.and.totT.gt.eq_time) then
 261          call EconstrQ
 262          call Econstr_back
 263       else
 264          Uconst=0.0d0
 265          Uconst_back=0.0d0
 266       endif
 267 #ifdef TIMING
 268       time_enecalc=time_enecalc+MPI_Wtime()-time00
 269 #endif
 270 c      print *,"Processor",myrank," computed Uconstr"
 271 #ifdef TIMING
 272       time00=MPI_Wtime()
 273 #endif
 274 c
 275 C Sum the energies
 276 C
 277       energia(1)=evdw
 278 #ifdef SCP14
 279       energia(2)=evdw2-evdw2_14
 280       energia(18)=evdw2_14
 281 #else
 282       energia(2)=evdw2
 283       energia(18)=0.0d0
 284 #endif
 285 #ifdef SPLITELE
 286       energia(3)=ees
 287       energia(16)=evdw1
 288 #else
 289       energia(3)=ees+evdw1
 290       energia(16)=0.0d0
 291 #endif
 292       energia(4)=ecorr
 293       energia(5)=ecorr5
 294       energia(6)=ecorr6
 295       energia(7)=eel_loc
 296       energia(8)=eello_turn3
 297       energia(9)=eello_turn4
 298       energia(10)=eturn6
 299       energia(11)=ebe
 300       energia(12)=escloc
 301       energia(13)=etors
 302       energia(14)=etors_d
 303       energia(15)=ehpb
 304       energia(19)=edihcnstr
 305       energia(17)=estr
 306       energia(20)=Uconst+Uconst_back
 307       energia(21)=esccor
 308 c      print *," Processor",myrank," calls SUM_ENERGY"
 309       call sum_energy(energia,.true.)
 310       if (dyn_ss) call dyn_set_nss
 311 c      print *," Processor",myrank," left SUM_ENERGY"
 312 #ifdef TIMING
 313       time_sumene=time_sumene+MPI_Wtime()-time00
 314 #endif
 315       return
 316       end
 317 c-------------------------------------------------------------------------------
 318       subroutine sum_energy(energia,reduce)
 319       implicit real*8 (a-h,o-z)
 320       include 'DIMENSIONS'
 321 #ifndef ISNAN
 322       external proc_proc
 323 #ifdef WINPGI
 324 cMS$ATTRIBUTES C ::  proc_proc
 325 #endif
 326 #endif
 327 #ifdef MPI
 328       include "mpif.h"
 329 #endif
 330       include 'COMMON.SETUP'
 331       include 'COMMON.IOUNITS'
 332       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 333       include 'COMMON.FFIELD'
 334       include 'COMMON.DERIV'
 335       include 'COMMON.INTERACT'
 336       include 'COMMON.SBRIDGE'
 337       include 'COMMON.CHAIN'
 338       include 'COMMON.VAR'
 339       include 'COMMON.CONTROL'
 340       include 'COMMON.TIME1'
 341       logical reduce
 342 #ifdef MPI
 343       if (nfgtasks.gt.1 .and. reduce) then
 344 #ifdef DEBUG
 345         write (iout,*) "energies before REDUCE"
 346         call enerprint(energia)
 347         call flush(iout)
 348 #endif
 349         do i=0,n_ene
 350           enebuff(i)=energia(i)
 351         enddo
 352         time00=MPI_Wtime()
 353         call MPI_Barrier(FG_COMM,IERR)
 354         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 355         time00=MPI_Wtime()
 356         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 357      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 358 #ifdef DEBUG
 359         write (iout,*) "energies after REDUCE"
 360         call enerprint(energia)
 361         call flush(iout)
 362 #endif
 363         time_Reduce=time_Reduce+MPI_Wtime()-time00
 364       endif
 365       if (fg_rank.eq.0) then
 366 #endif
 367       evdw=energia(1)
 368 #ifdef SCP14
 369       evdw2=energia(2)+energia(18)
 370       evdw2_14=energia(18)
 371 #else
 372       evdw2=energia(2)
 373 #endif
 374 #ifdef SPLITELE
 375       ees=energia(3)
 376       evdw1=energia(16)
 377 #else
 378       ees=energia(3)
 379       evdw1=0.0d0
 380 #endif
 381       ecorr=energia(4)
 382       ecorr5=energia(5)
 383       ecorr6=energia(6)
 384       eel_loc=energia(7)
 385       eello_turn3=energia(8)
 386       eello_turn4=energia(9)
 387       eturn6=energia(10)
 388       ebe=energia(11)
 389       escloc=energia(12)
 390       etors=energia(13)
 391       etors_d=energia(14)
 392       ehpb=energia(15)
 393       edihcnstr=energia(19)
 394       estr=energia(17)
 395       Uconst=energia(20)
 396       esccor=energia(21)
 397 #ifdef SPLITELE
 398       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 399      & +wang*ebe+wtor*etors+wscloc*escloc
 400      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 401      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 402      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 403      & +wbond*estr+Uconst+wsccor*esccor
 404 #else
 405       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 406      & +wang*ebe+wtor*etors+wscloc*escloc
 407      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 408      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 409      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 410      & +wbond*estr+Uconst+wsccor*esccor
 411 #endif
 412       energia(0)=etot
 413 c detecting NaNQ
 414 #ifdef ISNAN
 415 #ifdef AIX
 416       if (isnan(etot).ne.0) energia(0)=1.0d+99
 417 #else
 418       if (isnan(etot)) energia(0)=1.0d+99
 419 #endif
 420 #else
 421       i=0
 422 #ifdef WINPGI
 423       idumm=proc_proc(etot,i)
 424 #else
 425       call proc_proc(etot,i)
 426 #endif
 427       if(i.eq.1)energia(0)=1.0d+99
 428 #endif
 429 #ifdef MPI
 430       endif
 431 #endif
 432       return
 433       end
 434 c-------------------------------------------------------------------------------
 435       subroutine sum_gradient
 436       implicit real*8 (a-h,o-z)
 437       include 'DIMENSIONS'
 438 #ifndef ISNAN
 439       external proc_proc
 440 #ifdef WINPGI
 441 cMS$ATTRIBUTES C ::  proc_proc
 442 #endif
 443 #endif
 444 #ifdef MPI
 445       include 'mpif.h'
 446 #endif
 447       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 448      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 449       include 'COMMON.SETUP'
 450       include 'COMMON.IOUNITS'
 451       include 'COMMON.FFIELD'
 452       include 'COMMON.DERIV'
 453       include 'COMMON.INTERACT'
 454       include 'COMMON.SBRIDGE'
 455       include 'COMMON.CHAIN'
 456       include 'COMMON.VAR'
 457       include 'COMMON.CONTROL'
 458       include 'COMMON.TIME1'
 459       include 'COMMON.MAXGRAD'
 460       include 'COMMON.SCCOR'
 461 #ifdef TIMING
 462       time01=MPI_Wtime()
 463 #endif
 464 #ifdef DEBUG
 465       write (iout,*) "sum_gradient gvdwc, gvdwx"
 466       do i=1,nres
 467         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 468      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 469       enddo
 470       call flush(iout)
 471 #endif
 472 #ifdef MPI
 473 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 474         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 475      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 476 #endif
 477 C
 478 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 479 C            in virtual-bond-vector coordinates
 480 C
 481 #ifdef DEBUG
 482 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 483 c      do i=1,nres-1
 484 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 485 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 486 c      enddo
 487 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 488 c      do i=1,nres-1
 489 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 490 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 491 c      enddo
 492       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 493       do i=1,nres
 494         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 495      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 496      &   g_corr5_loc(i)
 497       enddo
 498       call flush(iout)
 499 #endif
 500 #ifdef SPLITELE
 501       do i=1,nct
 502         do j=1,3
 503           gradbufc(j,i)=wsc*gvdwc(j,i)+
 504      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 505      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 506      &                wel_loc*gel_loc_long(j,i)+
 507      &                wcorr*gradcorr_long(j,i)+
 508      &                wcorr5*gradcorr5_long(j,i)+
 509      &                wcorr6*gradcorr6_long(j,i)+
 510      &                wturn6*gcorr6_turn_long(j,i)+
 511      &                wstrain*ghpbc(j,i)
 512         enddo
 513       enddo
 514 #else
 515       do i=1,nct
 516         do j=1,3
 517           gradbufc(j,i)=wsc*gvdwc(j,i)+
 518      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 519      &                welec*gelc_long(j,i)+
 520      &                wbond*gradb(j,i)+
 521      &                wel_loc*gel_loc_long(j,i)+
 522      &                wcorr*gradcorr_long(j,i)+
 523      &                wcorr5*gradcorr5_long(j,i)+
 524      &                wcorr6*gradcorr6_long(j,i)+
 525      &                wturn6*gcorr6_turn_long(j,i)+
 526      &                wstrain*ghpbc(j,i)
 527         enddo
 528       enddo
 529 #endif
 530 #ifdef MPI
 531       if (nfgtasks.gt.1) then
 532       time00=MPI_Wtime()
 533 #ifdef DEBUG
 534       write (iout,*) "gradbufc before allreduce"
 535       do i=1,nres
 536         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 537       enddo
 538       call flush(iout)
 539 #endif
 540       do i=1,nres
 541         do j=1,3
 542           gradbufc_sum(j,i)=gradbufc(j,i)
 543         enddo
 544       enddo
 545 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 546 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 547 c      time_reduce=time_reduce+MPI_Wtime()-time00
 548 #ifdef DEBUG
 549 c      write (iout,*) "gradbufc_sum after allreduce"
 550 c      do i=1,nres
 551 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 552 c      enddo
 553 c      call flush(iout)
 554 #endif
 555 #ifdef TIMING
 556 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 557 #endif
 558       do i=nnt,nres
 559         do k=1,3
 560           gradbufc(k,i)=0.0d0
 561         enddo
 562       enddo
 563 #ifdef DEBUG
 564       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 565       write (iout,*) (i," jgrad_start",jgrad_start(i),
 566      &                  " jgrad_end  ",jgrad_end(i),
 567      &                  i=igrad_start,igrad_end)
 568 #endif
 569 c
 570 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 571 c do not parallelize this part.
 572 c
 573 c      do i=igrad_start,igrad_end
 574 c        do j=jgrad_start(i),jgrad_end(i)
 575 c          do k=1,3
 576 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 577 c          enddo
 578 c        enddo
 579 c      enddo
 580       do j=1,3
 581         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 582       enddo
 583       do i=nres-2,nnt,-1
 584         do j=1,3
 585           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 586         enddo
 587       enddo
 588 #ifdef DEBUG
 589       write (iout,*) "gradbufc after summing"
 590       do i=1,nres
 591         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 592       enddo
 593       call flush(iout)
 594 #endif
 595       else
 596 #endif
 597 #ifdef DEBUG
 598       write (iout,*) "gradbufc"
 599       do i=1,nres
 600         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 601       enddo
 602       call flush(iout)
 603 #endif
 604       do i=1,nres
 605         do j=1,3
 606           gradbufc_sum(j,i)=gradbufc(j,i)
 607           gradbufc(j,i)=0.0d0
 608         enddo
 609       enddo
 610       do j=1,3
 611         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 612       enddo
 613       do i=nres-2,nnt,-1
 614         do j=1,3
 615           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 616         enddo
 617       enddo
 618 c      do i=nnt,nres-1
 619 c        do k=1,3
 620 c          gradbufc(k,i)=0.0d0
 621 c        enddo
 622 c        do j=i+1,nres
 623 c          do k=1,3
 624 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 625 c          enddo
 626 c        enddo
 627 c      enddo
 628 #ifdef DEBUG
 629       write (iout,*) "gradbufc after summing"
 630       do i=1,nres
 631         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 632       enddo
 633       call flush(iout)
 634 #endif
 635 #ifdef MPI
 636       endif
 637 #endif
 638       do k=1,3
 639         gradbufc(k,nres)=0.0d0
 640       enddo
 641       do i=1,nct
 642         do j=1,3
 643 #ifdef SPLITELE
 644           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 645      &                wel_loc*gel_loc(j,i)+
 646      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 647      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 648      &                wel_loc*gel_loc_long(j,i)+
 649      &                wcorr*gradcorr_long(j,i)+
 650      &                wcorr5*gradcorr5_long(j,i)+
 651      &                wcorr6*gradcorr6_long(j,i)+
 652      &                wturn6*gcorr6_turn_long(j,i))+
 653      &                wbond*gradb(j,i)+
 654      &                wcorr*gradcorr(j,i)+
 655      &                wturn3*gcorr3_turn(j,i)+
 656      &                wturn4*gcorr4_turn(j,i)+
 657      &                wcorr5*gradcorr5(j,i)+
 658      &                wcorr6*gradcorr6(j,i)+
 659      &                wturn6*gcorr6_turn(j,i)+
 660      &                wsccor*gsccorc(j,i)
 661      &               +wscloc*gscloc(j,i)
 662 #else
 663           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 664      &                wel_loc*gel_loc(j,i)+
 665      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 666      &                welec*gelc_long(j,i)
 667      &                wel_loc*gel_loc_long(j,i)+
 668      &                wcorr*gcorr_long(j,i)+
 669      &                wcorr5*gradcorr5_long(j,i)+
 670      &                wcorr6*gradcorr6_long(j,i)+
 671      &                wturn6*gcorr6_turn_long(j,i))+
 672      &                wbond*gradb(j,i)+
 673      &                wcorr*gradcorr(j,i)+
 674      &                wturn3*gcorr3_turn(j,i)+
 675      &                wturn4*gcorr4_turn(j,i)+
 676      &                wcorr5*gradcorr5(j,i)+
 677      &                wcorr6*gradcorr6(j,i)+
 678      &                wturn6*gcorr6_turn(j,i)+
 679      &                wsccor*gsccorc(j,i)
 680      &               +wscloc*gscloc(j,i)
 681 #endif
 682           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 683      &                  wbond*gradbx(j,i)+
 684      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 685      &                  wsccor*gsccorx(j,i)
 686      &                 +wscloc*gsclocx(j,i)
 687         enddo
 688       enddo
 689 #ifdef DEBUG
 690       write (iout,*) "gloc before adding corr"
 691       do i=1,4*nres
 692         write (iout,*) i,gloc(i,icg)
 693       enddo
 694 #endif
 695       do i=1,nres-3
 696         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 697      &   +wcorr5*g_corr5_loc(i)
 698      &   +wcorr6*g_corr6_loc(i)
 699      &   +wturn4*gel_loc_turn4(i)
 700      &   +wturn3*gel_loc_turn3(i)
 701      &   +wturn6*gel_loc_turn6(i)
 702      &   +wel_loc*gel_loc_loc(i)
 703       enddo
 704 #ifdef DEBUG
 705       write (iout,*) "gloc after adding corr"
 706       do i=1,4*nres
 707         write (iout,*) i,gloc(i,icg)
 708       enddo
 709 #endif
 710 #ifdef MPI
 711       if (nfgtasks.gt.1) then
 712         do j=1,3
 713           do i=1,nres
 714             gradbufc(j,i)=gradc(j,i,icg)
 715             gradbufx(j,i)=gradx(j,i,icg)
 716           enddo
 717         enddo
 718         do i=1,4*nres
 719           glocbuf(i)=gloc(i,icg)
 720         enddo
 721 #define DEBUG
 722 #ifdef DEBUG
 723       write (iout,*) "gloc_sc before reduce"
 724       do i=1,nres
 725        do j=1,1
 726         write (iout,*) i,j,gloc_sc(j,i,icg)
 727        enddo
 728       enddo
 729 #endif
 730 #undef DEBUG
 731         do i=1,nres
 732          do j=1,3
 733           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 734          enddo
 735         enddo
 736         time00=MPI_Wtime()
 737         call MPI_Barrier(FG_COMM,IERR)
 738         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 739         time00=MPI_Wtime()
 740         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 746         time_reduce=time_reduce+MPI_Wtime()-time00
 747         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 748      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 749         time_reduce=time_reduce+MPI_Wtime()-time00
 750 #define DEBUG
 751 #ifdef DEBUG
 752       write (iout,*) "gloc_sc after reduce"
 753       do i=1,nres
 754        do j=1,1
 755         write (iout,*) i,j,gloc_sc(j,i,icg)
 756        enddo
 757       enddo
 758 #endif
 759 #undef DEBUG
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after reduce"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766       endif
 767 #endif
 768       if (gnorm_check) then
 769 c
 770 c Compute the maximum elements of the gradient
 771 c
 772       gvdwc_max=0.0d0
 773       gvdwc_scp_max=0.0d0
 774       gelc_max=0.0d0
 775       gvdwpp_max=0.0d0
 776       gradb_max=0.0d0
 777       ghpbc_max=0.0d0
 778       gradcorr_max=0.0d0
 779       gel_loc_max=0.0d0
 780       gcorr3_turn_max=0.0d0
 781       gcorr4_turn_max=0.0d0
 782       gradcorr5_max=0.0d0
 783       gradcorr6_max=0.0d0
 784       gcorr6_turn_max=0.0d0
 785       gsccorc_max=0.0d0
 786       gscloc_max=0.0d0
 787       gvdwx_max=0.0d0
 788       gradx_scp_max=0.0d0
 789       ghpbx_max=0.0d0
 790       gradxorr_max=0.0d0
 791       gsccorx_max=0.0d0
 792       gsclocx_max=0.0d0
 793       do i=1,nct
 794         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 795         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 796         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 797         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 798      &   gvdwc_scp_max=gvdwc_scp_norm
 799         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 800         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 801         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 802         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 803         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 804         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 805         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 806         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 807         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 808         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 809         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 810         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 811         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 812      &    gcorr3_turn(1,i)))
 813         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 814      &    gcorr3_turn_max=gcorr3_turn_norm
 815         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 816      &    gcorr4_turn(1,i)))
 817         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 818      &    gcorr4_turn_max=gcorr4_turn_norm
 819         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 820         if (gradcorr5_norm.gt.gradcorr5_max)
 821      &    gradcorr5_max=gradcorr5_norm
 822         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 823         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 824         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 825      &    gcorr6_turn(1,i)))
 826         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 827      &    gcorr6_turn_max=gcorr6_turn_norm
 828         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 829         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 830         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 831         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 832         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 833         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 834         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 835         if (gradx_scp_norm.gt.gradx_scp_max)
 836      &    gradx_scp_max=gradx_scp_norm
 837         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 838         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 839         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 840         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 841         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 842         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 843         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 844         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 845       enddo
 846       if (gradout) then
 847 #ifdef AIX
 848         open(istat,file=statname,position="append")
 849 #else
 850         open(istat,file=statname,access="append")
 851 #endif
 852         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 853      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 854      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 855      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 856      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 857      &     gsccorx_max,gsclocx_max
 858         close(istat)
 859         if (gvdwc_max.gt.1.0d4) then
 860           write (iout,*) "gvdwc gvdwx gradb gradbx"
 861           do i=nnt,nct
 862             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 863      &        gradb(j,i),gradbx(j,i),j=1,3)
 864           enddo
 865           call pdbout(0.0d0,'cipiszcze',iout)
 866           call flush(iout)
 867         endif
 868       endif
 869       endif
 870 #ifdef DEBUG
 871       write (iout,*) "gradc gradx gloc"
 872       do i=1,nres
 873         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 874      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 875       enddo
 876 #endif
 877 #ifdef TIMING
 878       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 879 #endif
 880       return
 881       end
 882 c-------------------------------------------------------------------------------
 883       subroutine rescale_weights(t_bath)
 884       implicit real*8 (a-h,o-z)
 885       include 'DIMENSIONS'
 886       include 'COMMON.IOUNITS'
 887       include 'COMMON.FFIELD'
 888       include 'COMMON.SBRIDGE'
 889       double precision kfac /2.4d0/
 890       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 891 c      facT=temp0/t_bath
 892 c      facT=2*temp0/(t_bath+temp0)
 893       if (rescale_mode.eq.0) then
 894         facT=1.0d0
 895         facT2=1.0d0
 896         facT3=1.0d0
 897         facT4=1.0d0
 898         facT5=1.0d0
 899       else if (rescale_mode.eq.1) then
 900         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 901         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 902         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 903         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 904         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 905       else if (rescale_mode.eq.2) then
 906         x=t_bath/temp0
 907         x2=x*x
 908         x3=x2*x
 909         x4=x3*x
 910         x5=x4*x
 911         facT=licznik/dlog(dexp(x)+dexp(-x))
 912         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 913         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 914         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 915         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 916       else
 917         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 918         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 919 #ifdef MPI
 920        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 921 #endif
 922        stop 555
 923       endif
 924       welec=weights(3)*fact
 925       wcorr=weights(4)*fact3
 926       wcorr5=weights(5)*fact4
 927       wcorr6=weights(6)*fact5
 928       wel_loc=weights(7)*fact2
 929       wturn3=weights(8)*fact2
 930       wturn4=weights(9)*fact3
 931       wturn6=weights(10)*fact5
 932       wtor=weights(13)*fact
 933       wtor_d=weights(14)*fact2
 934       wsccor=weights(21)*fact
 935
 936       return
 937       end
 938 C------------------------------------------------------------------------
 939       subroutine enerprint(energia)
 940       implicit real*8 (a-h,o-z)
 941       include 'DIMENSIONS'
 942       include 'COMMON.IOUNITS'
 943       include 'COMMON.FFIELD'
 944       include 'COMMON.SBRIDGE'
 945       include 'COMMON.MD'
 946       double precision energia(0:n_ene)
 947       etot=energia(0)
 948       evdw=energia(1)
 949       evdw2=energia(2)
 950 #ifdef SCP14
 951       evdw2=energia(2)+energia(18)
 952 #else
 953       evdw2=energia(2)
 954 #endif
 955       ees=energia(3)
 956 #ifdef SPLITELE
 957       evdw1=energia(16)
 958 #endif
 959       ecorr=energia(4)
 960       ecorr5=energia(5)
 961       ecorr6=energia(6)
 962       eel_loc=energia(7)
 963       eello_turn3=energia(8)
 964       eello_turn4=energia(9)
 965       eello_turn6=energia(10)
 966       ebe=energia(11)
 967       escloc=energia(12)
 968       etors=energia(13)
 969       etors_d=energia(14)
 970       ehpb=energia(15)
 971       edihcnstr=energia(19)
 972       estr=energia(17)
 973       Uconst=energia(20)
 974       esccor=energia(21)
 975 #ifdef SPLITELE
 976       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 977      &  estr,wbond,ebe,wang,
 978      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 979      &  ecorr,wcorr,
 980      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 981      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 982      &  edihcnstr,ebr*nss,
 983      &  Uconst,etot
 984    10 format (/'Virtual-chain energies:'//
 985      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 986      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 987      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 988      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 989      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 990      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 991      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 992      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 993      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 994      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 995      & ' (SS bridges & dist. cnstr.)'/
 996      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 999      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1000      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1001      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1002      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1003      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1004      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1005      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1006      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1007      & 'ETOT=  ',1pE16.6,' (total)')
1008 #else
1009       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1010      &  estr,wbond,ebe,wang,
1011      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1012      &  ecorr,wcorr,
1013      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1014      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1015      &  ebr*nss,Uconst,etot
1016    10 format (/'Virtual-chain energies:'//
1017      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1018      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1019      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1020      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1021      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1022      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1023      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1024      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1025      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1026      & ' (SS bridges & dist. cnstr.)'/
1027      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1030      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1031      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1032      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1033      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1034      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1035      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1036      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1037      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1038      & 'ETOT=  ',1pE16.6,' (total)')
1039 #endif
1040       return
1041       end
1042 C-----------------------------------------------------------------------
1043       subroutine elj(evdw)
1044 C
1045 C This subroutine calculates the interaction energy of nonbonded side chains
1046 C assuming the LJ potential of interaction.
1047 C
1048       implicit real*8 (a-h,o-z)
1049       include 'DIMENSIONS'
1050       parameter (accur=1.0d-10)
1051       include 'COMMON.GEO'
1052       include 'COMMON.VAR'
1053       include 'COMMON.LOCAL'
1054       include 'COMMON.CHAIN'
1055       include 'COMMON.DERIV'
1056       include 'COMMON.INTERACT'
1057       include 'COMMON.TORSION'
1058       include 'COMMON.SBRIDGE'
1059       include 'COMMON.NAMES'
1060       include 'COMMON.IOUNITS'
1061       include 'COMMON.CONTACTS'
1062       dimension gg(3)
1063 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1064       evdw=0.0D0
1065       do i=iatsc_s,iatsc_e
1066         itypi=itype(i)
1067         if (itypi.eq.21) cycle
1068         itypi1=itype(i+1)
1069         xi=c(1,nres+i)
1070         yi=c(2,nres+i)
1071         zi=c(3,nres+i)
1072 C Change 12/1/95
1073         num_conti=0
1074 C
1075 C Calculate SC interaction energy.
1076 C
1077         do iint=1,nint_gr(i)
1078 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1079 cd   &                  'iend=',iend(i,iint)
1080           do j=istart(i,iint),iend(i,iint)
1081             itypj=itype(j)
1082             if (itypj.eq.21) cycle
1083             xj=c(1,nres+j)-xi
1084             yj=c(2,nres+j)-yi
1085             zj=c(3,nres+j)-zi
1086 C Change 12/1/95 to calculate four-body interactions
1087             rij=xj*xj+yj*yj+zj*zj
1088             rrij=1.0D0/rij
1089 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1090             eps0ij=eps(itypi,itypj)
1091             fac=rrij**expon2
1092             e1=fac*fac*aa(itypi,itypj)
1093             e2=fac*bb(itypi,itypj)
1094             evdwij=e1+e2
1095 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1096 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1097 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1098 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1099 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1100 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1101             evdw=evdw+evdwij
1102 C
1103 C Calculate the components of the gradient in DC and X
1104 C
1105             fac=-rrij*(e1+evdwij)
1106             gg(1)=xj*fac
1107             gg(2)=yj*fac
1108             gg(3)=zj*fac
1109             do k=1,3
1110               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1111               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1112               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1113               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1114             enddo
1115 cgrad            do k=i,j-1
1116 cgrad              do l=1,3
1117 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1118 cgrad              enddo
1119 cgrad            enddo
1120 C
1121 C 12/1/95, revised on 5/20/97
1122 C
1123 C Calculate the contact function. The ith column of the array JCONT will
1124 C contain the numbers of atoms that make contacts with the atom I (of numbers
1125 C greater than I). The arrays FACONT and GACONT will contain the values of
1126 C the contact function and its derivative.
1127 C
1128 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1129 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1130 C Uncomment next line, if the correlation interactions are contact function only
1131             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1132               rij=dsqrt(rij)
1133               sigij=sigma(itypi,itypj)
1134               r0ij=rs0(itypi,itypj)
1135 C
1136 C Check whether the SC's are not too far to make a contact.
1137 C
1138               rcut=1.5d0*r0ij
1139               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1140 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1141 C
1142               if (fcont.gt.0.0D0) then
1143 C If the SC-SC distance if close to sigma, apply spline.
1144 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1145 cAdam &             fcont1,fprimcont1)
1146 cAdam           fcont1=1.0d0-fcont1
1147 cAdam           if (fcont1.gt.0.0d0) then
1148 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1149 cAdam             fcont=fcont*fcont1
1150 cAdam           endif
1151 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1152 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1153 cga             do k=1,3
1154 cga               gg(k)=gg(k)*eps0ij
1155 cga             enddo
1156 cga             eps0ij=-evdwij*eps0ij
1157 C Uncomment for AL's type of SC correlation interactions.
1158 cadam           eps0ij=-evdwij
1159                 num_conti=num_conti+1
1160                 jcont(num_conti,i)=j
1161                 facont(num_conti,i)=fcont*eps0ij
1162                 fprimcont=eps0ij*fprimcont/rij
1163                 fcont=expon*fcont
1164 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1165 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1166 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1167 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1168                 gacont(1,num_conti,i)=-fprimcont*xj
1169                 gacont(2,num_conti,i)=-fprimcont*yj
1170                 gacont(3,num_conti,i)=-fprimcont*zj
1171 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1172 cd              write (iout,'(2i3,3f10.5)')
1173 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1174               endif
1175             endif
1176           enddo      ! j
1177         enddo        ! iint
1178 C Change 12/1/95
1179         num_cont(i)=num_conti
1180       enddo          ! i
1181       do i=1,nct
1182         do j=1,3
1183           gvdwc(j,i)=expon*gvdwc(j,i)
1184           gvdwx(j,i)=expon*gvdwx(j,i)
1185         enddo
1186       enddo
1187 C******************************************************************************
1188 C
1189 C                              N O T E !!!
1190 C
1191 C To save time, the factor of EXPON has been extracted from ALL components
1192 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1193 C use!
1194 C
1195 C******************************************************************************
1196       return
1197       end
1198 C-----------------------------------------------------------------------------
1199       subroutine eljk(evdw)
1200 C
1201 C This subroutine calculates the interaction energy of nonbonded side chains
1202 C assuming the LJK potential of interaction.
1203 C
1204       implicit real*8 (a-h,o-z)
1205       include 'DIMENSIONS'
1206       include 'COMMON.GEO'
1207       include 'COMMON.VAR'
1208       include 'COMMON.LOCAL'
1209       include 'COMMON.CHAIN'
1210       include 'COMMON.DERIV'
1211       include 'COMMON.INTERACT'
1212       include 'COMMON.IOUNITS'
1213       include 'COMMON.NAMES'
1214       dimension gg(3)
1215       logical scheck
1216 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1217       evdw=0.0D0
1218       do i=iatsc_s,iatsc_e
1219         itypi=itype(i)
1220         if (itypi.eq.21) cycle
1221         itypi1=itype(i+1)
1222         xi=c(1,nres+i)
1223         yi=c(2,nres+i)
1224         zi=c(3,nres+i)
1225 C
1226 C Calculate SC interaction energy.
1227 C
1228         do iint=1,nint_gr(i)
1229           do j=istart(i,iint),iend(i,iint)
1230             itypj=itype(j)
1231             if (itypj.eq.21) cycle
1232             xj=c(1,nres+j)-xi
1233             yj=c(2,nres+j)-yi
1234             zj=c(3,nres+j)-zi
1235             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1236             fac_augm=rrij**expon
1237             e_augm=augm(itypi,itypj)*fac_augm
1238             r_inv_ij=dsqrt(rrij)
1239             rij=1.0D0/r_inv_ij
1240             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1241             fac=r_shift_inv**expon
1242             e1=fac*fac*aa(itypi,itypj)
1243             e2=fac*bb(itypi,itypj)
1244             evdwij=e_augm+e1+e2
1245 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1246 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1247 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1248 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1249 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1250 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1251 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1252             evdw=evdw+evdwij
1253 C
1254 C Calculate the components of the gradient in DC and X
1255 C
1256             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1257             gg(1)=xj*fac
1258             gg(2)=yj*fac
1259             gg(3)=zj*fac
1260             do k=1,3
1261               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1262               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1263               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1264               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1265             enddo
1266 cgrad            do k=i,j-1
1267 cgrad              do l=1,3
1268 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1269 cgrad              enddo
1270 cgrad            enddo
1271           enddo      ! j
1272         enddo        ! iint
1273       enddo          ! i
1274       do i=1,nct
1275         do j=1,3
1276           gvdwc(j,i)=expon*gvdwc(j,i)
1277           gvdwx(j,i)=expon*gvdwx(j,i)
1278         enddo
1279       enddo
1280       return
1281       end
1282 C-----------------------------------------------------------------------------
1283       subroutine ebp(evdw)
1284 C
1285 C This subroutine calculates the interaction energy of nonbonded side chains
1286 C assuming the Berne-Pechukas potential of interaction.
1287 C
1288       implicit real*8 (a-h,o-z)
1289       include 'DIMENSIONS'
1290       include 'COMMON.GEO'
1291       include 'COMMON.VAR'
1292       include 'COMMON.LOCAL'
1293       include 'COMMON.CHAIN'
1294       include 'COMMON.DERIV'
1295       include 'COMMON.NAMES'
1296       include 'COMMON.INTERACT'
1297       include 'COMMON.IOUNITS'
1298       include 'COMMON.CALC'
1299       common /srutu/ icall
1300 c     double precision rrsave(maxdim)
1301       logical lprn
1302       evdw=0.0D0
1303 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1304       evdw=0.0D0
1305 c     if (icall.eq.0) then
1306 c       lprn=.true.
1307 c     else
1308         lprn=.false.
1309 c     endif
1310       ind=0
1311       do i=iatsc_s,iatsc_e
1312         itypi=itype(i)
1313         if (itypi.eq.21) cycle
1314         itypi1=itype(i+1)
1315         xi=c(1,nres+i)
1316         yi=c(2,nres+i)
1317         zi=c(3,nres+i)
1318         dxi=dc_norm(1,nres+i)
1319         dyi=dc_norm(2,nres+i)
1320         dzi=dc_norm(3,nres+i)
1321 c        dsci_inv=dsc_inv(itypi)
1322         dsci_inv=vbld_inv(i+nres)
1323 C
1324 C Calculate SC interaction energy.
1325 C
1326         do iint=1,nint_gr(i)
1327           do j=istart(i,iint),iend(i,iint)
1328             ind=ind+1
1329             itypj=itype(j)
1330             if (itypj.eq.21) cycle
1331 c            dscj_inv=dsc_inv(itypj)
1332             dscj_inv=vbld_inv(j+nres)
1333             chi1=chi(itypi,itypj)
1334             chi2=chi(itypj,itypi)
1335             chi12=chi1*chi2
1336             chip1=chip(itypi)
1337             chip2=chip(itypj)
1338             chip12=chip1*chip2
1339             alf1=alp(itypi)
1340             alf2=alp(itypj)
1341             alf12=0.5D0*(alf1+alf2)
1342 C For diagnostics only!!!
1343 c           chi1=0.0D0
1344 c           chi2=0.0D0
1345 c           chi12=0.0D0
1346 c           chip1=0.0D0
1347 c           chip2=0.0D0
1348 c           chip12=0.0D0
1349 c           alf1=0.0D0
1350 c           alf2=0.0D0
1351 c           alf12=0.0D0
1352             xj=c(1,nres+j)-xi
1353             yj=c(2,nres+j)-yi
1354             zj=c(3,nres+j)-zi
1355             dxj=dc_norm(1,nres+j)
1356             dyj=dc_norm(2,nres+j)
1357             dzj=dc_norm(3,nres+j)
1358             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1359 cd          if (icall.eq.0) then
1360 cd            rrsave(ind)=rrij
1361 cd          else
1362 cd            rrij=rrsave(ind)
1363 cd          endif
1364             rij=dsqrt(rrij)
1365 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1366             call sc_angular
1367 C Calculate whole angle-dependent part of epsilon and contributions
1368 C to its derivatives
1369             fac=(rrij*sigsq)**expon2
1370             e1=fac*fac*aa(itypi,itypj)
1371             e2=fac*bb(itypi,itypj)
1372             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1373             eps2der=evdwij*eps3rt
1374             eps3der=evdwij*eps2rt
1375             evdwij=evdwij*eps2rt*eps3rt
1376             evdw=evdw+evdwij
1377             if (lprn) then
1378             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1379             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1380 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1381 cd     &        restyp(itypi),i,restyp(itypj),j,
1382 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1383 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1384 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1385 cd     &        evdwij
1386             endif
1387 C Calculate gradient components.
1388             e1=e1*eps1*eps2rt**2*eps3rt**2
1389             fac=-expon*(e1+evdwij)
1390             sigder=fac/sigsq
1391             fac=rrij*fac
1392 C Calculate radial part of the gradient
1393             gg(1)=xj*fac
1394             gg(2)=yj*fac
1395             gg(3)=zj*fac
1396 C Calculate the angular part of the gradient and sum add the contributions
1397 C to the appropriate components of the Cartesian gradient.
1398             call sc_grad
1399           enddo      ! j
1400         enddo        ! iint
1401       enddo          ! i
1402 c     stop
1403       return
1404       end
1405 C-----------------------------------------------------------------------------
1406       subroutine egb(evdw)
1407 C
1408 C This subroutine calculates the interaction energy of nonbonded side chains
1409 C assuming the Gay-Berne potential of interaction.
1410 C
1411       implicit real*8 (a-h,o-z)
1412       include 'DIMENSIONS'
1413       include 'COMMON.GEO'
1414       include 'COMMON.VAR'
1415       include 'COMMON.LOCAL'
1416       include 'COMMON.CHAIN'
1417       include 'COMMON.DERIV'
1418       include 'COMMON.NAMES'
1419       include 'COMMON.INTERACT'
1420       include 'COMMON.IOUNITS'
1421       include 'COMMON.CALC'
1422       include 'COMMON.CONTROL'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       evdw=0.0D0
1426 ccccc      energy_dec=.false.
1427 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1428       evdw=0.0D0
1429       lprn=.false.
1430 c     if (icall.eq.0) lprn=.false.
1431       ind=0
1432       do i=iatsc_s,iatsc_e
1433         itypi=itype(i)
1434         if (itypi.eq.21) cycle
1435         itypi1=itype(i+1)
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1445 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1446 C
1447 C Calculate SC interaction energy.
1448 C
1449         do iint=1,nint_gr(i)
1450           do j=istart(i,iint),iend(i,iint)
1451             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1452               call dyn_ssbond_ene(i,j,evdwij)
1453               evdw=evdw+evdwij
1454               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1455      &                        'evdw',i,j,evdwij,' ss'
1456             ELSE
1457             ind=ind+1
1458             itypj=itype(j)
1459             if (itypj.eq.21) cycle
1460 c            dscj_inv=dsc_inv(itypj)
1461             dscj_inv=vbld_inv(j+nres)
1462 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1463 c     &       1.0d0/vbld(j+nres)
1464 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1465             sig0ij=sigma(itypi,itypj)
1466             chi1=chi(itypi,itypj)
1467             chi2=chi(itypj,itypi)
1468             chi12=chi1*chi2
1469             chip1=chip(itypi)
1470             chip2=chip(itypj)
1471             chip12=chip1*chip2
1472             alf1=alp(itypi)
1473             alf2=alp(itypj)
1474             alf12=0.5D0*(alf1+alf2)
1475 C For diagnostics only!!!
1476 c           chi1=0.0D0
1477 c           chi2=0.0D0
1478 c           chi12=0.0D0
1479 c           chip1=0.0D0
1480 c           chip2=0.0D0
1481 c           chip12=0.0D0
1482 c           alf1=0.0D0
1483 c           alf2=0.0D0
1484 c           alf12=0.0D0
1485             xj=c(1,nres+j)-xi
1486             yj=c(2,nres+j)-yi
1487             zj=c(3,nres+j)-zi
1488             dxj=dc_norm(1,nres+j)
1489             dyj=dc_norm(2,nres+j)
1490             dzj=dc_norm(3,nres+j)
1491 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1492 c            write (iout,*) "j",j," dc_norm",
1493 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1494             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1495             rij=dsqrt(rrij)
1496 C Calculate angle-dependent terms of energy and contributions to their
1497 C derivatives.
1498             call sc_angular
1499             sigsq=1.0D0/sigsq
1500             sig=sig0ij*dsqrt(sigsq)
1501             rij_shift=1.0D0/rij-sig+sig0ij
1502 c for diagnostics; uncomment
1503 c            rij_shift=1.2*sig0ij
1504 C I hate to put IF's in the loops, but here don't have another choice!!!!
1505             if (rij_shift.le.0.0D0) then
1506               evdw=1.0D20
1507 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1508 cd     &        restyp(itypi),i,restyp(itypj),j,
1509 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1510               return
1511             endif
1512             sigder=-sig*sigsq
1513 c---------------------------------------------------------------
1514             rij_shift=1.0D0/rij_shift
1515             fac=rij_shift**expon
1516             e1=fac*fac*aa(itypi,itypj)
1517             e2=fac*bb(itypi,itypj)
1518             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1519             eps2der=evdwij*eps3rt
1520             eps3der=evdwij*eps2rt
1521 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1522 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1523             evdwij=evdwij*eps2rt*eps3rt
1524             evdw=evdw+evdwij
1525             if (lprn) then
1526             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1527             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1528             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1529      &        restyp(itypi),i,restyp(itypj),j,
1530      &        epsi,sigm,chi1,chi2,chip1,chip2,
1531      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1532      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1533      &        evdwij
1534             endif
1535
1536             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1537      &                        'evdw',i,j,evdwij
1538
1539 C Calculate gradient components.
1540             e1=e1*eps1*eps2rt**2*eps3rt**2
1541             fac=-expon*(e1+evdwij)*rij_shift
1542             sigder=fac*sigder
1543             fac=rij*fac
1544 c            fac=0.0d0
1545 C Calculate the radial part of the gradient
1546             gg(1)=xj*fac
1547             gg(2)=yj*fac
1548             gg(3)=zj*fac
1549 C Calculate angular part of the gradient.
1550             call sc_grad
1551             ENDIF    ! dyn_ss
1552           enddo      ! j
1553         enddo        ! iint
1554       enddo          ! i
1555 c      write (iout,*) "Number of loop steps in EGB:",ind
1556 cccc      energy_dec=.false.
1557       return
1558       end
1559 C-----------------------------------------------------------------------------
1560       subroutine egbv(evdw)
1561 C
1562 C This subroutine calculates the interaction energy of nonbonded side chains
1563 C assuming the Gay-Berne-Vorobjev potential of interaction.
1564 C
1565       implicit real*8 (a-h,o-z)
1566       include 'DIMENSIONS'
1567       include 'COMMON.GEO'
1568       include 'COMMON.VAR'
1569       include 'COMMON.LOCAL'
1570       include 'COMMON.CHAIN'
1571       include 'COMMON.DERIV'
1572       include 'COMMON.NAMES'
1573       include 'COMMON.INTERACT'
1574       include 'COMMON.IOUNITS'
1575       include 'COMMON.CALC'
1576       common /srutu/ icall
1577       logical lprn
1578       evdw=0.0D0
1579 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1580       evdw=0.0D0
1581       lprn=.false.
1582 c     if (icall.eq.0) lprn=.true.
1583       ind=0
1584       do i=iatsc_s,iatsc_e
1585         itypi=itype(i)
1586         if (itypi.eq.21) cycle
1587         itypi1=itype(i+1)
1588         xi=c(1,nres+i)
1589         yi=c(2,nres+i)
1590         zi=c(3,nres+i)
1591         dxi=dc_norm(1,nres+i)
1592         dyi=dc_norm(2,nres+i)
1593         dzi=dc_norm(3,nres+i)
1594 c        dsci_inv=dsc_inv(itypi)
1595         dsci_inv=vbld_inv(i+nres)
1596 C
1597 C Calculate SC interaction energy.
1598 C
1599         do iint=1,nint_gr(i)
1600           do j=istart(i,iint),iend(i,iint)
1601             ind=ind+1
1602             itypj=itype(j)
1603             if (itypj.eq.21) cycle
1604 c            dscj_inv=dsc_inv(itypj)
1605             dscj_inv=vbld_inv(j+nres)
1606             sig0ij=sigma(itypi,itypj)
1607             r0ij=r0(itypi,itypj)
1608             chi1=chi(itypi,itypj)
1609             chi2=chi(itypj,itypi)
1610             chi12=chi1*chi2
1611             chip1=chip(itypi)
1612             chip2=chip(itypj)
1613             chip12=chip1*chip2
1614             alf1=alp(itypi)
1615             alf2=alp(itypj)
1616             alf12=0.5D0*(alf1+alf2)
1617 C For diagnostics only!!!
1618 c           chi1=0.0D0
1619 c           chi2=0.0D0
1620 c           chi12=0.0D0
1621 c           chip1=0.0D0
1622 c           chip2=0.0D0
1623 c           chip12=0.0D0
1624 c           alf1=0.0D0
1625 c           alf2=0.0D0
1626 c           alf12=0.0D0
1627             xj=c(1,nres+j)-xi
1628             yj=c(2,nres+j)-yi
1629             zj=c(3,nres+j)-zi
1630             dxj=dc_norm(1,nres+j)
1631             dyj=dc_norm(2,nres+j)
1632             dzj=dc_norm(3,nres+j)
1633             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1634             rij=dsqrt(rrij)
1635 C Calculate angle-dependent terms of energy and contributions to their
1636 C derivatives.
1637             call sc_angular
1638             sigsq=1.0D0/sigsq
1639             sig=sig0ij*dsqrt(sigsq)
1640             rij_shift=1.0D0/rij-sig+r0ij
1641 C I hate to put IF's in the loops, but here don't have another choice!!!!
1642             if (rij_shift.le.0.0D0) then
1643               evdw=1.0D20
1644               return
1645             endif
1646             sigder=-sig*sigsq
1647 c---------------------------------------------------------------
1648             rij_shift=1.0D0/rij_shift
1649             fac=rij_shift**expon
1650             e1=fac*fac*aa(itypi,itypj)
1651             e2=fac*bb(itypi,itypj)
1652             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1653             eps2der=evdwij*eps3rt
1654             eps3der=evdwij*eps2rt
1655             fac_augm=rrij**expon
1656             e_augm=augm(itypi,itypj)*fac_augm
1657             evdwij=evdwij*eps2rt*eps3rt
1658             evdw=evdw+evdwij+e_augm
1659             if (lprn) then
1660             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1661             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1662             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1663      &        restyp(itypi),i,restyp(itypj),j,
1664      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1665      &        chi1,chi2,chip1,chip2,
1666      &        eps1,eps2rt**2,eps3rt**2,
1667      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1668      &        evdwij+e_augm
1669             endif
1670 C Calculate gradient components.
1671             e1=e1*eps1*eps2rt**2*eps3rt**2
1672             fac=-expon*(e1+evdwij)*rij_shift
1673             sigder=fac*sigder
1674             fac=rij*fac-2*expon*rrij*e_augm
1675 C Calculate the radial part of the gradient
1676             gg(1)=xj*fac
1677             gg(2)=yj*fac
1678             gg(3)=zj*fac
1679 C Calculate angular part of the gradient.
1680             call sc_grad
1681           enddo      ! j
1682         enddo        ! iint
1683       enddo          ! i
1684       end
1685 C-----------------------------------------------------------------------------
1686       subroutine sc_angular
1687 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1688 C om12. Called by ebp, egb, and egbv.
1689       implicit none
1690       include 'COMMON.CALC'
1691       include 'COMMON.IOUNITS'
1692       erij(1)=xj*rij
1693       erij(2)=yj*rij
1694       erij(3)=zj*rij
1695       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1696       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1697       om12=dxi*dxj+dyi*dyj+dzi*dzj
1698       chiom12=chi12*om12
1699 C Calculate eps1(om12) and its derivative in om12
1700       faceps1=1.0D0-om12*chiom12
1701       faceps1_inv=1.0D0/faceps1
1702       eps1=dsqrt(faceps1_inv)
1703 C Following variable is eps1*deps1/dom12
1704       eps1_om12=faceps1_inv*chiom12
1705 c diagnostics only
1706 c      faceps1_inv=om12
1707 c      eps1=om12
1708 c      eps1_om12=1.0d0
1709 c      write (iout,*) "om12",om12," eps1",eps1
1710 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1711 C and om12.
1712       om1om2=om1*om2
1713       chiom1=chi1*om1
1714       chiom2=chi2*om2
1715       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1716       sigsq=1.0D0-facsig*faceps1_inv
1717       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1718       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1719       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1720 c diagnostics only
1721 c      sigsq=1.0d0
1722 c      sigsq_om1=0.0d0
1723 c      sigsq_om2=0.0d0
1724 c      sigsq_om12=0.0d0
1725 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1726 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1727 c     &    " eps1",eps1
1728 C Calculate eps2 and its derivatives in om1, om2, and om12.
1729       chipom1=chip1*om1
1730       chipom2=chip2*om2
1731       chipom12=chip12*om12
1732       facp=1.0D0-om12*chipom12
1733       facp_inv=1.0D0/facp
1734       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1735 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1736 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1737 C Following variable is the square root of eps2
1738       eps2rt=1.0D0-facp1*facp_inv
1739 C Following three variables are the derivatives of the square root of eps
1740 C in om1, om2, and om12.
1741       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1742       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1743       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1744 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1745       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1746 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1747 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1748 c     &  " eps2rt_om12",eps2rt_om12
1749 C Calculate whole angle-dependent part of epsilon and contributions
1750 C to its derivatives
1751       return
1752       end
1753 C----------------------------------------------------------------------------
1754       subroutine sc_grad
1755       implicit real*8 (a-h,o-z)
1756       include 'DIMENSIONS'
1757       include 'COMMON.CHAIN'
1758       include 'COMMON.DERIV'
1759       include 'COMMON.CALC'
1760       include 'COMMON.IOUNITS'
1761       double precision dcosom1(3),dcosom2(3)
1762       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1763       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1764       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1765      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1766 c diagnostics only
1767 c      eom1=0.0d0
1768 c      eom2=0.0d0
1769 c      eom12=evdwij*eps1_om12
1770 c end diagnostics
1771 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1772 c     &  " sigder",sigder
1773 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1774 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1775       do k=1,3
1776         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1777         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1778       enddo
1779       do k=1,3
1780         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1781       enddo
1782 c      write (iout,*) "gg",(gg(k),k=1,3)
1783       do k=1,3
1784         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1785      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1786      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1787         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1788      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1789      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1790 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1791 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1792 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1793 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1794       enddo
1795 C
1796 C Calculate the components of the gradient in DC and X
1797 C
1798 cgrad      do k=i,j-1
1799 cgrad        do l=1,3
1800 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1801 cgrad        enddo
1802 cgrad      enddo
1803       do l=1,3
1804         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1805         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1806       enddo
1807       return
1808       end
1809 C-----------------------------------------------------------------------
1810       subroutine e_softsphere(evdw)
1811 C
1812 C This subroutine calculates the interaction energy of nonbonded side chains
1813 C assuming the LJ potential of interaction.
1814 C
1815       implicit real*8 (a-h,o-z)
1816       include 'DIMENSIONS'
1817       parameter (accur=1.0d-10)
1818       include 'COMMON.GEO'
1819       include 'COMMON.VAR'
1820       include 'COMMON.LOCAL'
1821       include 'COMMON.CHAIN'
1822       include 'COMMON.DERIV'
1823       include 'COMMON.INTERACT'
1824       include 'COMMON.TORSION'
1825       include 'COMMON.SBRIDGE'
1826       include 'COMMON.NAMES'
1827       include 'COMMON.IOUNITS'
1828       include 'COMMON.CONTACTS'
1829       dimension gg(3)
1830 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1831       evdw=0.0D0
1832       do i=iatsc_s,iatsc_e
1833         itypi=itype(i)
1834         if (itypi.eq.21) cycle
1835         itypi1=itype(i+1)
1836         xi=c(1,nres+i)
1837         yi=c(2,nres+i)
1838         zi=c(3,nres+i)
1839 C
1840 C Calculate SC interaction energy.
1841 C
1842         do iint=1,nint_gr(i)
1843 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1844 cd   &                  'iend=',iend(i,iint)
1845           do j=istart(i,iint),iend(i,iint)
1846             itypj=itype(j)
1847             if (itypj.eq.21) cycle
1848             xj=c(1,nres+j)-xi
1849             yj=c(2,nres+j)-yi
1850             zj=c(3,nres+j)-zi
1851             rij=xj*xj+yj*yj+zj*zj
1852 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1853             r0ij=r0(itypi,itypj)
1854             r0ijsq=r0ij*r0ij
1855 c            print *,i,j,r0ij,dsqrt(rij)
1856             if (rij.lt.r0ijsq) then
1857               evdwij=0.25d0*(rij-r0ijsq)**2
1858               fac=rij-r0ijsq
1859             else
1860               evdwij=0.0d0
1861               fac=0.0d0
1862             endif
1863             evdw=evdw+evdwij
1864 C
1865 C Calculate the components of the gradient in DC and X
1866 C
1867             gg(1)=xj*fac
1868             gg(2)=yj*fac
1869             gg(3)=zj*fac
1870             do k=1,3
1871               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1872               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1873               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1874               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1875             enddo
1876 cgrad            do k=i,j-1
1877 cgrad              do l=1,3
1878 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1879 cgrad              enddo
1880 cgrad            enddo
1881           enddo ! j
1882         enddo ! iint
1883       enddo ! i
1884       return
1885       end
1886 C--------------------------------------------------------------------------
1887       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1888      &              eello_turn4)
1889 C
1890 C Soft-sphere potential of p-p interaction
1891 C
1892       implicit real*8 (a-h,o-z)
1893       include 'DIMENSIONS'
1894       include 'COMMON.CONTROL'
1895       include 'COMMON.IOUNITS'
1896       include 'COMMON.GEO'
1897       include 'COMMON.VAR'
1898       include 'COMMON.LOCAL'
1899       include 'COMMON.CHAIN'
1900       include 'COMMON.DERIV'
1901       include 'COMMON.INTERACT'
1902       include 'COMMON.CONTACTS'
1903       include 'COMMON.TORSION'
1904       include 'COMMON.VECTORS'
1905       include 'COMMON.FFIELD'
1906       dimension ggg(3)
1907 cd      write(iout,*) 'In EELEC_soft_sphere'
1908       ees=0.0D0
1909       evdw1=0.0D0
1910       eel_loc=0.0d0
1911       eello_turn3=0.0d0
1912       eello_turn4=0.0d0
1913       ind=0
1914       do i=iatel_s,iatel_e
1915         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1916         dxi=dc(1,i)
1917         dyi=dc(2,i)
1918         dzi=dc(3,i)
1919         xmedi=c(1,i)+0.5d0*dxi
1920         ymedi=c(2,i)+0.5d0*dyi
1921         zmedi=c(3,i)+0.5d0*dzi
1922         num_conti=0
1923 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1924         do j=ielstart(i),ielend(i)
1925           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1926           ind=ind+1
1927           iteli=itel(i)
1928           itelj=itel(j)
1929           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1930           r0ij=rpp(iteli,itelj)
1931           r0ijsq=r0ij*r0ij
1932           dxj=dc(1,j)
1933           dyj=dc(2,j)
1934           dzj=dc(3,j)
1935           xj=c(1,j)+0.5D0*dxj-xmedi
1936           yj=c(2,j)+0.5D0*dyj-ymedi
1937           zj=c(3,j)+0.5D0*dzj-zmedi
1938           rij=xj*xj+yj*yj+zj*zj
1939           if (rij.lt.r0ijsq) then
1940             evdw1ij=0.25d0*(rij-r0ijsq)**2
1941             fac=rij-r0ijsq
1942           else
1943             evdw1ij=0.0d0
1944             fac=0.0d0
1945           endif
1946           evdw1=evdw1+evdw1ij
1947 C
1948 C Calculate contributions to the Cartesian gradient.
1949 C
1950           ggg(1)=fac*xj
1951           ggg(2)=fac*yj
1952           ggg(3)=fac*zj
1953           do k=1,3
1954             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1955             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1956           enddo
1957 *
1958 * Loop over residues i+1 thru j-1.
1959 *
1960 cgrad          do k=i+1,j-1
1961 cgrad            do l=1,3
1962 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1963 cgrad            enddo
1964 cgrad          enddo
1965         enddo ! j
1966       enddo   ! i
1967 cgrad      do i=nnt,nct-1
1968 cgrad        do k=1,3
1969 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1970 cgrad        enddo
1971 cgrad        do j=i+1,nct-1
1972 cgrad          do k=1,3
1973 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1974 cgrad          enddo
1975 cgrad        enddo
1976 cgrad      enddo
1977       return
1978       end
1979 c------------------------------------------------------------------------------
1980       subroutine vec_and_deriv
1981       implicit real*8 (a-h,o-z)
1982       include 'DIMENSIONS'
1983 #ifdef MPI
1984       include 'mpif.h'
1985 #endif
1986       include 'COMMON.IOUNITS'
1987       include 'COMMON.GEO'
1988       include 'COMMON.VAR'
1989       include 'COMMON.LOCAL'
1990       include 'COMMON.CHAIN'
1991       include 'COMMON.VECTORS'
1992       include 'COMMON.SETUP'
1993       include 'COMMON.TIME1'
1994       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1995 C Compute the local reference systems. For reference system (i), the
1996 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1997 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1998 #ifdef PARVEC
1999       do i=ivec_start,ivec_end
2000 #else
2001       do i=1,nres-1
2002 #endif
2003           if (i.eq.nres-1) then
2004 C Case of the last full residue
2005 C Compute the Z-axis
2006             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2007             costh=dcos(pi-theta(nres))
2008             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2009             do k=1,3
2010               uz(k,i)=fac*uz(k,i)
2011             enddo
2012 C Compute the derivatives of uz
2013             uzder(1,1,1)= 0.0d0
2014             uzder(2,1,1)=-dc_norm(3,i-1)
2015             uzder(3,1,1)= dc_norm(2,i-1)
2016             uzder(1,2,1)= dc_norm(3,i-1)
2017             uzder(2,2,1)= 0.0d0
2018             uzder(3,2,1)=-dc_norm(1,i-1)
2019             uzder(1,3,1)=-dc_norm(2,i-1)
2020             uzder(2,3,1)= dc_norm(1,i-1)
2021             uzder(3,3,1)= 0.0d0
2022             uzder(1,1,2)= 0.0d0
2023             uzder(2,1,2)= dc_norm(3,i)
2024             uzder(3,1,2)=-dc_norm(2,i)
2025             uzder(1,2,2)=-dc_norm(3,i)
2026             uzder(2,2,2)= 0.0d0
2027             uzder(3,2,2)= dc_norm(1,i)
2028             uzder(1,3,2)= dc_norm(2,i)
2029             uzder(2,3,2)=-dc_norm(1,i)
2030             uzder(3,3,2)= 0.0d0
2031 C Compute the Y-axis
2032             facy=fac
2033             do k=1,3
2034               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2035             enddo
2036 C Compute the derivatives of uy
2037             do j=1,3
2038               do k=1,3
2039                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2040      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2041                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2042               enddo
2043               uyder(j,j,1)=uyder(j,j,1)-costh
2044               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2045             enddo
2046             do j=1,2
2047               do k=1,3
2048                 do l=1,3
2049                   uygrad(l,k,j,i)=uyder(l,k,j)
2050                   uzgrad(l,k,j,i)=uzder(l,k,j)
2051                 enddo
2052               enddo
2053             enddo
2054             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2055             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2056             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2057             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2058           else
2059 C Other residues
2060 C Compute the Z-axis
2061             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2062             costh=dcos(pi-theta(i+2))
2063             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2064             do k=1,3
2065               uz(k,i)=fac*uz(k,i)
2066             enddo
2067 C Compute the derivatives of uz
2068             uzder(1,1,1)= 0.0d0
2069             uzder(2,1,1)=-dc_norm(3,i+1)
2070             uzder(3,1,1)= dc_norm(2,i+1)
2071             uzder(1,2,1)= dc_norm(3,i+1)
2072             uzder(2,2,1)= 0.0d0
2073             uzder(3,2,1)=-dc_norm(1,i+1)
2074             uzder(1,3,1)=-dc_norm(2,i+1)
2075             uzder(2,3,1)= dc_norm(1,i+1)
2076             uzder(3,3,1)= 0.0d0
2077             uzder(1,1,2)= 0.0d0
2078             uzder(2,1,2)= dc_norm(3,i)
2079             uzder(3,1,2)=-dc_norm(2,i)
2080             uzder(1,2,2)=-dc_norm(3,i)
2081             uzder(2,2,2)= 0.0d0
2082             uzder(3,2,2)= dc_norm(1,i)
2083             uzder(1,3,2)= dc_norm(2,i)
2084             uzder(2,3,2)=-dc_norm(1,i)
2085             uzder(3,3,2)= 0.0d0
2086 C Compute the Y-axis
2087             facy=fac
2088             do k=1,3
2089               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2090             enddo
2091 C Compute the derivatives of uy
2092             do j=1,3
2093               do k=1,3
2094                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2095      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2096                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2097               enddo
2098               uyder(j,j,1)=uyder(j,j,1)-costh
2099               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2100             enddo
2101             do j=1,2
2102               do k=1,3
2103                 do l=1,3
2104                   uygrad(l,k,j,i)=uyder(l,k,j)
2105                   uzgrad(l,k,j,i)=uzder(l,k,j)
2106                 enddo
2107               enddo
2108             enddo
2109             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2110             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2111             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2112             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2113           endif
2114       enddo
2115       do i=1,nres-1
2116         vbld_inv_temp(1)=vbld_inv(i+1)
2117         if (i.lt.nres-1) then
2118           vbld_inv_temp(2)=vbld_inv(i+2)
2119           else
2120           vbld_inv_temp(2)=vbld_inv(i)
2121           endif
2122         do j=1,2
2123           do k=1,3
2124             do l=1,3
2125               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2126               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2127             enddo
2128           enddo
2129         enddo
2130       enddo
2131 #if defined(PARVEC) && defined(MPI)
2132       if (nfgtasks1.gt.1) then
2133         time00=MPI_Wtime()
2134 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2135 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2136 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2137         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2138      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2139      &   FG_COMM1,IERR)
2140         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2141      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2142      &   FG_COMM1,IERR)
2143         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2144      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2145      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2146         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2147      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2148      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2149         time_gather=time_gather+MPI_Wtime()-time00
2150       endif
2151 c      if (fg_rank.eq.0) then
2152 c        write (iout,*) "Arrays UY and UZ"
2153 c        do i=1,nres-1
2154 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2155 c     &     (uz(k,i),k=1,3)
2156 c        enddo
2157 c      endif
2158 #endif
2159       return
2160       end
2161 C-----------------------------------------------------------------------------
2162       subroutine check_vecgrad
2163       implicit real*8 (a-h,o-z)
2164       include 'DIMENSIONS'
2165       include 'COMMON.IOUNITS'
2166       include 'COMMON.GEO'
2167       include 'COMMON.VAR'
2168       include 'COMMON.LOCAL'
2169       include 'COMMON.CHAIN'
2170       include 'COMMON.VECTORS'
2171       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2172       dimension uyt(3,maxres),uzt(3,maxres)
2173       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2174       double precision delta /1.0d-7/
2175       call vec_and_deriv
2176 cd      do i=1,nres
2177 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2178 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2179 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2180 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2181 cd     &     (dc_norm(if90,i),if90=1,3)
2182 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2183 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2184 cd          write(iout,'(a)')
2185 cd      enddo
2186       do i=1,nres
2187         do j=1,2
2188           do k=1,3
2189             do l=1,3
2190               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2191               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2192             enddo
2193           enddo
2194         enddo
2195       enddo
2196       call vec_and_deriv
2197       do i=1,nres
2198         do j=1,3
2199           uyt(j,i)=uy(j,i)
2200           uzt(j,i)=uz(j,i)
2201         enddo
2202       enddo
2203       do i=1,nres
2204 cd        write (iout,*) 'i=',i
2205         do k=1,3
2206           erij(k)=dc_norm(k,i)
2207         enddo
2208         do j=1,3
2209           do k=1,3
2210             dc_norm(k,i)=erij(k)
2211           enddo
2212           dc_norm(j,i)=dc_norm(j,i)+delta
2213 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2214 c          do k=1,3
2215 c            dc_norm(k,i)=dc_norm(k,i)/fac
2216 c          enddo
2217 c          write (iout,*) (dc_norm(k,i),k=1,3)
2218 c          write (iout,*) (erij(k),k=1,3)
2219           call vec_and_deriv
2220           do k=1,3
2221             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2222             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2223             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2224             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2225           enddo
2226 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2227 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2228 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2229         enddo
2230         do k=1,3
2231           dc_norm(k,i)=erij(k)
2232         enddo
2233 cd        do k=1,3
2234 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2235 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2236 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2237 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2238 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2239 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2240 cd          write (iout,'(a)')
2241 cd        enddo
2242       enddo
2243       return
2244       end
2245 C--------------------------------------------------------------------------
2246       subroutine set_matrices
2247       implicit real*8 (a-h,o-z)
2248       include 'DIMENSIONS'
2249 #ifdef MPI
2250       include "mpif.h"
2251       include "COMMON.SETUP"
2252       integer IERR
2253       integer status(MPI_STATUS_SIZE)
2254 #endif
2255       include 'COMMON.IOUNITS'
2256       include 'COMMON.GEO'
2257       include 'COMMON.VAR'
2258       include 'COMMON.LOCAL'
2259       include 'COMMON.CHAIN'
2260       include 'COMMON.DERIV'
2261       include 'COMMON.INTERACT'
2262       include 'COMMON.CONTACTS'
2263       include 'COMMON.TORSION'
2264       include 'COMMON.VECTORS'
2265       include 'COMMON.FFIELD'
2266       double precision auxvec(2),auxmat(2,2)
2267 C
2268 C Compute the virtual-bond-torsional-angle dependent quantities needed
2269 C to calculate the el-loc multibody terms of various order.
2270 C
2271 #ifdef PARMAT
2272       do i=ivec_start+2,ivec_end+2
2273 #else
2274       do i=3,nres+1
2275 #endif
2276         if (i .lt. nres+1) then
2277           sin1=dsin(phi(i))
2278           cos1=dcos(phi(i))
2279           sintab(i-2)=sin1
2280           costab(i-2)=cos1
2281           obrot(1,i-2)=cos1
2282           obrot(2,i-2)=sin1
2283           sin2=dsin(2*phi(i))
2284           cos2=dcos(2*phi(i))
2285           sintab2(i-2)=sin2
2286           costab2(i-2)=cos2
2287           obrot2(1,i-2)=cos2
2288           obrot2(2,i-2)=sin2
2289           Ug(1,1,i-2)=-cos1
2290           Ug(1,2,i-2)=-sin1
2291           Ug(2,1,i-2)=-sin1
2292           Ug(2,2,i-2)= cos1
2293           Ug2(1,1,i-2)=-cos2
2294           Ug2(1,2,i-2)=-sin2
2295           Ug2(2,1,i-2)=-sin2
2296           Ug2(2,2,i-2)= cos2
2297         else
2298           costab(i-2)=1.0d0
2299           sintab(i-2)=0.0d0
2300           obrot(1,i-2)=1.0d0
2301           obrot(2,i-2)=0.0d0
2302           obrot2(1,i-2)=0.0d0
2303           obrot2(2,i-2)=0.0d0
2304           Ug(1,1,i-2)=1.0d0
2305           Ug(1,2,i-2)=0.0d0
2306           Ug(2,1,i-2)=0.0d0
2307           Ug(2,2,i-2)=1.0d0
2308           Ug2(1,1,i-2)=0.0d0
2309           Ug2(1,2,i-2)=0.0d0
2310           Ug2(2,1,i-2)=0.0d0
2311           Ug2(2,2,i-2)=0.0d0
2312         endif
2313         if (i .gt. 3 .and. i .lt. nres+1) then
2314           obrot_der(1,i-2)=-sin1
2315           obrot_der(2,i-2)= cos1
2316           Ugder(1,1,i-2)= sin1
2317           Ugder(1,2,i-2)=-cos1
2318           Ugder(2,1,i-2)=-cos1
2319           Ugder(2,2,i-2)=-sin1
2320           dwacos2=cos2+cos2
2321           dwasin2=sin2+sin2
2322           obrot2_der(1,i-2)=-dwasin2
2323           obrot2_der(2,i-2)= dwacos2
2324           Ug2der(1,1,i-2)= dwasin2
2325           Ug2der(1,2,i-2)=-dwacos2
2326           Ug2der(2,1,i-2)=-dwacos2
2327           Ug2der(2,2,i-2)=-dwasin2
2328         else
2329           obrot_der(1,i-2)=0.0d0
2330           obrot_der(2,i-2)=0.0d0
2331           Ugder(1,1,i-2)=0.0d0
2332           Ugder(1,2,i-2)=0.0d0
2333           Ugder(2,1,i-2)=0.0d0
2334           Ugder(2,2,i-2)=0.0d0
2335           obrot2_der(1,i-2)=0.0d0
2336           obrot2_der(2,i-2)=0.0d0
2337           Ug2der(1,1,i-2)=0.0d0
2338           Ug2der(1,2,i-2)=0.0d0
2339           Ug2der(2,1,i-2)=0.0d0
2340           Ug2der(2,2,i-2)=0.0d0
2341         endif
2342 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2343         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2344 c        write(iout,*) (itype(i-2))
2345           iti = itortyp(itype(i-2))
2346         else
2347           iti=ntortyp+1
2348         endif
2349 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2350         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2351           iti1 = itortyp(itype(i-1))
2352         else
2353           iti1=ntortyp+1
2354         endif
2355 cd        write (iout,*) '*******i',i,' iti1',iti
2356 cd        write (iout,*) 'b1',b1(:,iti)
2357 cd        write (iout,*) 'b2',b2(:,iti)
2358 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2359 c        if (i .gt. iatel_s+2) then
2360         if (i .gt. nnt+2) then
2361           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2362           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2363           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2364      &    then
2365           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2366           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2367           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2368           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2369           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2370           endif
2371         else
2372           do k=1,2
2373             Ub2(k,i-2)=0.0d0
2374             Ctobr(k,i-2)=0.0d0
2375             Dtobr2(k,i-2)=0.0d0
2376             do l=1,2
2377               EUg(l,k,i-2)=0.0d0
2378               CUg(l,k,i-2)=0.0d0
2379               DUg(l,k,i-2)=0.0d0
2380               DtUg2(l,k,i-2)=0.0d0
2381             enddo
2382           enddo
2383         endif
2384         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2385         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2386         do k=1,2
2387           muder(k,i-2)=Ub2der(k,i-2)
2388         enddo
2389 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2390         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2391           iti1 = itortyp(itype(i-1))
2392         else
2393           iti1=ntortyp+1
2394         endif
2395         do k=1,2
2396           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2397         enddo
2398 cd        write (iout,*) 'mu ',mu(:,i-2)
2399 cd        write (iout,*) 'mu1',mu1(:,i-2)
2400 cd        write (iout,*) 'mu2',mu2(:,i-2)
2401         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2402      &  then
2403         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2404         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2405         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2406         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2407         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2408 C Vectors and matrices dependent on a single virtual-bond dihedral.
2409         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2410         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2411         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2412         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2413         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2414         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2415         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2416         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2417         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2418         endif
2419       enddo
2420 C Matrices dependent on two consecutive virtual-bond dihedrals.
2421 C The order of matrices is from left to right.
2422       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2423      &then
2424 c      do i=max0(ivec_start,2),ivec_end
2425       do i=2,nres-1
2426         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2427         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2428         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2429         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2430         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2431         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2432         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2433         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2434       enddo
2435       endif
2436 #if defined(MPI) && defined(PARMAT)
2437 #ifdef DEBUG
2438 c      if (fg_rank.eq.0) then
2439         write (iout,*) "Arrays UG and UGDER before GATHER"
2440         do i=1,nres-1
2441           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2442      &     ((ug(l,k,i),l=1,2),k=1,2),
2443      &     ((ugder(l,k,i),l=1,2),k=1,2)
2444         enddo
2445         write (iout,*) "Arrays UG2 and UG2DER"
2446         do i=1,nres-1
2447           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2448      &     ((ug2(l,k,i),l=1,2),k=1,2),
2449      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2450         enddo
2451         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2452         do i=1,nres-1
2453           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2454      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2455      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2456         enddo
2457         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2458         do i=1,nres-1
2459           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2460      &     costab(i),sintab(i),costab2(i),sintab2(i)
2461         enddo
2462         write (iout,*) "Array MUDER"
2463         do i=1,nres-1
2464           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2465         enddo
2466 c      endif
2467 #endif
2468       if (nfgtasks.gt.1) then
2469         time00=MPI_Wtime()
2470 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2471 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2472 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2473 #ifdef MATGATHER
2474         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2475      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2476      &   FG_COMM1,IERR)
2477         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2478      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2479      &   FG_COMM1,IERR)
2480         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2481      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2482      &   FG_COMM1,IERR)
2483         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2484      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2485      &   FG_COMM1,IERR)
2486         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2487      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2488      &   FG_COMM1,IERR)
2489         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2490      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2491      &   FG_COMM1,IERR)
2492         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2493      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2494      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2495         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2496      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2497      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2498         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2499      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2500      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2501         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2502      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2503      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2504         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2505      &  then
2506         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2507      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2508      &   FG_COMM1,IERR)
2509         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2510      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2511      &   FG_COMM1,IERR)
2512         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2513      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2514      &   FG_COMM1,IERR)
2515        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2516      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2517      &   FG_COMM1,IERR)
2518         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2519      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2522      &   ivec_count(fg_rank1),
2523      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2524      &   FG_COMM1,IERR)
2525         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2526      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2527      &   FG_COMM1,IERR)
2528         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2529      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2530      &   FG_COMM1,IERR)
2531         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2532      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2533      &   FG_COMM1,IERR)
2534         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2535      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2536      &   FG_COMM1,IERR)
2537         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2538      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2539      &   FG_COMM1,IERR)
2540         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2544      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2547      &   ivec_count(fg_rank1),
2548      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2549      &   FG_COMM1,IERR)
2550         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2552      &   FG_COMM1,IERR)
2553        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2555      &   FG_COMM1,IERR)
2556         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2557      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2558      &   FG_COMM1,IERR)
2559        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2560      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2563      &   ivec_count(fg_rank1),
2564      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2567      &   ivec_count(fg_rank1),
2568      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2571      &   ivec_count(fg_rank1),
2572      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2573      &   MPI_MAT2,FG_COMM1,IERR)
2574         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2575      &   ivec_count(fg_rank1),
2576      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2577      &   MPI_MAT2,FG_COMM1,IERR)
2578         endif
2579 #else
2580 c Passes matrix info through the ring
2581       isend=fg_rank1
2582       irecv=fg_rank1-1
2583       if (irecv.lt.0) irecv=nfgtasks1-1
2584       iprev=irecv
2585       inext=fg_rank1+1
2586       if (inext.ge.nfgtasks1) inext=0
2587       do i=1,nfgtasks1-1
2588 c        write (iout,*) "isend",isend," irecv",irecv
2589 c        call flush(iout)
2590         lensend=lentyp(isend)
2591         lenrecv=lentyp(irecv)
2592 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2593 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2594 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2595 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2596 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2597 c        write (iout,*) "Gather ROTAT1"
2598 c        call flush(iout)
2599 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2600 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2601 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2602 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2603 c        write (iout,*) "Gather ROTAT2"
2604 c        call flush(iout)
2605         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2606      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2607      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2608      &   iprev,4400+irecv,FG_COMM,status,IERR)
2609 c        write (iout,*) "Gather ROTAT_OLD"
2610 c        call flush(iout)
2611         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2612      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2613      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2614      &   iprev,5500+irecv,FG_COMM,status,IERR)
2615 c        write (iout,*) "Gather PRECOMP11"
2616 c        call flush(iout)
2617         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2618      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2619      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2620      &   iprev,6600+irecv,FG_COMM,status,IERR)
2621 c        write (iout,*) "Gather PRECOMP12"
2622 c        call flush(iout)
2623         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2624      &  then
2625         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2626      &   MPI_ROTAT2(lensend),inext,7700+isend,
2627      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2628      &   iprev,7700+irecv,FG_COMM,status,IERR)
2629 c        write (iout,*) "Gather PRECOMP21"
2630 c        call flush(iout)
2631         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2632      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2633      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2634      &   iprev,8800+irecv,FG_COMM,status,IERR)
2635 c        write (iout,*) "Gather PRECOMP22"
2636 c        call flush(iout)
2637         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2638      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2639      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2640      &   MPI_PRECOMP23(lenrecv),
2641      &   iprev,9900+irecv,FG_COMM,status,IERR)
2642 c        write (iout,*) "Gather PRECOMP23"
2643 c        call flush(iout)
2644         endif
2645         isend=irecv
2646         irecv=irecv-1
2647         if (irecv.lt.0) irecv=nfgtasks1-1
2648       enddo
2649 #endif
2650         time_gather=time_gather+MPI_Wtime()-time00
2651       endif
2652 #ifdef DEBUG
2653 c      if (fg_rank.eq.0) then
2654         write (iout,*) "Arrays UG and UGDER"
2655         do i=1,nres-1
2656           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2657      &     ((ug(l,k,i),l=1,2),k=1,2),
2658      &     ((ugder(l,k,i),l=1,2),k=1,2)
2659         enddo
2660         write (iout,*) "Arrays UG2 and UG2DER"
2661         do i=1,nres-1
2662           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2663      &     ((ug2(l,k,i),l=1,2),k=1,2),
2664      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2665         enddo
2666         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2667         do i=1,nres-1
2668           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2669      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2670      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2671         enddo
2672         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2673         do i=1,nres-1
2674           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2675      &     costab(i),sintab(i),costab2(i),sintab2(i)
2676         enddo
2677         write (iout,*) "Array MUDER"
2678         do i=1,nres-1
2679           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2680         enddo
2681 c      endif
2682 #endif
2683 #endif
2684 cd      do i=1,nres
2685 cd        iti = itortyp(itype(i))
2686 cd        write (iout,*) i
2687 cd        do j=1,2
2688 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2689 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2690 cd        enddo
2691 cd      enddo
2692       return
2693       end
2694 C--------------------------------------------------------------------------
2695       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2696 C
2697 C This subroutine calculates the average interaction energy and its gradient
2698 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2699 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2700 C The potential depends both on the distance of peptide-group centers and on
2701 C the orientation of the CA-CA virtual bonds.
2702 C
2703       implicit real*8 (a-h,o-z)
2704 #ifdef MPI
2705       include 'mpif.h'
2706 #endif
2707       include 'DIMENSIONS'
2708       include 'COMMON.CONTROL'
2709       include 'COMMON.SETUP'
2710       include 'COMMON.IOUNITS'
2711       include 'COMMON.GEO'
2712       include 'COMMON.VAR'
2713       include 'COMMON.LOCAL'
2714       include 'COMMON.CHAIN'
2715       include 'COMMON.DERIV'
2716       include 'COMMON.INTERACT'
2717       include 'COMMON.CONTACTS'
2718       include 'COMMON.TORSION'
2719       include 'COMMON.VECTORS'
2720       include 'COMMON.FFIELD'
2721       include 'COMMON.TIME1'
2722       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2723      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2724       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2725      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),eel_loc_ij
2726       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2727      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2728      &    num_conti,j1,j2
2729 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2730 #ifdef MOMENT
2731       double precision scal_el /1.0d0/
2732 #else
2733       double precision scal_el /0.5d0/
2734 #endif
2735 C 12/13/98
2736 C 13-go grudnia roku pamietnego...
2737       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2738      &                   0.0d0,1.0d0,0.0d0,
2739      &                   0.0d0,0.0d0,1.0d0/
2740 cd      write(iout,*) 'In EELEC'
2741 cd      do i=1,nloctyp
2742 cd        write(iout,*) 'Type',i
2743 cd        write(iout,*) 'B1',B1(:,i)
2744 cd        write(iout,*) 'B2',B2(:,i)
2745 cd        write(iout,*) 'CC',CC(:,:,i)
2746 cd        write(iout,*) 'DD',DD(:,:,i)
2747 cd        write(iout,*) 'EE',EE(:,:,i)
2748 cd      enddo
2749 cd      call check_vecgrad
2750 cd      stop
2751       if (icheckgrad.eq.1) then
2752         do i=1,nres-1
2753           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2754           do k=1,3
2755             dc_norm(k,i)=dc(k,i)*fac
2756           enddo
2757 c          write (iout,*) 'i',i,' fac',fac
2758         enddo
2759       endif
2760       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2761      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2762      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2763 c        call vec_and_deriv
2764 #ifdef TIMING
2765         time01=MPI_Wtime()
2766 #endif
2767         call set_matrices
2768 c        write (iout,*) "after set matrices"
2769 #ifdef TIMING
2770         time_mat=time_mat+MPI_Wtime()-time01
2771 #endif
2772       endif
2773 cd      do i=1,nres-1
2774 cd        write (iout,*) 'i=',i
2775 cd        do k=1,3
2776 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2777 cd        enddo
2778 cd        do k=1,3
2779 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2780 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2781 cd        enddo
2782 cd      enddo
2783       t_eelecij=0.0d0
2784       ees=0.0D0
2785       evdw1=0.0D0
2786       eel_loc=0.0d0
2787       eello_turn3=0.0d0
2788       eello_turn4=0.0d0
2789       ind=0
2790       do i=1,nres
2791         num_cont_hb(i)=0
2792       enddo
2793 cd      print '(a)','Enter EELEC'
2794 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2795       do i=1,nres
2796         gel_loc_loc(i)=0.0d0
2797         gcorr_loc(i)=0.0d0
2798       enddo
2799 c
2800 c
2801 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2802 C
2803 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2804 C
2805 c      write(iout,*) "przed turnem3 loop"
2806       do i=iturn3_start,iturn3_end
2807         if (itype(i).eq.21 .or. itype(i+1).eq.21
2808      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2809         dxi=dc(1,i)
2810         dyi=dc(2,i)
2811         dzi=dc(3,i)
2812         dx_normi=dc_norm(1,i)
2813         dy_normi=dc_norm(2,i)
2814         dz_normi=dc_norm(3,i)
2815         xmedi=c(1,i)+0.5d0*dxi
2816         ymedi=c(2,i)+0.5d0*dyi
2817         zmedi=c(3,i)+0.5d0*dzi
2818         num_conti=0
2819         call eelecij(i,i+2,ees,evdw1,eel_loc)
2820         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2821         num_cont_hb(i)=num_conti
2822       enddo
2823       do i=iturn4_start,iturn4_end
2824         if (itype(i).eq.21 .or. itype(i+1).eq.21
2825      &    .or. itype(i+3).eq.21
2826      &    .or. itype(i+4).eq.21) cycle
2827         dxi=dc(1,i)
2828         dyi=dc(2,i)
2829         dzi=dc(3,i)
2830         dx_normi=dc_norm(1,i)
2831         dy_normi=dc_norm(2,i)
2832         dz_normi=dc_norm(3,i)
2833         xmedi=c(1,i)+0.5d0*dxi
2834         ymedi=c(2,i)+0.5d0*dyi
2835         zmedi=c(3,i)+0.5d0*dzi
2836         num_conti=num_cont_hb(i)
2837         call eelecij(i,i+3,ees,evdw1,eel_loc)
2838         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2839      &   call eturn4(i,eello_turn4)
2840         num_cont_hb(i)=num_conti
2841       enddo   ! i
2842 c
2843 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2844 c
2845       do i=iatel_s,iatel_e
2846         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2847         dxi=dc(1,i)
2848         dyi=dc(2,i)
2849         dzi=dc(3,i)
2850         dx_normi=dc_norm(1,i)
2851         dy_normi=dc_norm(2,i)
2852         dz_normi=dc_norm(3,i)
2853         xmedi=c(1,i)+0.5d0*dxi
2854         ymedi=c(2,i)+0.5d0*dyi
2855         zmedi=c(3,i)+0.5d0*dzi
2856 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2857         num_conti=num_cont_hb(i)
2858         do j=ielstart(i),ielend(i)
2859 c          write (iout,*) i,j,itype(i),itype(j)
2860           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2861           call eelecij(i,j,ees,evdw1,eel_loc)
2862         enddo ! j
2863         num_cont_hb(i)=num_conti
2864       enddo   ! i
2865 c      write (iout,*) "Number of loop steps in EELEC:",ind
2866 cd      do i=1,nres
2867 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2868 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2869 cd      enddo
2870 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2871 ccc      eel_loc=eel_loc+eello_turn3
2872 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2873       return
2874       end
2875 C-------------------------------------------------------------------------------
2876       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2877       implicit real*8 (a-h,o-z)
2878       include 'DIMENSIONS'
2879 #ifdef MPI
2880       include "mpif.h"
2881 #endif
2882       include 'COMMON.CONTROL'
2883       include 'COMMON.IOUNITS'
2884       include 'COMMON.GEO'
2885       include 'COMMON.VAR'
2886       include 'COMMON.LOCAL'
2887       include 'COMMON.CHAIN'
2888       include 'COMMON.DERIV'
2889       include 'COMMON.INTERACT'
2890       include 'COMMON.CONTACTS'
2891       include 'COMMON.TORSION'
2892       include 'COMMON.VECTORS'
2893       include 'COMMON.FFIELD'
2894       include 'COMMON.TIME1'
2895       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2896      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2897       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2898      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),a22,a23,a32,a33
2899       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2900      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2901      &    num_conti,j1,j2
2902 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2903 #ifdef MOMENT
2904       double precision scal_el /1.0d0/
2905 #else
2906       double precision scal_el /0.5d0/
2907 #endif
2908 C 12/13/98
2909 C 13-go grudnia roku pamietnego...
2910       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2911      &                   0.0d0,1.0d0,0.0d0,
2912      &                   0.0d0,0.0d0,1.0d0/
2913 c          time00=MPI_Wtime()
2914 cd      write (iout,*) "eelecij",i,j
2915 c          ind=ind+1
2916           iteli=itel(i)
2917           itelj=itel(j)
2918           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2919           aaa=app(iteli,itelj)
2920           bbb=bpp(iteli,itelj)
2921           ael6i=ael6(iteli,itelj)
2922           ael3i=ael3(iteli,itelj)
2923           dxj=dc(1,j)
2924           dyj=dc(2,j)
2925           dzj=dc(3,j)
2926           dx_normj=dc_norm(1,j)
2927           dy_normj=dc_norm(2,j)
2928           dz_normj=dc_norm(3,j)
2929           xj=c(1,j)+0.5D0*dxj-xmedi
2930           yj=c(2,j)+0.5D0*dyj-ymedi
2931           zj=c(3,j)+0.5D0*dzj-zmedi
2932           rij=xj*xj+yj*yj+zj*zj
2933           rrmij=1.0D0/rij
2934           rij=dsqrt(rij)
2935           rmij=1.0D0/rij
2936           r3ij=rrmij*rmij
2937           r6ij=r3ij*r3ij
2938           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2939           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2940           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2941           fac=cosa-3.0D0*cosb*cosg
2942           ev1=aaa*r6ij*r6ij
2943 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2944           if (j.eq.i+2) ev1=scal_el*ev1
2945           ev2=bbb*r6ij
2946           fac3=ael6i*r6ij
2947           fac4=ael3i*r3ij
2948           evdwij=ev1+ev2
2949           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2950           el2=fac4*fac
2951           eesij=el1+el2
2952 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2953           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2954           ees=ees+eesij
2955           evdw1=evdw1+evdwij
2956 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2957 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2958 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2959 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2960
2961           if (energy_dec) then
2962               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2963               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2964           endif
2965
2966 C
2967 C Calculate contributions to the Cartesian gradient.
2968 C
2969 #ifdef SPLITELE
2970           facvdw=-6*rrmij*(ev1+evdwij)
2971           facel=-3*rrmij*(el1+eesij)
2972           fac1=fac
2973           erij(1)=xj*rmij
2974           erij(2)=yj*rmij
2975           erij(3)=zj*rmij
2976 *
2977 * Radial derivatives. First process both termini of the fragment (i,j)
2978 *
2979           ggg(1)=facel*xj
2980           ggg(2)=facel*yj
2981           ggg(3)=facel*zj
2982 c          do k=1,3
2983 c            ghalf=0.5D0*ggg(k)
2984 c            gelc(k,i)=gelc(k,i)+ghalf
2985 c            gelc(k,j)=gelc(k,j)+ghalf
2986 c          enddo
2987 c 9/28/08 AL Gradient compotents will be summed only at the end
2988           do k=1,3
2989             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2990             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2991           enddo
2992 *
2993 * Loop over residues i+1 thru j-1.
2994 *
2995 cgrad          do k=i+1,j-1
2996 cgrad            do l=1,3
2997 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2998 cgrad            enddo
2999 cgrad          enddo
3000           ggg(1)=facvdw*xj
3001           ggg(2)=facvdw*yj
3002           ggg(3)=facvdw*zj
3003 c          do k=1,3
3004 c            ghalf=0.5D0*ggg(k)
3005 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3006 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3007 c          enddo
3008 c 9/28/08 AL Gradient compotents will be summed only at the end
3009           do k=1,3
3010             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3011             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3012           enddo
3013 *
3014 * Loop over residues i+1 thru j-1.
3015 *
3016 cgrad          do k=i+1,j-1
3017 cgrad            do l=1,3
3018 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3019 cgrad            enddo
3020 cgrad          enddo
3021 #else
3022           facvdw=ev1+evdwij
3023           facel=el1+eesij
3024           fac1=fac
3025           fac=-3*rrmij*(facvdw+facvdw+facel)
3026           erij(1)=xj*rmij
3027           erij(2)=yj*rmij
3028           erij(3)=zj*rmij
3029 *
3030 * Radial derivatives. First process both termini of the fragment (i,j)
3031 *
3032           ggg(1)=fac*xj
3033           ggg(2)=fac*yj
3034           ggg(3)=fac*zj
3035 c          do k=1,3
3036 c            ghalf=0.5D0*ggg(k)
3037 c            gelc(k,i)=gelc(k,i)+ghalf
3038 c            gelc(k,j)=gelc(k,j)+ghalf
3039 c          enddo
3040 c 9/28/08 AL Gradient compotents will be summed only at the end
3041           do k=1,3
3042             gelc_long(k,j)=gelc(k,j)+ggg(k)
3043             gelc_long(k,i)=gelc(k,i)-ggg(k)
3044           enddo
3045 *
3046 * Loop over residues i+1 thru j-1.
3047 *
3048 cgrad          do k=i+1,j-1
3049 cgrad            do l=1,3
3050 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3051 cgrad            enddo
3052 cgrad          enddo
3053 c 9/28/08 AL Gradient compotents will be summed only at the end
3054           ggg(1)=facvdw*xj
3055           ggg(2)=facvdw*yj
3056           ggg(3)=facvdw*zj
3057           do k=1,3
3058             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3059             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3060           enddo
3061 #endif
3062 *
3063 * Angular part
3064 *
3065           ecosa=2.0D0*fac3*fac1+fac4
3066           fac4=-3.0D0*fac4
3067           fac3=-6.0D0*fac3
3068           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3069           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3070           do k=1,3
3071             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3072             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3073           enddo
3074 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3075 cd   &          (dcosg(k),k=1,3)
3076           do k=1,3
3077             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3078           enddo
3079 c          do k=1,3
3080 c            ghalf=0.5D0*ggg(k)
3081 c            gelc(k,i)=gelc(k,i)+ghalf
3082 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3083 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3084 c            gelc(k,j)=gelc(k,j)+ghalf
3085 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3086 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3087 c          enddo
3088 cgrad          do k=i+1,j-1
3089 cgrad            do l=1,3
3090 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3091 cgrad            enddo
3092 cgrad          enddo
3093           do k=1,3
3094             gelc(k,i)=gelc(k,i)
3095      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3096      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3097             gelc(k,j)=gelc(k,j)
3098      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3099      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3100             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3101             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3102           enddo
3103           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3104      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3105      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3106 C
3107 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3108 C   energy of a peptide unit is assumed in the form of a second-order
3109 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3110 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3111 C   are computed for EVERY pair of non-contiguous peptide groups.
3112 C
3113           if (j.lt.nres-1) then
3114             j1=j+1
3115             j2=j-1
3116           else
3117             j1=j-1
3118             j2=j-2
3119           endif
3120           kkk=0
3121           do k=1,2
3122             do l=1,2
3123               kkk=kkk+1
3124               muij(kkk)=mu(k,i)*mu(l,j)
3125             enddo
3126           enddo
3127 cd         write (iout,*) 'EELEC: i',i,' j',j
3128 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3129 cd          write(iout,*) 'muij',muij
3130           ury=scalar(uy(1,i),erij)
3131           urz=scalar(uz(1,i),erij)
3132           vry=scalar(uy(1,j),erij)
3133           vrz=scalar(uz(1,j),erij)
3134           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3135           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3136           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3137           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3138           fac=dsqrt(-ael6i)*r3ij
3139           a22=a22*fac
3140           a23=a23*fac
3141           a32=a32*fac
3142           a33=a33*fac
3143 cd          write (iout,'(4i5,4f10.5)')
3144 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3145 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3146 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3147 cd     &      uy(:,j),uz(:,j)
3148 cd          write (iout,'(4f10.5)')
3149 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3150 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3151 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3152 cd           write (iout,'(9f10.5/)')
3153 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3154 C Derivatives of the elements of A in virtual-bond vectors
3155           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3156           do k=1,3
3157             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3158             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3159             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3160             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3161             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3162             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3163             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3164             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3165             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3166             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3167             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3168             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3169           enddo
3170 C Compute radial contributions to the gradient
3171           facr=-3.0d0*rrmij
3172           a22der=a22*facr
3173           a23der=a23*facr
3174           a32der=a32*facr
3175           a33der=a33*facr
3176           agg(1,1)=a22der*xj
3177           agg(2,1)=a22der*yj
3178           agg(3,1)=a22der*zj
3179           agg(1,2)=a23der*xj
3180           agg(2,2)=a23der*yj
3181           agg(3,2)=a23der*zj
3182           agg(1,3)=a32der*xj
3183           agg(2,3)=a32der*yj
3184           agg(3,3)=a32der*zj
3185           agg(1,4)=a33der*xj
3186           agg(2,4)=a33der*yj
3187           agg(3,4)=a33der*zj
3188 C Add the contributions coming from er
3189           fac3=-3.0d0*fac
3190           do k=1,3
3191             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3192             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3193             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3194             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3195           enddo
3196           do k=1,3
3197 C Derivatives in DC(i)
3198 cgrad            ghalf1=0.5d0*agg(k,1)
3199 cgrad            ghalf2=0.5d0*agg(k,2)
3200 cgrad            ghalf3=0.5d0*agg(k,3)
3201 cgrad            ghalf4=0.5d0*agg(k,4)
3202             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3203      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3204             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3205      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3206             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3207      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3208             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3209      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3210 C Derivatives in DC(i+1)
3211             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3212      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3213             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3214      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3215             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3216      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3217             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3218      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3219 C Derivatives in DC(j)
3220             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3221      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3222             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3223      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3224             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3225      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3226             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3227      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3228 C Derivatives in DC(j+1) or DC(nres-1)
3229             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3230      &      -3.0d0*vryg(k,3)*ury)
3231             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3232      &      -3.0d0*vrzg(k,3)*ury)
3233             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3234      &      -3.0d0*vryg(k,3)*urz)
3235             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3236      &      -3.0d0*vrzg(k,3)*urz)
3237 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3238 cgrad              do l=1,4
3239 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3240 cgrad              enddo
3241 cgrad            endif
3242           enddo
3243           acipa(1,1)=a22
3244           acipa(1,2)=a23
3245           acipa(2,1)=a32
3246           acipa(2,2)=a33
3247           a22=-a22
3248           a23=-a23
3249           do l=1,2
3250             do k=1,3
3251               agg(k,l)=-agg(k,l)
3252               aggi(k,l)=-aggi(k,l)
3253               aggi1(k,l)=-aggi1(k,l)
3254               aggj(k,l)=-aggj(k,l)
3255               aggj1(k,l)=-aggj1(k,l)
3256             enddo
3257           enddo
3258           if (j.lt.nres-1) then
3259             a22=-a22
3260             a32=-a32
3261             do l=1,3,2
3262               do k=1,3
3263                 agg(k,l)=-agg(k,l)
3264                 aggi(k,l)=-aggi(k,l)
3265                 aggi1(k,l)=-aggi1(k,l)
3266                 aggj(k,l)=-aggj(k,l)
3267                 aggj1(k,l)=-aggj1(k,l)
3268               enddo
3269             enddo
3270           else
3271             a22=-a22
3272             a23=-a23
3273             a32=-a32
3274             a33=-a33
3275             do l=1,4
3276               do k=1,3
3277                 agg(k,l)=-agg(k,l)
3278                 aggi(k,l)=-aggi(k,l)
3279                 aggi1(k,l)=-aggi1(k,l)
3280                 aggj(k,l)=-aggj(k,l)
3281                 aggj1(k,l)=-aggj1(k,l)
3282               enddo
3283             enddo
3284           endif
3285           ENDIF ! WCORR
3286           IF (wel_loc.gt.0.0d0) THEN
3287 C Contribution to the local-electrostatic energy coming from the i-j pair
3288           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3289      &     +a33*muij(4)
3290 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3291
3292           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3293      &            'eelloc',i,j,eel_loc_ij
3294
3295           eel_loc=eel_loc+eel_loc_ij
3296 C Partial derivatives in virtual-bond dihedral angles gamma
3297           if (i.gt.1)
3298      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3299      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3300      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3301           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3302      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3303      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3304 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3305           do l=1,3
3306             ggg(l)=agg(l,1)*muij(1)+
3307      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3308             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3309             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3310 cgrad            ghalf=0.5d0*ggg(l)
3311 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3312 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3313           enddo
3314 cgrad          do k=i+1,j2
3315 cgrad            do l=1,3
3316 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3317 cgrad            enddo
3318 cgrad          enddo
3319 C Remaining derivatives of eello
3320           do l=1,3
3321             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3322      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3323             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3324      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3325             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3326      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3327             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3328      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3329           enddo
3330           ENDIF
3331 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3332 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3333           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3334      &       .and. num_conti.le.maxconts) then
3335 c            write (iout,*) i,j," entered corr"
3336 C
3337 C Calculate the contact function. The ith column of the array JCONT will
3338 C contain the numbers of atoms that make contacts with the atom I (of numbers
3339 C greater than I). The arrays FACONT and GACONT will contain the values of
3340 C the contact function and its derivative.
3341 c           r0ij=1.02D0*rpp(iteli,itelj)
3342 c           r0ij=1.11D0*rpp(iteli,itelj)
3343             r0ij=2.20D0*rpp(iteli,itelj)
3344 c           r0ij=1.55D0*rpp(iteli,itelj)
3345             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3346             if (fcont.gt.0.0D0) then
3347               num_conti=num_conti+1
3348               if (num_conti.gt.maxconts) then
3349                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3350      &                         ' will skip next contacts for this conf.'
3351               else
3352                 jcont_hb(num_conti,i)=j
3353 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3354 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3355                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3356      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3357 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3358 C  terms.
3359                 d_cont(num_conti,i)=rij
3360 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3361 C     --- Electrostatic-interaction matrix ---
3362                 a_chuj(1,1,num_conti,i)=a22
3363                 a_chuj(1,2,num_conti,i)=a23
3364                 a_chuj(2,1,num_conti,i)=a32
3365                 a_chuj(2,2,num_conti,i)=a33
3366 C     --- Gradient of rij
3367                 do kkk=1,3
3368                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3369                 enddo
3370                 kkll=0
3371                 do k=1,2
3372                   do l=1,2
3373                     kkll=kkll+1
3374                     do m=1,3
3375                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3376                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3377                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3378                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3379                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3380                     enddo
3381                   enddo
3382                 enddo
3383                 ENDIF
3384                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3385 C Calculate contact energies
3386                 cosa4=4.0D0*cosa
3387                 wij=cosa-3.0D0*cosb*cosg
3388                 cosbg1=cosb+cosg
3389                 cosbg2=cosb-cosg
3390 c               fac3=dsqrt(-ael6i)/r0ij**3
3391                 fac3=dsqrt(-ael6i)*r3ij
3392 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3393                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3394                 if (ees0tmp.gt.0) then
3395                   ees0pij=dsqrt(ees0tmp)
3396                 else
3397                   ees0pij=0
3398                 endif
3399 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3400                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3401                 if (ees0tmp.gt.0) then
3402                   ees0mij=dsqrt(ees0tmp)
3403                 else
3404                   ees0mij=0
3405                 endif
3406 c               ees0mij=0.0D0
3407                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3408                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3409 C Diagnostics. Comment out or remove after debugging!
3410 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3411 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3412 c               ees0m(num_conti,i)=0.0D0
3413 C End diagnostics.
3414 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3415 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3416 C Angular derivatives of the contact function
3417                 ees0pij1=fac3/ees0pij
3418                 ees0mij1=fac3/ees0mij
3419                 fac3p=-3.0D0*fac3*rrmij
3420                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3421                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3422 c               ees0mij1=0.0D0
3423                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3424                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3425                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3426                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3427                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3428                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3429                 ecosap=ecosa1+ecosa2
3430                 ecosbp=ecosb1+ecosb2
3431                 ecosgp=ecosg1+ecosg2
3432                 ecosam=ecosa1-ecosa2
3433                 ecosbm=ecosb1-ecosb2
3434                 ecosgm=ecosg1-ecosg2
3435 C Diagnostics
3436 c               ecosap=ecosa1
3437 c               ecosbp=ecosb1
3438 c               ecosgp=ecosg1
3439 c               ecosam=0.0D0
3440 c               ecosbm=0.0D0
3441 c               ecosgm=0.0D0
3442 C End diagnostics
3443                 facont_hb(num_conti,i)=fcont
3444                 fprimcont=fprimcont/rij
3445 cd              facont_hb(num_conti,i)=1.0D0
3446 C Following line is for diagnostics.
3447 cd              fprimcont=0.0D0
3448                 do k=1,3
3449                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3450                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3451                 enddo
3452                 do k=1,3
3453                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3454                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3455                 enddo
3456                 gggp(1)=gggp(1)+ees0pijp*xj
3457                 gggp(2)=gggp(2)+ees0pijp*yj
3458                 gggp(3)=gggp(3)+ees0pijp*zj
3459                 gggm(1)=gggm(1)+ees0mijp*xj
3460                 gggm(2)=gggm(2)+ees0mijp*yj
3461                 gggm(3)=gggm(3)+ees0mijp*zj
3462 C Derivatives due to the contact function
3463                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3464                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3465                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3466                 do k=1,3
3467 c
3468 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3469 c          following the change of gradient-summation algorithm.
3470 c
3471 cgrad                  ghalfp=0.5D0*gggp(k)
3472 cgrad                  ghalfm=0.5D0*gggm(k)
3473                   gacontp_hb1(k,num_conti,i)=!ghalfp
3474      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3475      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3476                   gacontp_hb2(k,num_conti,i)=!ghalfp
3477      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3478      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3479                   gacontp_hb3(k,num_conti,i)=gggp(k)
3480                   gacontm_hb1(k,num_conti,i)=!ghalfm
3481      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3482      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3483                   gacontm_hb2(k,num_conti,i)=!ghalfm
3484      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3485      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3486                   gacontm_hb3(k,num_conti,i)=gggm(k)
3487                 enddo
3488 C Diagnostics. Comment out or remove after debugging!
3489 cdiag           do k=1,3
3490 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3491 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3492 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3493 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3494 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3495 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3496 cdiag           enddo
3497               ENDIF ! wcorr
3498               endif  ! num_conti.le.maxconts
3499             endif  ! fcont.gt.0
3500           endif    ! j.gt.i+1
3501           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3502             do k=1,4
3503               do l=1,3
3504                 ghalf=0.5d0*agg(l,k)
3505                 aggi(l,k)=aggi(l,k)+ghalf
3506                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3507                 aggj(l,k)=aggj(l,k)+ghalf
3508               enddo
3509             enddo
3510             if (j.eq.nres-1 .and. i.lt.j-2) then
3511               do k=1,4
3512                 do l=1,3
3513                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3514                 enddo
3515               enddo
3516             endif
3517           endif
3518 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3519       return
3520       end
3521 C-----------------------------------------------------------------------------
3522       subroutine eturn3(i,eello_turn3)
3523 C Third- and fourth-order contributions from turns
3524       implicit real*8 (a-h,o-z)
3525       include 'DIMENSIONS'
3526       include 'COMMON.IOUNITS'
3527       include 'COMMON.GEO'
3528       include 'COMMON.VAR'
3529       include 'COMMON.LOCAL'
3530       include 'COMMON.CHAIN'
3531       include 'COMMON.DERIV'
3532       include 'COMMON.INTERACT'
3533       include 'COMMON.CONTACTS'
3534       include 'COMMON.TORSION'
3535       include 'COMMON.VECTORS'
3536       include 'COMMON.FFIELD'
3537       include 'COMMON.CONTROL'
3538       dimension ggg(3)
3539       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3540      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3541      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3542       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3543      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3544       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3545      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3546      &    num_conti,j1,j2
3547       j=i+2
3548 c      write (iout,*) "eturn3",i,j,j1,j2
3549       a_temp(1,1)=a22
3550       a_temp(1,2)=a23
3551       a_temp(2,1)=a32
3552       a_temp(2,2)=a33
3553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3554 C
3555 C               Third-order contributions
3556 C
3557 C                 (i+2)o----(i+3)
3558 C                      | |
3559 C                      | |
3560 C                 (i+1)o----i
3561 C
3562 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3563 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3564         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3565         call transpose2(auxmat(1,1),auxmat1(1,1))
3566         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3567         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3568         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3569      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3570 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3571 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3572 cd     &    ' eello_turn3_num',4*eello_turn3_num
3573 C Derivatives in gamma(i)
3574         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3575         call transpose2(auxmat2(1,1),auxmat3(1,1))
3576         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3577         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3578 C Derivatives in gamma(i+1)
3579         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3580         call transpose2(auxmat2(1,1),auxmat3(1,1))
3581         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3582         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3583      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3584 C Cartesian derivatives
3585         do l=1,3
3586 c            ghalf1=0.5d0*agg(l,1)
3587 c            ghalf2=0.5d0*agg(l,2)
3588 c            ghalf3=0.5d0*agg(l,3)
3589 c            ghalf4=0.5d0*agg(l,4)
3590           a_temp(1,1)=aggi(l,1)!+ghalf1
3591           a_temp(1,2)=aggi(l,2)!+ghalf2
3592           a_temp(2,1)=aggi(l,3)!+ghalf3
3593           a_temp(2,2)=aggi(l,4)!+ghalf4
3594           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3595           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3596      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3597           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3598           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3599           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3600           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3601           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3602           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3603      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3604           a_temp(1,1)=aggj(l,1)!+ghalf1
3605           a_temp(1,2)=aggj(l,2)!+ghalf2
3606           a_temp(2,1)=aggj(l,3)!+ghalf3
3607           a_temp(2,2)=aggj(l,4)!+ghalf4
3608           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3609           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3610      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3611           a_temp(1,1)=aggj1(l,1)
3612           a_temp(1,2)=aggj1(l,2)
3613           a_temp(2,1)=aggj1(l,3)
3614           a_temp(2,2)=aggj1(l,4)
3615           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3616           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3617      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3618         enddo
3619       return
3620       end
3621 C-------------------------------------------------------------------------------
3622       subroutine eturn4(i,eello_turn4)
3623 C Third- and fourth-order contributions from turns
3624       implicit real*8 (a-h,o-z)
3625       include 'DIMENSIONS'
3626       include 'COMMON.IOUNITS'
3627       include 'COMMON.GEO'
3628       include 'COMMON.VAR'
3629       include 'COMMON.LOCAL'
3630       include 'COMMON.CHAIN'
3631       include 'COMMON.DERIV'
3632       include 'COMMON.INTERACT'
3633       include 'COMMON.CONTACTS'
3634       include 'COMMON.TORSION'
3635       include 'COMMON.VECTORS'
3636       include 'COMMON.FFIELD'
3637       include 'COMMON.CONTROL'
3638       dimension ggg(3)
3639       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3640      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3641      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3642       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3643      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3644       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3645      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3646      &    num_conti,j1,j2
3647       j=i+3
3648 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3649 C
3650 C               Fourth-order contributions
3651 C
3652 C                 (i+3)o----(i+4)
3653 C                     /  |
3654 C               (i+2)o   |
3655 C                     \  |
3656 C                 (i+1)o----i
3657 C
3658 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3659 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3660 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3661         a_temp(1,1)=a22
3662         a_temp(1,2)=a23
3663         a_temp(2,1)=a32
3664         a_temp(2,2)=a33
3665         iti1=itortyp(itype(i+1))
3666         iti2=itortyp(itype(i+2))
3667         iti3=itortyp(itype(i+3))
3668 C        write(iout,*) i,"iti1",iti1," iti2",iti2," iti3",iti3,itype(i+3)
3669         call transpose2(EUg(1,1,i+1),e1t(1,1))
3670         call transpose2(Eug(1,1,i+2),e2t(1,1))
3671         call transpose2(Eug(1,1,i+3),e3t(1,1))
3672         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3673         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3674         s1=scalar2(b1(1,iti2),auxvec(1))
3675         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3676         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3677         s2=scalar2(b1(1,iti1),auxvec(1))
3678         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3679         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3680         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3681         eello_turn4=eello_turn4-(s1+s2+s3)
3682         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3683      &      'eturn4',i,j,-(s1+s2+s3)
3684 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3685 cd     &    ' eello_turn4_num',8*eello_turn4_num
3686 C Derivatives in gamma(i)
3687         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3688         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3689         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3690         s1=scalar2(b1(1,iti2),auxvec(1))
3691         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3692         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3693         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3694 C Derivatives in gamma(i+1)
3695         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3696         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3697         s2=scalar2(b1(1,iti1),auxvec(1))
3698         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3699         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3700         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3701         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3702 C Derivatives in gamma(i+2)
3703         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3704         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3705         s1=scalar2(b1(1,iti2),auxvec(1))
3706         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3707         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3708         s2=scalar2(b1(1,iti1),auxvec(1))
3709         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3710         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3711         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3712         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3713 C Cartesian derivatives
3714 C Derivatives of this turn contributions in DC(i+2)
3715         if (j.lt.nres-1) then
3716           do l=1,3
3717             a_temp(1,1)=agg(l,1)
3718             a_temp(1,2)=agg(l,2)
3719             a_temp(2,1)=agg(l,3)
3720             a_temp(2,2)=agg(l,4)
3721             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3722             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3723             s1=scalar2(b1(1,iti2),auxvec(1))
3724             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3725             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3726             s2=scalar2(b1(1,iti1),auxvec(1))
3727             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3728             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3729             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3730             ggg(l)=-(s1+s2+s3)
3731             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3732           enddo
3733         endif
3734 C Remaining derivatives of this turn contribution
3735         do l=1,3
3736           a_temp(1,1)=aggi(l,1)
3737           a_temp(1,2)=aggi(l,2)
3738           a_temp(2,1)=aggi(l,3)
3739           a_temp(2,2)=aggi(l,4)
3740           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3741           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3742           s1=scalar2(b1(1,iti2),auxvec(1))
3743           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3744           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3745           s2=scalar2(b1(1,iti1),auxvec(1))
3746           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3747           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3748           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3749           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3750           a_temp(1,1)=aggi1(l,1)
3751           a_temp(1,2)=aggi1(l,2)
3752           a_temp(2,1)=aggi1(l,3)
3753           a_temp(2,2)=aggi1(l,4)
3754           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3755           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3756           s1=scalar2(b1(1,iti2),auxvec(1))
3757           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3758           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3759           s2=scalar2(b1(1,iti1),auxvec(1))
3760           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3761           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3762           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3763           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3764           a_temp(1,1)=aggj(l,1)
3765           a_temp(1,2)=aggj(l,2)
3766           a_temp(2,1)=aggj(l,3)
3767           a_temp(2,2)=aggj(l,4)
3768           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3769           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3770           s1=scalar2(b1(1,iti2),auxvec(1))
3771           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3772           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3773           s2=scalar2(b1(1,iti1),auxvec(1))
3774           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3775           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3776           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3777           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3778           a_temp(1,1)=aggj1(l,1)
3779           a_temp(1,2)=aggj1(l,2)
3780           a_temp(2,1)=aggj1(l,3)
3781           a_temp(2,2)=aggj1(l,4)
3782           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3783           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3784           s1=scalar2(b1(1,iti2),auxvec(1))
3785           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3786           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3787           s2=scalar2(b1(1,iti1),auxvec(1))
3788           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3789           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3790           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3791 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3792           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3793         enddo
3794       return
3795       end
3796 C-----------------------------------------------------------------------------
3797       subroutine vecpr(u,v,w)
3798       implicit real*8(a-h,o-z)
3799       dimension u(3),v(3),w(3)
3800       w(1)=u(2)*v(3)-u(3)*v(2)
3801       w(2)=-u(1)*v(3)+u(3)*v(1)
3802       w(3)=u(1)*v(2)-u(2)*v(1)
3803       return
3804       end
3805 C-----------------------------------------------------------------------------
3806       subroutine unormderiv(u,ugrad,unorm,ungrad)
3807 C This subroutine computes the derivatives of a normalized vector u, given
3808 C the derivatives computed without normalization conditions, ugrad. Returns
3809 C ungrad.
3810       implicit none
3811       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3812       double precision vec(3)
3813       double precision scalar
3814       integer i,j
3815 c      write (2,*) 'ugrad',ugrad
3816 c      write (2,*) 'u',u
3817       do i=1,3
3818         vec(i)=scalar(ugrad(1,i),u(1))
3819       enddo
3820 c      write (2,*) 'vec',vec
3821       do i=1,3
3822         do j=1,3
3823           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3824         enddo
3825       enddo
3826 c      write (2,*) 'ungrad',ungrad
3827       return
3828       end
3829 C-----------------------------------------------------------------------------
3830       subroutine escp_soft_sphere(evdw2,evdw2_14)
3831 C
3832 C This subroutine calculates the excluded-volume interaction energy between
3833 C peptide-group centers and side chains and its gradient in virtual-bond and
3834 C side-chain vectors.
3835 C
3836       implicit real*8 (a-h,o-z)
3837       include 'DIMENSIONS'
3838       include 'COMMON.GEO'
3839       include 'COMMON.VAR'
3840       include 'COMMON.LOCAL'
3841       include 'COMMON.CHAIN'
3842       include 'COMMON.DERIV'
3843       include 'COMMON.INTERACT'
3844       include 'COMMON.FFIELD'
3845       include 'COMMON.IOUNITS'
3846       include 'COMMON.CONTROL'
3847       dimension ggg(3)
3848       evdw2=0.0D0
3849       evdw2_14=0.0d0
3850       r0_scp=4.5d0
3851 cd    print '(a)','Enter ESCP'
3852 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3853       do i=iatscp_s,iatscp_e
3854         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3855         iteli=itel(i)
3856         xi=0.5D0*(c(1,i)+c(1,i+1))
3857         yi=0.5D0*(c(2,i)+c(2,i+1))
3858         zi=0.5D0*(c(3,i)+c(3,i+1))
3859
3860         do iint=1,nscp_gr(i)
3861
3862         do j=iscpstart(i,iint),iscpend(i,iint)
3863           if (itype(j).eq.21) cycle
3864           itypj=itype(j)
3865 C Uncomment following three lines for SC-p interactions
3866 c         xj=c(1,nres+j)-xi
3867 c         yj=c(2,nres+j)-yi
3868 c         zj=c(3,nres+j)-zi
3869 C Uncomment following three lines for Ca-p interactions
3870           xj=c(1,j)-xi
3871           yj=c(2,j)-yi
3872           zj=c(3,j)-zi
3873           rij=xj*xj+yj*yj+zj*zj
3874           r0ij=r0_scp
3875           r0ijsq=r0ij*r0ij
3876           if (rij.lt.r0ijsq) then
3877             evdwij=0.25d0*(rij-r0ijsq)**2
3878             fac=rij-r0ijsq
3879           else
3880             evdwij=0.0d0
3881             fac=0.0d0
3882           endif
3883           evdw2=evdw2+evdwij
3884 C
3885 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3886 C
3887           ggg(1)=xj*fac
3888           ggg(2)=yj*fac
3889           ggg(3)=zj*fac
3890 cgrad          if (j.lt.i) then
3891 cd          write (iout,*) 'j<i'
3892 C Uncomment following three lines for SC-p interactions
3893 c           do k=1,3
3894 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3895 c           enddo
3896 cgrad          else
3897 cd          write (iout,*) 'j>i'
3898 cgrad            do k=1,3
3899 cgrad              ggg(k)=-ggg(k)
3900 C Uncomment following line for SC-p interactions
3901 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3902 cgrad            enddo
3903 cgrad          endif
3904 cgrad          do k=1,3
3905 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3906 cgrad          enddo
3907 cgrad          kstart=min0(i+1,j)
3908 cgrad          kend=max0(i-1,j-1)
3909 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3910 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3911 cgrad          do k=kstart,kend
3912 cgrad            do l=1,3
3913 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3914 cgrad            enddo
3915 cgrad          enddo
3916           do k=1,3
3917             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3918             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3919           enddo
3920         enddo
3921
3922         enddo ! iint
3923       enddo ! i
3924       return
3925       end
3926 C-----------------------------------------------------------------------------
3927       subroutine escp(evdw2,evdw2_14)
3928 C
3929 C This subroutine calculates the excluded-volume interaction energy between
3930 C peptide-group centers and side chains and its gradient in virtual-bond and
3931 C side-chain vectors.
3932 C
3933       implicit real*8 (a-h,o-z)
3934       include 'DIMENSIONS'
3935       include 'COMMON.GEO'
3936       include 'COMMON.VAR'
3937       include 'COMMON.LOCAL'
3938       include 'COMMON.CHAIN'
3939       include 'COMMON.DERIV'
3940       include 'COMMON.INTERACT'
3941       include 'COMMON.FFIELD'
3942       include 'COMMON.IOUNITS'
3943       include 'COMMON.CONTROL'
3944       dimension ggg(3)
3945       evdw2=0.0D0
3946       evdw2_14=0.0d0
3947 cd    print '(a)','Enter ESCP'
3948 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3949       do i=iatscp_s,iatscp_e
3950         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3951         iteli=itel(i)
3952         xi=0.5D0*(c(1,i)+c(1,i+1))
3953         yi=0.5D0*(c(2,i)+c(2,i+1))
3954         zi=0.5D0*(c(3,i)+c(3,i+1))
3955
3956         do iint=1,nscp_gr(i)
3957
3958         do j=iscpstart(i,iint),iscpend(i,iint)
3959           itypj=itype(j)
3960           if (itypj.eq.21) cycle
3961 C Uncomment following three lines for SC-p interactions
3962 c         xj=c(1,nres+j)-xi
3963 c         yj=c(2,nres+j)-yi
3964 c         zj=c(3,nres+j)-zi
3965 C Uncomment following three lines for Ca-p interactions
3966           xj=c(1,j)-xi
3967           yj=c(2,j)-yi
3968           zj=c(3,j)-zi
3969           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3970           fac=rrij**expon2
3971           e1=fac*fac*aad(itypj,iteli)
3972           e2=fac*bad(itypj,iteli)
3973           if (iabs(j-i) .le. 2) then
3974             e1=scal14*e1
3975             e2=scal14*e2
3976             evdw2_14=evdw2_14+e1+e2
3977           endif
3978           evdwij=e1+e2
3979           evdw2=evdw2+evdwij
3980           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3981      &        'evdw2',i,j,evdwij
3982 C
3983 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3984 C
3985           fac=-(evdwij+e1)*rrij
3986           ggg(1)=xj*fac
3987           ggg(2)=yj*fac
3988           ggg(3)=zj*fac
3989 cgrad          if (j.lt.i) then
3990 cd          write (iout,*) 'j<i'
3991 C Uncomment following three lines for SC-p interactions
3992 c           do k=1,3
3993 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3994 c           enddo
3995 cgrad          else
3996 cd          write (iout,*) 'j>i'
3997 cgrad            do k=1,3
3998 cgrad              ggg(k)=-ggg(k)
3999 C Uncomment following line for SC-p interactions
4000 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4001 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4002 cgrad            enddo
4003 cgrad          endif
4004 cgrad          do k=1,3
4005 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4006 cgrad          enddo
4007 cgrad          kstart=min0(i+1,j)
4008 cgrad          kend=max0(i-1,j-1)
4009 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4010 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4011 cgrad          do k=kstart,kend
4012 cgrad            do l=1,3
4013 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4014 cgrad            enddo
4015 cgrad          enddo
4016           do k=1,3
4017             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4018             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4019           enddo
4020         enddo
4021
4022         enddo ! iint
4023       enddo ! i
4024       do i=1,nct
4025         do j=1,3
4026           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4027           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4028           gradx_scp(j,i)=expon*gradx_scp(j,i)
4029         enddo
4030       enddo
4031 C******************************************************************************
4032 C
4033 C                              N O T E !!!
4034 C
4035 C To save time the factor EXPON has been extracted from ALL components
4036 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4037 C use!
4038 C
4039 C******************************************************************************
4040       return
4041       end
4042 C--------------------------------------------------------------------------
4043       subroutine edis(ehpb)
4044 C
4045 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4046 C
4047       implicit real*8 (a-h,o-z)
4048       include 'DIMENSIONS'
4049       include 'COMMON.SBRIDGE'
4050       include 'COMMON.CHAIN'
4051       include 'COMMON.DERIV'
4052       include 'COMMON.VAR'
4053       include 'COMMON.INTERACT'
4054       include 'COMMON.IOUNITS'
4055       dimension ggg(3)
4056       ehpb=0.0D0
4057 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4058 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4059       if (link_end.eq.0) return
4060       do i=link_start,link_end
4061 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4062 C CA-CA distance used in regularization of structure.
4063         ii=ihpb(i)
4064         jj=jhpb(i)
4065 C iii and jjj point to the residues for which the distance is assigned.
4066         if (ii.gt.nres) then
4067           iii=ii-nres
4068           jjj=jj-nres
4069         else
4070           iii=ii
4071           jjj=jj
4072         endif
4073 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4074 c     &    dhpb(i),dhpb1(i),forcon(i)
4075 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4076 C    distance and angle dependent SS bond potential.
4077 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4078 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4079         if (.not.dyn_ss .and. i.le.nss) then
4080 C 15/02/13 CC dynamic SSbond - additional check
4081          if (ii.gt.nres
4082      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4083           call ssbond_ene(iii,jjj,eij)
4084           ehpb=ehpb+2*eij
4085          endif
4086 cd          write (iout,*) "eij",eij
4087         else
4088 C Calculate the distance between the two points and its difference from the
4089 C target distance.
4090           dd=dist(ii,jj)
4091             rdis=dd-dhpb(i)
4092 C Get the force constant corresponding to this distance.
4093             waga=forcon(i)
4094 C Calculate the contribution to energy.
4095             ehpb=ehpb+waga*rdis*rdis
4096 C
4097 C Evaluate gradient.
4098 C
4099             fac=waga*rdis/dd
4100 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4101 cd   &   ' waga=',waga,' fac=',fac
4102             do j=1,3
4103               ggg(j)=fac*(c(j,jj)-c(j,ii))
4104             enddo
4105 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4106 C If this is a SC-SC distance, we need to calculate the contributions to the
4107 C Cartesian gradient in the SC vectors (ghpbx).
4108           if (iii.lt.ii) then
4109           do j=1,3
4110             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4111             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4112           enddo
4113           endif
4114 cgrad        do j=iii,jjj-1
4115 cgrad          do k=1,3
4116 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4117 cgrad          enddo
4118 cgrad        enddo
4119           do k=1,3
4120             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4121             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4122           enddo
4123         endif
4124       enddo
4125       ehpb=0.5D0*ehpb
4126       return
4127       end
4128 C--------------------------------------------------------------------------
4129       subroutine ssbond_ene(i,j,eij)
4130 C
4131 C Calculate the distance and angle dependent SS-bond potential energy
4132 C using a free-energy function derived based on RHF/6-31G** ab initio
4133 C calculations of diethyl disulfide.
4134 C
4135 C A. Liwo and U. Kozlowska, 11/24/03
4136 C
4137       implicit real*8 (a-h,o-z)
4138       include 'DIMENSIONS'
4139       include 'COMMON.SBRIDGE'
4140       include 'COMMON.CHAIN'
4141       include 'COMMON.DERIV'
4142       include 'COMMON.LOCAL'
4143       include 'COMMON.INTERACT'
4144       include 'COMMON.VAR'
4145       include 'COMMON.IOUNITS'
4146       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4147       itypi=itype(i)
4148       xi=c(1,nres+i)
4149       yi=c(2,nres+i)
4150       zi=c(3,nres+i)
4151       dxi=dc_norm(1,nres+i)
4152       dyi=dc_norm(2,nres+i)
4153       dzi=dc_norm(3,nres+i)
4154 c      dsci_inv=dsc_inv(itypi)
4155       dsci_inv=vbld_inv(nres+i)
4156       itypj=itype(j)
4157 c      dscj_inv=dsc_inv(itypj)
4158       dscj_inv=vbld_inv(nres+j)
4159       xj=c(1,nres+j)-xi
4160       yj=c(2,nres+j)-yi
4161       zj=c(3,nres+j)-zi
4162       dxj=dc_norm(1,nres+j)
4163       dyj=dc_norm(2,nres+j)
4164       dzj=dc_norm(3,nres+j)
4165       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166       rij=dsqrt(rrij)
4167       erij(1)=xj*rij
4168       erij(2)=yj*rij
4169       erij(3)=zj*rij
4170       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4171       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4172       om12=dxi*dxj+dyi*dyj+dzi*dzj
4173       do k=1,3
4174         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4175         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4176       enddo
4177       rij=1.0d0/rij
4178       deltad=rij-d0cm
4179       deltat1=1.0d0-om1
4180       deltat2=1.0d0+om2
4181       deltat12=om2-om1+2.0d0
4182       cosphi=om12-om1*om2
4183       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4184      &  +akct*deltad*deltat12
4185      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4186 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4187 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4188 c     &  " deltat12",deltat12," eij",eij
4189       ed=2*akcm*deltad+akct*deltat12
4190       pom1=akct*deltad
4191       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4192       eom1=-2*akth*deltat1-pom1-om2*pom2
4193       eom2= 2*akth*deltat2+pom1-om1*pom2
4194       eom12=pom2
4195       do k=1,3
4196         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4197         ghpbx(k,i)=ghpbx(k,i)-ggk
4198      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4199      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4200         ghpbx(k,j)=ghpbx(k,j)+ggk
4201      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4202      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4203         ghpbc(k,i)=ghpbc(k,i)-ggk
4204         ghpbc(k,j)=ghpbc(k,j)+ggk
4205       enddo
4206 C
4207 C Calculate the components of the gradient in DC and X
4208 C
4209 cgrad      do k=i,j-1
4210 cgrad        do l=1,3
4211 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4212 cgrad        enddo
4213 cgrad      enddo
4214       return
4215       end
4216 C--------------------------------------------------------------------------
4217       subroutine ebond(estr)
4218 c
4219 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4220 c
4221       implicit real*8 (a-h,o-z)
4222       include 'DIMENSIONS'
4223       include 'COMMON.LOCAL'
4224       include 'COMMON.GEO'
4225       include 'COMMON.INTERACT'
4226       include 'COMMON.DERIV'
4227       include 'COMMON.VAR'
4228       include 'COMMON.CHAIN'
4229       include 'COMMON.IOUNITS'
4230       include 'COMMON.NAMES'
4231       include 'COMMON.FFIELD'
4232       include 'COMMON.CONTROL'
4233       include 'COMMON.SETUP'
4234       double precision u(3),ud(3)
4235       estr=0.0d0
4236       estr1=0.0d0
4237       do i=ibondp_start,ibondp_end
4238         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4239           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4240           do j=1,3
4241           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4242      &      *dc(j,i-1)/vbld(i)
4243           enddo
4244           if (energy_dec) write(iout,*)
4245      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4246         else
4247         diff = vbld(i)-vbldp0
4248         if (energy_dec) write (iout,*)
4249      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4250         estr=estr+diff*diff
4251         do j=1,3
4252           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4253         enddo
4254 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4255         endif
4256       enddo
4257       estr=0.5d0*AKP*estr+estr1
4258 c
4259 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4260 c
4261       do i=ibond_start,ibond_end
4262         iti=itype(i)
4263         if (iti.ne.10 .and. iti.ne.21) then
4264           nbi=nbondterm(iti)
4265           if (nbi.eq.1) then
4266             diff=vbld(i+nres)-vbldsc0(1,iti)
4267             if (energy_dec) write (iout,*)
4268      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4269      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4270             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4271             do j=1,3
4272               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4273             enddo
4274           else
4275             do j=1,nbi
4276               diff=vbld(i+nres)-vbldsc0(j,iti)
4277               ud(j)=aksc(j,iti)*diff
4278               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4279             enddo
4280             uprod=u(1)
4281             do j=2,nbi
4282               uprod=uprod*u(j)
4283             enddo
4284             usum=0.0d0
4285             usumsqder=0.0d0
4286             do j=1,nbi
4287               uprod1=1.0d0
4288               uprod2=1.0d0
4289               do k=1,nbi
4290                 if (k.ne.j) then
4291                   uprod1=uprod1*u(k)
4292                   uprod2=uprod2*u(k)*u(k)
4293                 endif
4294               enddo
4295               usum=usum+uprod1
4296               usumsqder=usumsqder+ud(j)*uprod2
4297             enddo
4298             estr=estr+uprod/usum
4299             do j=1,3
4300              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4301             enddo
4302           endif
4303         endif
4304       enddo
4305       return
4306       end
4307 #ifdef CRYST_THETA
4308 C--------------------------------------------------------------------------
4309       subroutine ebend(etheta)
4310 C
4311 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4312 C angles gamma and its derivatives in consecutive thetas and gammas.
4313 C
4314       implicit real*8 (a-h,o-z)
4315       include 'DIMENSIONS'
4316       include 'COMMON.LOCAL'
4317       include 'COMMON.GEO'
4318       include 'COMMON.INTERACT'
4319       include 'COMMON.DERIV'
4320       include 'COMMON.VAR'
4321       include 'COMMON.CHAIN'
4322       include 'COMMON.IOUNITS'
4323       include 'COMMON.NAMES'
4324       include 'COMMON.FFIELD'
4325       include 'COMMON.CONTROL'
4326       common /calcthet/ term1,term2,termm,diffak,ratak,
4327      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4328      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4329       double precision y(2),z(2)
4330       delta=0.02d0*pi
4331 c      time11=dexp(-2*time)
4332 c      time12=1.0d0
4333       etheta=0.0D0
4334 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4335       do i=ithet_start,ithet_end
4336         if (itype(i-1).eq.21) cycle
4337 C Zero the energy function and its derivative at 0 or pi.
4338         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4339         it=itype(i-1)
4340         if (i.gt.3 .and. itype(i-2).ne.21) then
4341 #ifdef OSF
4342           phii=phi(i)
4343           if (phii.ne.phii) phii=150.0
4344 #else
4345           phii=phi(i)
4346 #endif
4347           y(1)=dcos(phii)
4348           y(2)=dsin(phii)
4349         else
4350           y(1)=0.0D0
4351           y(2)=0.0D0
4352         endif
4353         if (i.lt.nres .and. itype(i).ne.21) then
4354 #ifdef OSF
4355           phii1=phi(i+1)
4356           if (phii1.ne.phii1) phii1=150.0
4357           phii1=pinorm(phii1)
4358           z(1)=cos(phii1)
4359 #else
4360           phii1=phi(i+1)
4361           z(1)=dcos(phii1)
4362 #endif
4363           z(2)=dsin(phii1)
4364         else
4365           z(1)=0.0D0
4366           z(2)=0.0D0
4367         endif
4368 C Calculate the "mean" value of theta from the part of the distribution
4369 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4370 C In following comments this theta will be referred to as t_c.
4371         thet_pred_mean=0.0d0
4372         do k=1,2
4373           athetk=athet(k,it)
4374           bthetk=bthet(k,it)
4375           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4376         enddo
4377         dthett=thet_pred_mean*ssd
4378         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4379 C Derivatives of the "mean" values in gamma1 and gamma2.
4380         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4381         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4382         if (theta(i).gt.pi-delta) then
4383           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4384      &         E_tc0)
4385           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4386           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4387           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4388      &        E_theta)
4389           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4390      &        E_tc)
4391         else if (theta(i).lt.delta) then
4392           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4393           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4394           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4395      &        E_theta)
4396           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4397           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4398      &        E_tc)
4399         else
4400           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4401      &        E_theta,E_tc)
4402         endif
4403         etheta=etheta+ethetai
4404         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4405      &      'ebend',i,ethetai
4406         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4407         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4408         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4409       enddo
4410 C Ufff.... We've done all this!!!
4411       return
4412       end
4413 C---------------------------------------------------------------------------
4414       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4415      &     E_tc)
4416       implicit real*8 (a-h,o-z)
4417       include 'DIMENSIONS'
4418       include 'COMMON.LOCAL'
4419       include 'COMMON.IOUNITS'
4420       common /calcthet/ term1,term2,termm,diffak,ratak,
4421      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4422      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4423 C Calculate the contributions to both Gaussian lobes.
4424 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4425 C The "polynomial part" of the "standard deviation" of this part of
4426 C the distribution.
4427         sig=polthet(3,it)
4428         do j=2,0,-1
4429           sig=sig*thet_pred_mean+polthet(j,it)
4430         enddo
4431 C Derivative of the "interior part" of the "standard deviation of the"
4432 C gamma-dependent Gaussian lobe in t_c.
4433         sigtc=3*polthet(3,it)
4434         do j=2,1,-1
4435           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4436         enddo
4437         sigtc=sig*sigtc
4438 C Set the parameters of both Gaussian lobes of the distribution.
4439 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4440         fac=sig*sig+sigc0(it)
4441         sigcsq=fac+fac
4442         sigc=1.0D0/sigcsq
4443 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4444         sigsqtc=-4.0D0*sigcsq*sigtc
4445 c       print *,i,sig,sigtc,sigsqtc
4446 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4447         sigtc=-sigtc/(fac*fac)
4448 C Following variable is sigma(t_c)**(-2)
4449         sigcsq=sigcsq*sigcsq
4450         sig0i=sig0(it)
4451         sig0inv=1.0D0/sig0i**2
4452         delthec=thetai-thet_pred_mean
4453         delthe0=thetai-theta0i
4454         term1=-0.5D0*sigcsq*delthec*delthec
4455         term2=-0.5D0*sig0inv*delthe0*delthe0
4456 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4457 C NaNs in taking the logarithm. We extract the largest exponent which is added
4458 C to the energy (this being the log of the distribution) at the end of energy
4459 C term evaluation for this virtual-bond angle.
4460         if (term1.gt.term2) then
4461           termm=term1
4462           term2=dexp(term2-termm)
4463           term1=1.0d0
4464         else
4465           termm=term2
4466           term1=dexp(term1-termm)
4467           term2=1.0d0
4468         endif
4469 C The ratio between the gamma-independent and gamma-dependent lobes of
4470 C the distribution is a Gaussian function of thet_pred_mean too.
4471         diffak=gthet(2,it)-thet_pred_mean
4472         ratak=diffak/gthet(3,it)**2
4473         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4474 C Let's differentiate it in thet_pred_mean NOW.
4475         aktc=ak*ratak
4476 C Now put together the distribution terms to make complete distribution.
4477         termexp=term1+ak*term2
4478         termpre=sigc+ak*sig0i
4479 C Contribution of the bending energy from this theta is just the -log of
4480 C the sum of the contributions from the two lobes and the pre-exponential
4481 C factor. Simple enough, isn't it?
4482         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4483 C NOW the derivatives!!!
4484 C 6/6/97 Take into account the deformation.
4485         E_theta=(delthec*sigcsq*term1
4486      &       +ak*delthe0*sig0inv*term2)/termexp
4487         E_tc=((sigtc+aktc*sig0i)/termpre
4488      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4489      &       aktc*term2)/termexp)
4490       return
4491       end
4492 c-----------------------------------------------------------------------------
4493       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4494       implicit real*8 (a-h,o-z)
4495       include 'DIMENSIONS'
4496       include 'COMMON.LOCAL'
4497       include 'COMMON.IOUNITS'
4498       common /calcthet/ term1,term2,termm,diffak,ratak,
4499      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4500      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4501       delthec=thetai-thet_pred_mean
4502       delthe0=thetai-theta0i
4503 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4504       t3 = thetai-thet_pred_mean
4505       t6 = t3**2
4506       t9 = term1
4507       t12 = t3*sigcsq
4508       t14 = t12+t6*sigsqtc
4509       t16 = 1.0d0
4510       t21 = thetai-theta0i
4511       t23 = t21**2
4512       t26 = term2
4513       t27 = t21*t26
4514       t32 = termexp
4515       t40 = t32**2
4516       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4517      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4518      & *(-t12*t9-ak*sig0inv*t27)
4519       return
4520       end
4521 #else
4522 C--------------------------------------------------------------------------
4523       subroutine ebend(etheta)
4524 C
4525 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4526 C angles gamma and its derivatives in consecutive thetas and gammas.
4527 C ab initio-derived potentials from
4528 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4529 C
4530       implicit real*8 (a-h,o-z)
4531       include 'DIMENSIONS'
4532       include 'COMMON.LOCAL'
4533       include 'COMMON.GEO'
4534       include 'COMMON.INTERACT'
4535       include 'COMMON.DERIV'
4536       include 'COMMON.VAR'
4537       include 'COMMON.CHAIN'
4538       include 'COMMON.IOUNITS'
4539       include 'COMMON.NAMES'
4540       include 'COMMON.FFIELD'
4541       include 'COMMON.CONTROL'
4542       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4543      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4544      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4545      & sinph1ph2(maxdouble,maxdouble)
4546       logical lprn /.false./, lprn1 /.false./
4547       etheta=0.0D0
4548       do i=ithet_start,ithet_end
4549         if (itype(i-1).eq.21) cycle
4550         dethetai=0.0d0
4551         dephii=0.0d0
4552         dephii1=0.0d0
4553         theti2=0.5d0*theta(i)
4554         ityp2=ithetyp(itype(i-1))
4555         do k=1,nntheterm
4556           coskt(k)=dcos(k*theti2)
4557           sinkt(k)=dsin(k*theti2)
4558         enddo
4559         if (i.gt.3 .and. itype(i-2).ne.21) then
4560 #ifdef OSF
4561           phii=phi(i)
4562           if (phii.ne.phii) phii=150.0
4563 #else
4564           phii=phi(i)
4565 #endif
4566           ityp1=ithetyp(itype(i-2))
4567           do k=1,nsingle
4568             cosph1(k)=dcos(k*phii)
4569             sinph1(k)=dsin(k*phii)
4570           enddo
4571         else
4572           phii=0.0d0
4573           ityp1=nthetyp+1
4574           do k=1,nsingle
4575             cosph1(k)=0.0d0
4576             sinph1(k)=0.0d0
4577           enddo
4578         endif
4579         if (i.lt.nres .and. itype(i).ne.21) then
4580 #ifdef OSF
4581           phii1=phi(i+1)
4582           if (phii1.ne.phii1) phii1=150.0
4583           phii1=pinorm(phii1)
4584 #else
4585           phii1=phi(i+1)
4586 #endif
4587           ityp3=ithetyp(itype(i))
4588           do k=1,nsingle
4589             cosph2(k)=dcos(k*phii1)
4590             sinph2(k)=dsin(k*phii1)
4591           enddo
4592         else
4593           phii1=0.0d0
4594           ityp3=nthetyp+1
4595           do k=1,nsingle
4596             cosph2(k)=0.0d0
4597             sinph2(k)=0.0d0
4598           enddo
4599         endif
4600         ethetai=aa0thet(ityp1,ityp2,ityp3)
4601         do k=1,ndouble
4602           do l=1,k-1
4603             ccl=cosph1(l)*cosph2(k-l)
4604             ssl=sinph1(l)*sinph2(k-l)
4605             scl=sinph1(l)*cosph2(k-l)
4606             csl=cosph1(l)*sinph2(k-l)
4607             cosph1ph2(l,k)=ccl-ssl
4608             cosph1ph2(k,l)=ccl+ssl
4609             sinph1ph2(l,k)=scl+csl
4610             sinph1ph2(k,l)=scl-csl
4611           enddo
4612         enddo
4613         if (lprn) then
4614         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4615      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4616         write (iout,*) "coskt and sinkt"
4617         do k=1,nntheterm
4618           write (iout,*) k,coskt(k),sinkt(k)
4619         enddo
4620         endif
4621         do k=1,ntheterm
4622           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4623           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4624      &      *coskt(k)
4625           if (lprn)
4626      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4627      &     " ethetai",ethetai
4628         enddo
4629         if (lprn) then
4630         write (iout,*) "cosph and sinph"
4631         do k=1,nsingle
4632           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4633         enddo
4634         write (iout,*) "cosph1ph2 and sinph2ph2"
4635         do k=2,ndouble
4636           do l=1,k-1
4637             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4638      &         sinph1ph2(l,k),sinph1ph2(k,l)
4639           enddo
4640         enddo
4641         write(iout,*) "ethetai",ethetai
4642         endif
4643         do m=1,ntheterm2
4644           do k=1,nsingle
4645             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4646      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4647      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4648      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4649             ethetai=ethetai+sinkt(m)*aux
4650             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4651             dephii=dephii+k*sinkt(m)*(
4652      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4653      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4654             dephii1=dephii1+k*sinkt(m)*(
4655      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4656      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4657             if (lprn)
4658      &      write (iout,*) "m",m," k",k," bbthet",
4659      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4660      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4661      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4662      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4663           enddo
4664         enddo
4665         if (lprn)
4666      &  write(iout,*) "ethetai",ethetai
4667         do m=1,ntheterm3
4668           do k=2,ndouble
4669             do l=1,k-1
4670               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4671      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4672      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4673      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4674               ethetai=ethetai+sinkt(m)*aux
4675               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4676               dephii=dephii+l*sinkt(m)*(
4677      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4678      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4679      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4680      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4681               dephii1=dephii1+(k-l)*sinkt(m)*(
4682      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4683      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4684      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4685      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4686               if (lprn) then
4687               write (iout,*) "m",m," k",k," l",l," ffthet",
4688      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4689      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4690      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4691      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4692               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4693      &            cosph1ph2(k,l)*sinkt(m),
4694      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4695               endif
4696             enddo
4697           enddo
4698         enddo
4699 10      continue
4700         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4701      &   i,theta(i)*rad2deg,phii*rad2deg,
4702      &   phii1*rad2deg,ethetai
4703         etheta=etheta+ethetai
4704         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4705         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4706         gloc(nphi+i-2,icg)=wang*dethetai
4707       enddo
4708       return
4709       end
4710 #endif
4711 #ifdef CRYST_SC
4712 c-----------------------------------------------------------------------------
4713       subroutine esc(escloc)
4714 C Calculate the local energy of a side chain and its derivatives in the
4715 C corresponding virtual-bond valence angles THETA and the spherical angles
4716 C ALPHA and OMEGA.
4717       implicit real*8 (a-h,o-z)
4718       include 'DIMENSIONS'
4719       include 'COMMON.GEO'
4720       include 'COMMON.LOCAL'
4721       include 'COMMON.VAR'
4722       include 'COMMON.INTERACT'
4723       include 'COMMON.DERIV'
4724       include 'COMMON.CHAIN'
4725       include 'COMMON.IOUNITS'
4726       include 'COMMON.NAMES'
4727       include 'COMMON.FFIELD'
4728       include 'COMMON.CONTROL'
4729       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4730      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4731       common /sccalc/ time11,time12,time112,theti,it,nlobit
4732       delta=0.02d0*pi
4733       escloc=0.0D0
4734 c     write (iout,'(a)') 'ESC'
4735       do i=loc_start,loc_end
4736         it=itype(i)
4737         if (it.eq.21) cycle
4738         if (it.eq.10) goto 1
4739         nlobit=nlob(it)
4740 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4741 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4742         theti=theta(i+1)-pipol
4743         x(1)=dtan(theti)
4744         x(2)=alph(i)
4745         x(3)=omeg(i)
4746
4747         if (x(2).gt.pi-delta) then
4748           xtemp(1)=x(1)
4749           xtemp(2)=pi-delta
4750           xtemp(3)=x(3)
4751           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4752           xtemp(2)=pi
4753           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4754           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4755      &        escloci,dersc(2))
4756           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4757      &        ddersc0(1),dersc(1))
4758           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4759      &        ddersc0(3),dersc(3))
4760           xtemp(2)=pi-delta
4761           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4762           xtemp(2)=pi
4763           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4764           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4765      &            dersc0(2),esclocbi,dersc02)
4766           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4767      &            dersc12,dersc01)
4768           call splinthet(x(2),0.5d0*delta,ss,ssd)
4769           dersc0(1)=dersc01
4770           dersc0(2)=dersc02
4771           dersc0(3)=0.0d0
4772           do k=1,3
4773             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4774           enddo
4775           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4776 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4777 c    &             esclocbi,ss,ssd
4778           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4779 c         escloci=esclocbi
4780 c         write (iout,*) escloci
4781         else if (x(2).lt.delta) then
4782           xtemp(1)=x(1)
4783           xtemp(2)=delta
4784           xtemp(3)=x(3)
4785           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4786           xtemp(2)=0.0d0
4787           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4788           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4789      &        escloci,dersc(2))
4790           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4791      &        ddersc0(1),dersc(1))
4792           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4793      &        ddersc0(3),dersc(3))
4794           xtemp(2)=delta
4795           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4796           xtemp(2)=0.0d0
4797           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4798           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4799      &            dersc0(2),esclocbi,dersc02)
4800           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4801      &            dersc12,dersc01)
4802           dersc0(1)=dersc01
4803           dersc0(2)=dersc02
4804           dersc0(3)=0.0d0
4805           call splinthet(x(2),0.5d0*delta,ss,ssd)
4806           do k=1,3
4807             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4808           enddo
4809           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4810 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4811 c    &             esclocbi,ss,ssd
4812           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4813 c         write (iout,*) escloci
4814         else
4815           call enesc(x,escloci,dersc,ddummy,.false.)
4816         endif
4817
4818         escloc=escloc+escloci
4819         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4820      &     'escloc',i,escloci
4821 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4822
4823         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4824      &   wscloc*dersc(1)
4825         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4826         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4827     1   continue
4828       enddo
4829       return
4830       end
4831 C---------------------------------------------------------------------------
4832       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4833       implicit real*8 (a-h,o-z)
4834       include 'DIMENSIONS'
4835       include 'COMMON.GEO'
4836       include 'COMMON.LOCAL'
4837       include 'COMMON.IOUNITS'
4838       common /sccalc/ time11,time12,time112,theti,it,nlobit
4839       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4840       double precision contr(maxlob,-1:1)
4841       logical mixed
4842 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4843         escloc_i=0.0D0
4844         do j=1,3
4845           dersc(j)=0.0D0
4846           if (mixed) ddersc(j)=0.0d0
4847         enddo
4848         x3=x(3)
4849
4850 C Because of periodicity of the dependence of the SC energy in omega we have
4851 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4852 C To avoid underflows, first compute & store the exponents.
4853
4854         do iii=-1,1
4855
4856           x(3)=x3+iii*dwapi
4857
4858           do j=1,nlobit
4859             do k=1,3
4860               z(k)=x(k)-censc(k,j,it)
4861             enddo
4862             do k=1,3
4863               Axk=0.0D0
4864               do l=1,3
4865                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4866               enddo
4867               Ax(k,j,iii)=Axk
4868             enddo
4869             expfac=0.0D0
4870             do k=1,3
4871               expfac=expfac+Ax(k,j,iii)*z(k)
4872             enddo
4873             contr(j,iii)=expfac
4874           enddo ! j
4875
4876         enddo ! iii
4877
4878         x(3)=x3
4879 C As in the case of ebend, we want to avoid underflows in exponentiation and
4880 C subsequent NaNs and INFs in energy calculation.
4881 C Find the largest exponent
4882         emin=contr(1,-1)
4883         do iii=-1,1
4884           do j=1,nlobit
4885             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4886           enddo
4887         enddo
4888         emin=0.5D0*emin
4889 cd      print *,'it=',it,' emin=',emin
4890
4891 C Compute the contribution to SC energy and derivatives
4892         do iii=-1,1
4893
4894           do j=1,nlobit
4895 #ifdef OSF
4896             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4897             if(adexp.ne.adexp) adexp=1.0
4898             expfac=dexp(adexp)
4899 #else
4900             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4901 #endif
4902 cd          print *,'j=',j,' expfac=',expfac
4903             escloc_i=escloc_i+expfac
4904             do k=1,3
4905               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4906             enddo
4907             if (mixed) then
4908               do k=1,3,2
4909                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4910      &            +gaussc(k,2,j,it))*expfac
4911               enddo
4912             endif
4913           enddo
4914
4915         enddo ! iii
4916
4917         dersc(1)=dersc(1)/cos(theti)**2
4918         ddersc(1)=ddersc(1)/cos(theti)**2
4919         ddersc(3)=ddersc(3)
4920
4921         escloci=-(dlog(escloc_i)-emin)
4922         do j=1,3
4923           dersc(j)=dersc(j)/escloc_i
4924         enddo
4925         if (mixed) then
4926           do j=1,3,2
4927             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4928           enddo
4929         endif
4930       return
4931       end
4932 C------------------------------------------------------------------------------
4933       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4934       implicit real*8 (a-h,o-z)
4935       include 'DIMENSIONS'
4936       include 'COMMON.GEO'
4937       include 'COMMON.LOCAL'
4938       include 'COMMON.IOUNITS'
4939       common /sccalc/ time11,time12,time112,theti,it,nlobit
4940       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4941       double precision contr(maxlob)
4942       logical mixed
4943
4944       escloc_i=0.0D0
4945
4946       do j=1,3
4947         dersc(j)=0.0D0
4948       enddo
4949
4950       do j=1,nlobit
4951         do k=1,2
4952           z(k)=x(k)-censc(k,j,it)
4953         enddo
4954         z(3)=dwapi
4955         do k=1,3
4956           Axk=0.0D0
4957           do l=1,3
4958             Axk=Axk+gaussc(l,k,j,it)*z(l)
4959           enddo
4960           Ax(k,j)=Axk
4961         enddo
4962         expfac=0.0D0
4963         do k=1,3
4964           expfac=expfac+Ax(k,j)*z(k)
4965         enddo
4966         contr(j)=expfac
4967       enddo ! j
4968
4969 C As in the case of ebend, we want to avoid underflows in exponentiation and
4970 C subsequent NaNs and INFs in energy calculation.
4971 C Find the largest exponent
4972       emin=contr(1)
4973       do j=1,nlobit
4974         if (emin.gt.contr(j)) emin=contr(j)
4975       enddo
4976       emin=0.5D0*emin
4977
4978 C Compute the contribution to SC energy and derivatives
4979
4980       dersc12=0.0d0
4981       do j=1,nlobit
4982         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4983         escloc_i=escloc_i+expfac
4984         do k=1,2
4985           dersc(k)=dersc(k)+Ax(k,j)*expfac
4986         enddo
4987         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4988      &            +gaussc(1,2,j,it))*expfac
4989         dersc(3)=0.0d0
4990       enddo
4991
4992       dersc(1)=dersc(1)/cos(theti)**2
4993       dersc12=dersc12/cos(theti)**2
4994       escloci=-(dlog(escloc_i)-emin)
4995       do j=1,2
4996         dersc(j)=dersc(j)/escloc_i
4997       enddo
4998       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4999       return
5000       end
5001 #else
5002 c----------------------------------------------------------------------------------
5003       subroutine esc(escloc)
5004 C Calculate the local energy of a side chain and its derivatives in the
5005 C corresponding virtual-bond valence angles THETA and the spherical angles
5006 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5007 C added by Urszula Kozlowska. 07/11/2007
5008 C
5009       implicit real*8 (a-h,o-z)
5010       include 'DIMENSIONS'
5011       include 'COMMON.GEO'
5012       include 'COMMON.LOCAL'
5013       include 'COMMON.VAR'
5014       include 'COMMON.SCROT'
5015       include 'COMMON.INTERACT'
5016       include 'COMMON.DERIV'
5017       include 'COMMON.CHAIN'
5018       include 'COMMON.IOUNITS'
5019       include 'COMMON.NAMES'
5020       include 'COMMON.FFIELD'
5021       include 'COMMON.CONTROL'
5022       include 'COMMON.VECTORS'
5023       double precision x_prime(3),y_prime(3),z_prime(3)
5024      &    , sumene,dsc_i,dp2_i,x(65),
5025      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5026      &    de_dxx,de_dyy,de_dzz,de_dt
5027       double precision s1_t,s1_6_t,s2_t,s2_6_t
5028       double precision
5029      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5030      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5031      & dt_dCi(3),dt_dCi1(3)
5032       common /sccalc/ time11,time12,time112,theti,it,nlobit
5033       delta=0.02d0*pi
5034       escloc=0.0D0
5035       do i=loc_start,loc_end
5036         if (itype(i).eq.21) cycle
5037         costtab(i+1) =dcos(theta(i+1))
5038         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5039         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5040         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5041         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5042         cosfac=dsqrt(cosfac2)
5043         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5044         sinfac=dsqrt(sinfac2)
5045         it=itype(i)
5046         if (it.eq.10) goto 1
5047 c
5048 C  Compute the axes of tghe local cartesian coordinates system; store in
5049 c   x_prime, y_prime and z_prime
5050 c
5051         do j=1,3
5052           x_prime(j) = 0.00
5053           y_prime(j) = 0.00
5054           z_prime(j) = 0.00
5055         enddo
5056 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5057 C     &   dc_norm(3,i+nres)
5058         do j = 1,3
5059           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5060           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5061         enddo
5062         do j = 1,3
5063           z_prime(j) = -uz(j,i-1)
5064         enddo
5065 c       write (2,*) "i",i
5066 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5067 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5068 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5069 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5070 c      & " xy",scalar(x_prime(1),y_prime(1)),
5071 c      & " xz",scalar(x_prime(1),z_prime(1)),
5072 c      & " yy",scalar(y_prime(1),y_prime(1)),
5073 c      & " yz",scalar(y_prime(1),z_prime(1)),
5074 c      & " zz",scalar(z_prime(1),z_prime(1))
5075 c
5076 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5077 C to local coordinate system. Store in xx, yy, zz.
5078 c
5079         xx=0.0d0
5080         yy=0.0d0
5081         zz=0.0d0
5082         do j = 1,3
5083           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5084           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5085           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5086         enddo
5087
5088         xxtab(i)=xx
5089         yytab(i)=yy
5090         zztab(i)=zz
5091 C
5092 C Compute the energy of the ith side cbain
5093 C
5094 c        write (2,*) "xx",xx," yy",yy," zz",zz
5095         it=itype(i)
5096         do j = 1,65
5097           x(j) = sc_parmin(j,it)
5098         enddo
5099 #ifdef CHECK_COORD
5100 Cc diagnostics - remove later
5101         xx1 = dcos(alph(2))
5102         yy1 = dsin(alph(2))*dcos(omeg(2))
5103         zz1 = -dsin(alph(2))*dsin(omeg(2))
5104         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5105      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5106      &    xx1,yy1,zz1
5107 C,"  --- ", xx_w,yy_w,zz_w
5108 c end diagnostics
5109 #endif
5110         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5111      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5112      &   + x(10)*yy*zz
5113         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5114      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5115      & + x(20)*yy*zz
5116         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5117      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5118      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5119      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5120      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5121      &  +x(40)*xx*yy*zz
5122         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5123      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5124      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5125      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5126      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5127      &  +x(60)*xx*yy*zz
5128         dsc_i   = 0.743d0+x(61)
5129         dp2_i   = 1.9d0+x(62)
5130         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5131      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5132         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5133      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5134         s1=(1+x(63))/(0.1d0 + dscp1)
5135         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5136         s2=(1+x(65))/(0.1d0 + dscp2)
5137         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5138         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5139      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5140 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5141 c     &   sumene4,
5142 c     &   dscp1,dscp2,sumene
5143 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5144         escloc = escloc + sumene
5145 c        write (2,*) "i",i," escloc",sumene,escloc
5146 #ifdef DEBUG
5147 C
5148 C This section to check the numerical derivatives of the energy of ith side
5149 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5150 C #define DEBUG in the code to turn it on.
5151 C
5152         write (2,*) "sumene               =",sumene
5153         aincr=1.0d-7
5154         xxsave=xx
5155         xx=xx+aincr
5156         write (2,*) xx,yy,zz
5157         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5158         de_dxx_num=(sumenep-sumene)/aincr
5159         xx=xxsave
5160         write (2,*) "xx+ sumene from enesc=",sumenep
5161         yysave=yy
5162         yy=yy+aincr
5163         write (2,*) xx,yy,zz
5164         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5165         de_dyy_num=(sumenep-sumene)/aincr
5166         yy=yysave
5167         write (2,*) "yy+ sumene from enesc=",sumenep
5168         zzsave=zz
5169         zz=zz+aincr
5170         write (2,*) xx,yy,zz
5171         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5172         de_dzz_num=(sumenep-sumene)/aincr
5173         zz=zzsave
5174         write (2,*) "zz+ sumene from enesc=",sumenep
5175         costsave=cost2tab(i+1)
5176         sintsave=sint2tab(i+1)
5177         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5178         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5179         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5180         de_dt_num=(sumenep-sumene)/aincr
5181         write (2,*) " t+ sumene from enesc=",sumenep
5182         cost2tab(i+1)=costsave
5183         sint2tab(i+1)=sintsave
5184 C End of diagnostics section.
5185 #endif
5186 C
5187 C Compute the gradient of esc
5188 C
5189         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5190         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5191         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5192         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5193         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5194         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5195         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5196         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5197         pom1=(sumene3*sint2tab(i+1)+sumene1)
5198      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5199         pom2=(sumene4*cost2tab(i+1)+sumene2)
5200      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5201         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5202         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5203      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5204      &  +x(40)*yy*zz
5205         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5206         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5207      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5208      &  +x(60)*yy*zz
5209         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5210      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5211      &        +(pom1+pom2)*pom_dx
5212 #ifdef DEBUG
5213         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5214 #endif
5215 C
5216         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5217         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5218      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5219      &  +x(40)*xx*zz
5220         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5221         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5222      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5223      &  +x(59)*zz**2 +x(60)*xx*zz
5224         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5225      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5226      &        +(pom1-pom2)*pom_dy
5227 #ifdef DEBUG
5228         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5229 #endif
5230 C
5231         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5232      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5233      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5234      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5235      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5236      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5237      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5238      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5239 #ifdef DEBUG
5240         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5241 #endif
5242 C
5243         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5244      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5245      &  +pom1*pom_dt1+pom2*pom_dt2
5246 #ifdef DEBUG
5247         write(2,*), "de_dt = ", de_dt,de_dt_num
5248 #endif
5249 c
5250 C
5251        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5252        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5253        cosfac2xx=cosfac2*xx
5254        sinfac2yy=sinfac2*yy
5255        do k = 1,3
5256          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5257      &      vbld_inv(i+1)
5258          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5259      &      vbld_inv(i)
5260          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5261          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5262 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5263 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5264 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5265 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5266          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5267          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5268          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5269          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5270          dZZ_Ci1(k)=0.0d0
5271          dZZ_Ci(k)=0.0d0
5272          do j=1,3
5273            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5274            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5275          enddo
5276
5277          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5278          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5279          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5280 c
5281          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5282          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5283        enddo
5284
5285        do k=1,3
5286          dXX_Ctab(k,i)=dXX_Ci(k)
5287          dXX_C1tab(k,i)=dXX_Ci1(k)
5288          dYY_Ctab(k,i)=dYY_Ci(k)
5289          dYY_C1tab(k,i)=dYY_Ci1(k)
5290          dZZ_Ctab(k,i)=dZZ_Ci(k)
5291          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5292          dXX_XYZtab(k,i)=dXX_XYZ(k)
5293          dYY_XYZtab(k,i)=dYY_XYZ(k)
5294          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5295        enddo
5296
5297        do k = 1,3
5298 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5299 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5300 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5301 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5302 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5303 c     &    dt_dci(k)
5304 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5305 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5306          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5307      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5308          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5309      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5310          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5311      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5312        enddo
5313 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5314 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5315
5316 C to check gradient call subroutine check_grad
5317
5318     1 continue
5319       enddo
5320       return
5321       end
5322 c------------------------------------------------------------------------------
5323       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5324       implicit none
5325       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5326      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5327       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5328      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5329      &   + x(10)*yy*zz
5330       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5331      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5332      & + x(20)*yy*zz
5333       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5334      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5335      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5336      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5337      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5338      &  +x(40)*xx*yy*zz
5339       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5340      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5341      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5342      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5343      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5344      &  +x(60)*xx*yy*zz
5345       dsc_i   = 0.743d0+x(61)
5346       dp2_i   = 1.9d0+x(62)
5347       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5348      &          *(xx*cost2+yy*sint2))
5349       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5350      &          *(xx*cost2-yy*sint2))
5351       s1=(1+x(63))/(0.1d0 + dscp1)
5352       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5353       s2=(1+x(65))/(0.1d0 + dscp2)
5354       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5355       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5356      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5357       enesc=sumene
5358       return
5359       end
5360 #endif
5361 c------------------------------------------------------------------------------
5362       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5363 C
5364 C This procedure calculates two-body contact function g(rij) and its derivative:
5365 C
5366 C           eps0ij                                     !       x < -1
5367 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5368 C            0                                         !       x > 1
5369 C
5370 C where x=(rij-r0ij)/delta
5371 C
5372 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5373 C
5374       implicit none
5375       double precision rij,r0ij,eps0ij,fcont,fprimcont
5376       double precision x,x2,x4,delta
5377 c     delta=0.02D0*r0ij
5378 c      delta=0.2D0*r0ij
5379       x=(rij-r0ij)/delta
5380       if (x.lt.-1.0D0) then
5381         fcont=eps0ij
5382         fprimcont=0.0D0
5383       else if (x.le.1.0D0) then
5384         x2=x*x
5385         x4=x2*x2
5386         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5387         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5388       else
5389         fcont=0.0D0
5390         fprimcont=0.0D0
5391       endif
5392       return
5393       end
5394 c------------------------------------------------------------------------------
5395       subroutine splinthet(theti,delta,ss,ssder)
5396       implicit real*8 (a-h,o-z)
5397       include 'DIMENSIONS'
5398       include 'COMMON.VAR'
5399       include 'COMMON.GEO'
5400       thetup=pi-delta
5401       thetlow=delta
5402       if (theti.gt.pipol) then
5403         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5404       else
5405         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5406         ssder=-ssder
5407       endif
5408       return
5409       end
5410 c------------------------------------------------------------------------------
5411       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5412       implicit none
5413       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5414       double precision ksi,ksi2,ksi3,a1,a2,a3
5415       a1=fprim0*delta/(f1-f0)
5416       a2=3.0d0-2.0d0*a1
5417       a3=a1-2.0d0
5418       ksi=(x-x0)/delta
5419       ksi2=ksi*ksi
5420       ksi3=ksi2*ksi
5421       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5422       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5423       return
5424       end
5425 c------------------------------------------------------------------------------
5426       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5427       implicit none
5428       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5429       double precision ksi,ksi2,ksi3,a1,a2,a3
5430       ksi=(x-x0)/delta
5431       ksi2=ksi*ksi
5432       ksi3=ksi2*ksi
5433       a1=fprim0x*delta
5434       a2=3*(f1x-f0x)-2*fprim0x*delta
5435       a3=fprim0x*delta-2*(f1x-f0x)
5436       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5437       return
5438       end
5439 C-----------------------------------------------------------------------------
5440 #ifdef CRYST_TOR
5441 C-----------------------------------------------------------------------------
5442       subroutine etor(etors,edihcnstr)
5443       implicit real*8 (a-h,o-z)
5444       include 'DIMENSIONS'
5445       include 'COMMON.VAR'
5446       include 'COMMON.GEO'
5447       include 'COMMON.LOCAL'
5448       include 'COMMON.TORSION'
5449       include 'COMMON.INTERACT'
5450       include 'COMMON.DERIV'
5451       include 'COMMON.CHAIN'
5452       include 'COMMON.NAMES'
5453       include 'COMMON.IOUNITS'
5454       include 'COMMON.FFIELD'
5455       include 'COMMON.TORCNSTR'
5456       include 'COMMON.CONTROL'
5457       logical lprn
5458 C Set lprn=.true. for debugging
5459       lprn=.false.
5460 c      lprn=.true.
5461       etors=0.0D0
5462       do i=iphi_start,iphi_end
5463       etors_ii=0.0D0
5464         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5465      &      .or. itype(i).eq.21) cycle
5466         itori=itortyp(itype(i-2))
5467         itori1=itortyp(itype(i-1))
5468         phii=phi(i)
5469         gloci=0.0D0
5470 C Proline-Proline pair is a special case...
5471         if (itori.eq.3 .and. itori1.eq.3) then
5472           if (phii.gt.-dwapi3) then
5473             cosphi=dcos(3*phii)
5474             fac=1.0D0/(1.0D0-cosphi)
5475             etorsi=v1(1,3,3)*fac
5476             etorsi=etorsi+etorsi
5477             etors=etors+etorsi-v1(1,3,3)
5478             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5479             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5480           endif
5481           do j=1,3
5482             v1ij=v1(j+1,itori,itori1)
5483             v2ij=v2(j+1,itori,itori1)
5484             cosphi=dcos(j*phii)
5485             sinphi=dsin(j*phii)
5486             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5487             if (energy_dec) etors_ii=etors_ii+
5488      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5489             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5490           enddo
5491         else
5492           do j=1,nterm_old
5493             v1ij=v1(j,itori,itori1)
5494             v2ij=v2(j,itori,itori1)
5495             cosphi=dcos(j*phii)
5496             sinphi=dsin(j*phii)
5497             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5498             if (energy_dec) etors_ii=etors_ii+
5499      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5500             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5501           enddo
5502         endif
5503         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5504              'etor',i,etors_ii
5505         if (lprn)
5506      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5507      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5508      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5509         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5510 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5511       enddo
5512 ! 6/20/98 - dihedral angle constraints
5513       edihcnstr=0.0d0
5514       do i=1,ndih_constr
5515         itori=idih_constr(i)
5516         phii=phi(itori)
5517         difi=phii-phi0(i)
5518         if (difi.gt.drange(i)) then
5519           difi=difi-drange(i)
5520           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5521           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5522         else if (difi.lt.-drange(i)) then
5523           difi=difi+drange(i)
5524           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5525           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5526         endif
5527 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5528 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5529       enddo
5530 !      write (iout,*) 'edihcnstr',edihcnstr
5531       return
5532       end
5533 c------------------------------------------------------------------------------
5534       subroutine etor_d(etors_d)
5535       etors_d=0.0d0
5536       return
5537       end
5538 c----------------------------------------------------------------------------
5539 #else
5540       subroutine etor(etors,edihcnstr)
5541       implicit real*8 (a-h,o-z)
5542       include 'DIMENSIONS'
5543       include 'COMMON.VAR'
5544       include 'COMMON.GEO'
5545       include 'COMMON.LOCAL'
5546       include 'COMMON.TORSION'
5547       include 'COMMON.INTERACT'
5548       include 'COMMON.DERIV'
5549       include 'COMMON.CHAIN'
5550       include 'COMMON.NAMES'
5551       include 'COMMON.IOUNITS'
5552       include 'COMMON.FFIELD'
5553       include 'COMMON.TORCNSTR'
5554       include 'COMMON.CONTROL'
5555       logical lprn
5556 C Set lprn=.true. for debugging
5557       lprn=.false.
5558 c     lprn=.true.
5559       etors=0.0D0
5560       do i=iphi_start,iphi_end
5561         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5562      &       .or. itype(i).eq.21
5563      &       .or. itype(i-3).eq.ntyp1) cycle
5564       etors_ii=0.0D0
5565         itori=itortyp(itype(i-2))
5566         itori1=itortyp(itype(i-1))
5567         phii=phi(i)
5568         gloci=0.0D0
5569 C Regular cosine and sine terms
5570         do j=1,nterm(itori,itori1)
5571           v1ij=v1(j,itori,itori1)
5572           v2ij=v2(j,itori,itori1)
5573           cosphi=dcos(j*phii)
5574           sinphi=dsin(j*phii)
5575           etors=etors+v1ij*cosphi+v2ij*sinphi
5576           if (energy_dec) etors_ii=etors_ii+
5577      &                v1ij*cosphi+v2ij*sinphi
5578           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5579         enddo
5580 C Lorentz terms
5581 C                         v1
5582 C  E = SUM ----------------------------------- - v1
5583 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5584 C
5585         cosphi=dcos(0.5d0*phii)
5586         sinphi=dsin(0.5d0*phii)
5587         do j=1,nlor(itori,itori1)
5588           vl1ij=vlor1(j,itori,itori1)
5589           vl2ij=vlor2(j,itori,itori1)
5590           vl3ij=vlor3(j,itori,itori1)
5591           pom=vl2ij*cosphi+vl3ij*sinphi
5592           pom1=1.0d0/(pom*pom+1.0d0)
5593           etors=etors+vl1ij*pom1
5594           if (energy_dec) etors_ii=etors_ii+
5595      &                vl1ij*pom1
5596           pom=-pom*pom1*pom1
5597           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5598         enddo
5599 C Subtract the constant term
5600         etors=etors-v0(itori,itori1)
5601           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5602      &         'etor',i,etors_ii-v0(itori,itori1)
5603         if (lprn)
5604      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5605      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5606      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5607         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5608 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5609       enddo
5610 ! 6/20/98 - dihedral angle constraints
5611       edihcnstr=0.0d0
5612 c      do i=1,ndih_constr
5613       do i=idihconstr_start,idihconstr_end
5614         itori=idih_constr(i)
5615         phii=phi(itori)
5616         difi=pinorm(phii-phi0(i))
5617         if (difi.gt.drange(i)) then
5618           difi=difi-drange(i)
5619           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5620           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5621         else if (difi.lt.-drange(i)) then
5622           difi=difi+drange(i)
5623           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5624           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5625         else
5626           difi=0.0
5627         endif
5628 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5629 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5630 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5631       enddo
5632 cd       write (iout,*) 'edihcnstr',edihcnstr
5633       return
5634       end
5635 c----------------------------------------------------------------------------
5636       subroutine etor_d(etors_d)
5637 C 6/23/01 Compute double torsional energy
5638       implicit real*8 (a-h,o-z)
5639       include 'DIMENSIONS'
5640       include 'COMMON.VAR'
5641       include 'COMMON.GEO'
5642       include 'COMMON.LOCAL'
5643       include 'COMMON.TORSION'
5644       include 'COMMON.INTERACT'
5645       include 'COMMON.DERIV'
5646       include 'COMMON.CHAIN'
5647       include 'COMMON.NAMES'
5648       include 'COMMON.IOUNITS'
5649       include 'COMMON.FFIELD'
5650       include 'COMMON.TORCNSTR'
5651       logical lprn
5652 C Set lprn=.true. for debugging
5653       lprn=.false.
5654 c     lprn=.true.
5655       etors_d=0.0D0
5656 C      write(iout,*) "a tu??"
5657       do i=iphid_start,iphid_end
5658         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5659      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21
5660      &       .or. itype(i-3).eq.ntyp1) cycle
5661         itori=itortyp(itype(i-2))
5662         itori1=itortyp(itype(i-1))
5663         itori2=itortyp(itype(i))
5664         phii=phi(i)
5665         phii1=phi(i+1)
5666         gloci1=0.0D0
5667         gloci2=0.0D0
5668 C Regular cosine and sine terms
5669         do j=1,ntermd_1(itori,itori1,itori2)
5670           v1cij=v1c(1,j,itori,itori1,itori2)
5671           v1sij=v1s(1,j,itori,itori1,itori2)
5672           v2cij=v1c(2,j,itori,itori1,itori2)
5673           v2sij=v1s(2,j,itori,itori1,itori2)
5674           cosphi1=dcos(j*phii)
5675           sinphi1=dsin(j*phii)
5676           cosphi2=dcos(j*phii1)
5677           sinphi2=dsin(j*phii1)
5678           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5679      &     v2cij*cosphi2+v2sij*sinphi2
5680           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5681           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5682         enddo
5683         do k=2,ntermd_2(itori,itori1,itori2)
5684           do l=1,k-1
5685             v1cdij = v2c(k,l,itori,itori1,itori2)
5686             v2cdij = v2c(l,k,itori,itori1,itori2)
5687             v1sdij = v2s(k,l,itori,itori1,itori2)
5688             v2sdij = v2s(l,k,itori,itori1,itori2)
5689             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5690             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5691             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5692             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5693             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5694      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5695             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5696      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5697             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5698      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5699           enddo
5700         enddo
5701         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5702         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5703       enddo
5704       return
5705       end
5706 #endif
5707 c------------------------------------------------------------------------------
5708       subroutine eback_sc_corr(esccor)
5709 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5710 c        conformational states; temporarily implemented as differences
5711 c        between UNRES torsional potentials (dependent on three types of
5712 c        residues) and the torsional potentials dependent on all 20 types
5713 c        of residues computed from AM1  energy surfaces of terminally-blocked
5714 c        amino-acid residues.
5715       implicit real*8 (a-h,o-z)
5716       include 'DIMENSIONS'
5717       include 'COMMON.VAR'
5718       include 'COMMON.GEO'
5719       include 'COMMON.LOCAL'
5720       include 'COMMON.TORSION'
5721       include 'COMMON.SCCOR'
5722       include 'COMMON.INTERACT'
5723       include 'COMMON.DERIV'
5724       include 'COMMON.CHAIN'
5725       include 'COMMON.NAMES'
5726       include 'COMMON.IOUNITS'
5727       include 'COMMON.FFIELD'
5728       include 'COMMON.CONTROL'
5729       logical lprn
5730 C Set lprn=.true. for debugging
5731       lprn=.false.
5732 c      lprn=.true.
5733 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5734       esccor=0.0D0
5735       do i=itau_start,itau_end
5736         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5737         esccor_ii=0.0D0
5738         isccori=isccortyp(itype(i-2))
5739         isccori1=isccortyp(itype(i-1))
5740 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5741         phii=phi(i)
5742         do intertyp=1,3 !intertyp
5743 cc Added 09 May 2012 (Adasko)
5744 cc  Intertyp means interaction type of backbone mainchain correlation:
5745 c   1 = SC...Ca...Ca...Ca
5746 c   2 = Ca...Ca...Ca...SC
5747 c   3 = SC...Ca...Ca...SCi
5748         gloci=0.0D0
5749         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5750      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5751      &      (itype(i-1).eq.ntyp1)))
5752      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5753      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5754      &     .or.(itype(i).eq.ntyp1)))
5755      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5756      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5757      &      (itype(i-3).eq.ntyp1)))) cycle
5758         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5759         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5760      & cycle
5761        do j=1,nterm_sccor(isccori,isccori1)
5762           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5763           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5764           cosphi=dcos(j*tauangle(intertyp,i))
5765           sinphi=dsin(j*tauangle(intertyp,i))
5766           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5767           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5768         enddo
5769 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5770         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5771         if (lprn)
5772      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5773      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5774      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5775      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5776         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5777        enddo !intertyp
5778       enddo
5779
5780       return
5781       end
5782 c----------------------------------------------------------------------------
5783       subroutine multibody(ecorr)
5784 C This subroutine calculates multi-body contributions to energy following
5785 C the idea of Skolnick et al. If side chains I and J make a contact and
5786 C at the same time side chains I+1 and J+1 make a contact, an extra
5787 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5788       implicit real*8 (a-h,o-z)
5789       include 'DIMENSIONS'
5790       include 'COMMON.IOUNITS'
5791       include 'COMMON.DERIV'
5792       include 'COMMON.INTERACT'
5793       include 'COMMON.CONTACTS'
5794       double precision gx(3),gx1(3)
5795       logical lprn
5796
5797 C Set lprn=.true. for debugging
5798       lprn=.false.
5799
5800       if (lprn) then
5801         write (iout,'(a)') 'Contact function values:'
5802         do i=nnt,nct-2
5803           write (iout,'(i2,20(1x,i2,f10.5))')
5804      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5805         enddo
5806       endif
5807       ecorr=0.0D0
5808       do i=nnt,nct
5809         do j=1,3
5810           gradcorr(j,i)=0.0D0
5811           gradxorr(j,i)=0.0D0
5812         enddo
5813       enddo
5814       do i=nnt,nct-2
5815
5816         DO ISHIFT = 3,4
5817
5818         i1=i+ishift
5819         num_conti=num_cont(i)
5820         num_conti1=num_cont(i1)
5821         do jj=1,num_conti
5822           j=jcont(jj,i)
5823           do kk=1,num_conti1
5824             j1=jcont(kk,i1)
5825             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5826 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5827 cd   &                   ' ishift=',ishift
5828 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5829 C The system gains extra energy.
5830               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5831             endif   ! j1==j+-ishift
5832           enddo     ! kk
5833         enddo       ! jj
5834
5835         ENDDO ! ISHIFT
5836
5837       enddo         ! i
5838       return
5839       end
5840 c------------------------------------------------------------------------------
5841       double precision function esccorr(i,j,k,l,jj,kk)
5842       implicit real*8 (a-h,o-z)
5843       include 'DIMENSIONS'
5844       include 'COMMON.IOUNITS'
5845       include 'COMMON.DERIV'
5846       include 'COMMON.INTERACT'
5847       include 'COMMON.CONTACTS'
5848       double precision gx(3),gx1(3)
5849       logical lprn
5850       lprn=.false.
5851       eij=facont(jj,i)
5852       ekl=facont(kk,k)
5853 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5854 C Calculate the multi-body contribution to energy.
5855 C Calculate multi-body contributions to the gradient.
5856 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5857 cd   & k,l,(gacont(m,kk,k),m=1,3)
5858       do m=1,3
5859         gx(m) =ekl*gacont(m,jj,i)
5860         gx1(m)=eij*gacont(m,kk,k)
5861         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5862         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5863         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5864         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5865       enddo
5866       do m=i,j-1
5867         do ll=1,3
5868           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5869         enddo
5870       enddo
5871       do m=k,l-1
5872         do ll=1,3
5873           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5874         enddo
5875       enddo
5876       esccorr=-eij*ekl
5877       return
5878       end
5879 c------------------------------------------------------------------------------
5880       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5881 C This subroutine calculates multi-body contributions to hydrogen-bonding
5882       implicit real*8 (a-h,o-z)
5883       include 'DIMENSIONS'
5884       include 'COMMON.IOUNITS'
5885 #ifdef MPI
5886       include "mpif.h"
5887       parameter (max_cont=maxconts)
5888       parameter (max_dim=26)
5889       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5890       double precision zapas(max_dim,maxconts,max_fg_procs),
5891      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5892       common /przechowalnia/ zapas
5893       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5894      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5895 #endif
5896       include 'COMMON.SETUP'
5897       include 'COMMON.FFIELD'
5898       include 'COMMON.DERIV'
5899       include 'COMMON.INTERACT'
5900       include 'COMMON.CONTACTS'
5901       include 'COMMON.CONTROL'
5902       include 'COMMON.LOCAL'
5903       double precision gx(3),gx1(3),time00
5904       logical lprn,ldone
5905
5906 C Set lprn=.true. for debugging
5907       lprn=.false.
5908 #ifdef MPI
5909       n_corr=0
5910       n_corr1=0
5911       if (nfgtasks.le.1) goto 30
5912       if (lprn) then
5913         write (iout,'(a)') 'Contact function values before RECEIVE:'
5914         do i=nnt,nct-2
5915           write (iout,'(2i3,50(1x,i2,f5.2))')
5916      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5917      &    j=1,num_cont_hb(i))
5918         enddo
5919       endif
5920       call flush(iout)
5921       do i=1,ntask_cont_from
5922         ncont_recv(i)=0
5923       enddo
5924       do i=1,ntask_cont_to
5925         ncont_sent(i)=0
5926       enddo
5927 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5928 c     & ntask_cont_to
5929 C Make the list of contacts to send to send to other procesors
5930 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5931 c      call flush(iout)
5932       do i=iturn3_start,iturn3_end
5933 c        write (iout,*) "make contact list turn3",i," num_cont",
5934 c     &    num_cont_hb(i)
5935         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5936       enddo
5937       do i=iturn4_start,iturn4_end
5938 c        write (iout,*) "make contact list turn4",i," num_cont",
5939 c     &   num_cont_hb(i)
5940         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5941       enddo
5942       do ii=1,nat_sent
5943         i=iat_sent(ii)
5944 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5945 c     &    num_cont_hb(i)
5946         do j=1,num_cont_hb(i)
5947         do k=1,4
5948           jjc=jcont_hb(j,i)
5949           iproc=iint_sent_local(k,jjc,ii)
5950 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5951           if (iproc.gt.0) then
5952             ncont_sent(iproc)=ncont_sent(iproc)+1
5953             nn=ncont_sent(iproc)
5954             zapas(1,nn,iproc)=i
5955             zapas(2,nn,iproc)=jjc
5956             zapas(3,nn,iproc)=facont_hb(j,i)
5957             zapas(4,nn,iproc)=ees0p(j,i)
5958             zapas(5,nn,iproc)=ees0m(j,i)
5959             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5960             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5961             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5962             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5963             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5964             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5965             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5966             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5967             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5968             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5969             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5970             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5971             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5972             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5973             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5974             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5975             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5976             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5977             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5978             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5979             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5980           endif
5981         enddo
5982         enddo
5983       enddo
5984       if (lprn) then
5985       write (iout,*)
5986      &  "Numbers of contacts to be sent to other processors",
5987      &  (ncont_sent(i),i=1,ntask_cont_to)
5988       write (iout,*) "Contacts sent"
5989       do ii=1,ntask_cont_to
5990         nn=ncont_sent(ii)
5991         iproc=itask_cont_to(ii)
5992         write (iout,*) nn," contacts to processor",iproc,
5993      &   " of CONT_TO_COMM group"
5994         do i=1,nn
5995           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5996         enddo
5997       enddo
5998       call flush(iout)
5999       endif
6000       CorrelType=477
6001       CorrelID=fg_rank+1
6002       CorrelType1=478
6003       CorrelID1=nfgtasks+fg_rank+1
6004       ireq=0
6005 C Receive the numbers of needed contacts from other processors
6006       do ii=1,ntask_cont_from
6007         iproc=itask_cont_from(ii)
6008         ireq=ireq+1
6009         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6010      &    FG_COMM,req(ireq),IERR)
6011       enddo
6012 c      write (iout,*) "IRECV ended"
6013 c      call flush(iout)
6014 C Send the number of contacts needed by other processors
6015       do ii=1,ntask_cont_to
6016         iproc=itask_cont_to(ii)
6017         ireq=ireq+1
6018         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6019      &    FG_COMM,req(ireq),IERR)
6020       enddo
6021 c      write (iout,*) "ISEND ended"
6022 c      write (iout,*) "number of requests (nn)",ireq
6023       call flush(iout)
6024       if (ireq.gt.0)
6025      &  call MPI_Waitall(ireq,req,status_array,ierr)
6026 c      write (iout,*)
6027 c     &  "Numbers of contacts to be received from other processors",
6028 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6029 c      call flush(iout)
6030 C Receive contacts
6031       ireq=0
6032       do ii=1,ntask_cont_from
6033         iproc=itask_cont_from(ii)
6034         nn=ncont_recv(ii)
6035 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6036 c     &   " of CONT_TO_COMM group"
6037         call flush(iout)
6038         if (nn.gt.0) then
6039           ireq=ireq+1
6040           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6041      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6042 c          write (iout,*) "ireq,req",ireq,req(ireq)
6043         endif
6044       enddo
6045 C Send the contacts to processors that need them
6046       do ii=1,ntask_cont_to
6047         iproc=itask_cont_to(ii)
6048         nn=ncont_sent(ii)
6049 c        write (iout,*) nn," contacts to processor",iproc,
6050 c     &   " of CONT_TO_COMM group"
6051         if (nn.gt.0) then
6052           ireq=ireq+1
6053           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6054      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6055 c          write (iout,*) "ireq,req",ireq,req(ireq)
6056 c          do i=1,nn
6057 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6058 c          enddo
6059         endif
6060       enddo
6061 c      write (iout,*) "number of requests (contacts)",ireq
6062 c      write (iout,*) "req",(req(i),i=1,4)
6063 c      call flush(iout)
6064       if (ireq.gt.0)
6065      & call MPI_Waitall(ireq,req,status_array,ierr)
6066       do iii=1,ntask_cont_from
6067         iproc=itask_cont_from(iii)
6068         nn=ncont_recv(iii)
6069         if (lprn) then
6070         write (iout,*) "Received",nn," contacts from processor",iproc,
6071      &   " of CONT_FROM_COMM group"
6072         call flush(iout)
6073         do i=1,nn
6074           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6075         enddo
6076         call flush(iout)
6077         endif
6078         do i=1,nn
6079           ii=zapas_recv(1,i,iii)
6080 c Flag the received contacts to prevent double-counting
6081           jj=-zapas_recv(2,i,iii)
6082 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6083 c          call flush(iout)
6084           nnn=num_cont_hb(ii)+1
6085           num_cont_hb(ii)=nnn
6086           jcont_hb(nnn,ii)=jj
6087           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6088           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6089           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6090           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6091           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6092           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6093           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6094           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6095           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6096           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6097           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6098           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6099           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6100           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6101           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6102           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6103           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6104           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6105           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6106           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6107           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6108           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6109           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6110           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6111         enddo
6112       enddo
6113       call flush(iout)
6114       if (lprn) then
6115         write (iout,'(a)') 'Contact function values after receive:'
6116         do i=nnt,nct-2
6117           write (iout,'(2i3,50(1x,i3,f5.2))')
6118      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6119      &    j=1,num_cont_hb(i))
6120         enddo
6121         call flush(iout)
6122       endif
6123    30 continue
6124 #endif
6125       if (lprn) then
6126         write (iout,'(a)') 'Contact function values:'
6127         do i=nnt,nct-2
6128           write (iout,'(2i3,50(1x,i3,f5.2))')
6129      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6130      &    j=1,num_cont_hb(i))
6131         enddo
6132       endif
6133       ecorr=0.0D0
6134 C Remove the loop below after debugging !!!
6135       do i=nnt,nct
6136         do j=1,3
6137           gradcorr(j,i)=0.0D0
6138           gradxorr(j,i)=0.0D0
6139         enddo
6140       enddo
6141 C Calculate the local-electrostatic correlation terms
6142       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6143         i1=i+1
6144         num_conti=num_cont_hb(i)
6145         num_conti1=num_cont_hb(i+1)
6146         do jj=1,num_conti
6147           j=jcont_hb(jj,i)
6148           jp=iabs(j)
6149           do kk=1,num_conti1
6150             j1=jcont_hb(kk,i1)
6151             jp1=iabs(j1)
6152 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6153 c     &         ' jj=',jj,' kk=',kk
6154             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6155      &          .or. j.lt.0 .and. j1.gt.0) .and.
6156      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6157 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6158 C The system gains extra energy.
6159               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6160               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6161      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6162               n_corr=n_corr+1
6163             else if (j1.eq.j) then
6164 C Contacts I-J and I-(J+1) occur simultaneously.
6165 C The system loses extra energy.
6166 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6167             endif
6168           enddo ! kk
6169           do kk=1,num_conti
6170             j1=jcont_hb(kk,i)
6171 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6172 c    &         ' jj=',jj,' kk=',kk
6173             if (j1.eq.j+1) then
6174 C Contacts I-J and (I+1)-J occur simultaneously.
6175 C The system loses extra energy.
6176 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6177             endif ! j1==j+1
6178           enddo ! kk
6179         enddo ! jj
6180       enddo ! i
6181       return
6182       end
6183 c------------------------------------------------------------------------------
6184       subroutine add_hb_contact(ii,jj,itask)
6185       implicit real*8 (a-h,o-z)
6186       include "DIMENSIONS"
6187       include "COMMON.IOUNITS"
6188       integer max_cont
6189       integer max_dim
6190       parameter (max_cont=maxconts)
6191       parameter (max_dim=26)
6192       include "COMMON.CONTACTS"
6193       double precision zapas(max_dim,maxconts,max_fg_procs),
6194      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6195       common /przechowalnia/ zapas
6196       integer i,j,ii,jj,iproc,itask(4),nn
6197 c      write (iout,*) "itask",itask
6198       do i=1,2
6199         iproc=itask(i)
6200         if (iproc.gt.0) then
6201           do j=1,num_cont_hb(ii)
6202             jjc=jcont_hb(j,ii)
6203 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6204             if (jjc.eq.jj) then
6205               ncont_sent(iproc)=ncont_sent(iproc)+1
6206               nn=ncont_sent(iproc)
6207               zapas(1,nn,iproc)=ii
6208               zapas(2,nn,iproc)=jjc
6209               zapas(3,nn,iproc)=facont_hb(j,ii)
6210               zapas(4,nn,iproc)=ees0p(j,ii)
6211               zapas(5,nn,iproc)=ees0m(j,ii)
6212               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6213               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6214               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6215               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6216               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6217               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6218               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6219               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6220               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6221               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6222               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6223               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6224               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6225               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6226               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6227               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6228               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6229               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6230               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6231               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6232               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6233               exit
6234             endif
6235           enddo
6236         endif
6237       enddo
6238       return
6239       end
6240 c------------------------------------------------------------------------------
6241       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6242      &  n_corr1)
6243 C This subroutine calculates multi-body contributions to hydrogen-bonding
6244       implicit real*8 (a-h,o-z)
6245       include 'DIMENSIONS'
6246       include 'COMMON.IOUNITS'
6247 #ifdef MPI
6248       include "mpif.h"
6249       parameter (max_cont=maxconts)
6250       parameter (max_dim=70)
6251       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6252       double precision zapas(max_dim,maxconts,max_fg_procs),
6253      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6254       common /przechowalnia/ zapas
6255       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6256      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6257 #endif
6258       include 'COMMON.SETUP'
6259       include 'COMMON.FFIELD'
6260       include 'COMMON.DERIV'
6261       include 'COMMON.LOCAL'
6262       include 'COMMON.INTERACT'
6263       include 'COMMON.CONTACTS'
6264       include 'COMMON.CHAIN'
6265       include 'COMMON.CONTROL'
6266       double precision gx(3),gx1(3)
6267       integer num_cont_hb_old(maxres)
6268       logical lprn,ldone
6269       double precision eello4,eello5,eelo6,eello_turn6
6270       external eello4,eello5,eello6,eello_turn6
6271 C Set lprn=.true. for debugging
6272       lprn=.false.
6273       eturn6=0.0d0
6274 #ifdef MPI
6275       do i=1,nres
6276         num_cont_hb_old(i)=num_cont_hb(i)
6277       enddo
6278       n_corr=0
6279       n_corr1=0
6280       if (nfgtasks.le.1) goto 30
6281       if (lprn) then
6282         write (iout,'(a)') 'Contact function values before RECEIVE:'
6283         do i=nnt,nct-2
6284           write (iout,'(2i3,50(1x,i2,f5.2))')
6285      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6286      &    j=1,num_cont_hb(i))
6287         enddo
6288       endif
6289       call flush(iout)
6290       do i=1,ntask_cont_from
6291         ncont_recv(i)=0
6292       enddo
6293       do i=1,ntask_cont_to
6294         ncont_sent(i)=0
6295       enddo
6296 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6297 c     & ntask_cont_to
6298 C Make the list of contacts to send to send to other procesors
6299       do i=iturn3_start,iturn3_end
6300 c        write (iout,*) "make contact list turn3",i," num_cont",
6301 c     &    num_cont_hb(i)
6302         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6303       enddo
6304       do i=iturn4_start,iturn4_end
6305 c        write (iout,*) "make contact list turn4",i," num_cont",
6306 c     &   num_cont_hb(i)
6307         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6308       enddo
6309       do ii=1,nat_sent
6310         i=iat_sent(ii)
6311 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6312 c     &    num_cont_hb(i)
6313         do j=1,num_cont_hb(i)
6314         do k=1,4
6315           jjc=jcont_hb(j,i)
6316           iproc=iint_sent_local(k,jjc,ii)
6317 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6318           if (iproc.ne.0) then
6319             ncont_sent(iproc)=ncont_sent(iproc)+1
6320             nn=ncont_sent(iproc)
6321             zapas(1,nn,iproc)=i
6322             zapas(2,nn,iproc)=jjc
6323             zapas(3,nn,iproc)=d_cont(j,i)
6324             ind=3
6325             do kk=1,3
6326               ind=ind+1
6327               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6328             enddo
6329             do kk=1,2
6330               do ll=1,2
6331                 ind=ind+1
6332                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6333               enddo
6334             enddo
6335             do jj=1,5
6336               do kk=1,3
6337                 do ll=1,2
6338                   do mm=1,2
6339                     ind=ind+1
6340                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6341                   enddo
6342                 enddo
6343               enddo
6344             enddo
6345           endif
6346         enddo
6347         enddo
6348       enddo
6349       if (lprn) then
6350       write (iout,*)
6351      &  "Numbers of contacts to be sent to other processors",
6352      &  (ncont_sent(i),i=1,ntask_cont_to)
6353       write (iout,*) "Contacts sent"
6354       do ii=1,ntask_cont_to
6355         nn=ncont_sent(ii)
6356         iproc=itask_cont_to(ii)
6357         write (iout,*) nn," contacts to processor",iproc,
6358      &   " of CONT_TO_COMM group"
6359         do i=1,nn
6360           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6361         enddo
6362       enddo
6363       call flush(iout)
6364       endif
6365       CorrelType=477
6366       CorrelID=fg_rank+1
6367       CorrelType1=478
6368       CorrelID1=nfgtasks+fg_rank+1
6369       ireq=0
6370 C Receive the numbers of needed contacts from other processors
6371       do ii=1,ntask_cont_from
6372         iproc=itask_cont_from(ii)
6373         ireq=ireq+1
6374         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6375      &    FG_COMM,req(ireq),IERR)
6376       enddo
6377 c      write (iout,*) "IRECV ended"
6378 c      call flush(iout)
6379 C Send the number of contacts needed by other processors
6380       do ii=1,ntask_cont_to
6381         iproc=itask_cont_to(ii)
6382         ireq=ireq+1
6383         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6384      &    FG_COMM,req(ireq),IERR)
6385       enddo
6386 c      write (iout,*) "ISEND ended"
6387 c      write (iout,*) "number of requests (nn)",ireq
6388       call flush(iout)
6389       if (ireq.gt.0)
6390      &  call MPI_Waitall(ireq,req,status_array,ierr)
6391 c      write (iout,*)
6392 c     &  "Numbers of contacts to be received from other processors",
6393 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6394 c      call flush(iout)
6395 C Receive contacts
6396       ireq=0
6397       do ii=1,ntask_cont_from
6398         iproc=itask_cont_from(ii)
6399         nn=ncont_recv(ii)
6400 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6401 c     &   " of CONT_TO_COMM group"
6402         call flush(iout)
6403         if (nn.gt.0) then
6404           ireq=ireq+1
6405           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6406      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6407 c          write (iout,*) "ireq,req",ireq,req(ireq)
6408         endif
6409       enddo
6410 C Send the contacts to processors that need them
6411       do ii=1,ntask_cont_to
6412         iproc=itask_cont_to(ii)
6413         nn=ncont_sent(ii)
6414 c        write (iout,*) nn," contacts to processor",iproc,
6415 c     &   " of CONT_TO_COMM group"
6416         if (nn.gt.0) then
6417           ireq=ireq+1
6418           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6419      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6420 c          write (iout,*) "ireq,req",ireq,req(ireq)
6421 c          do i=1,nn
6422 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6423 c          enddo
6424         endif
6425       enddo
6426 c      write (iout,*) "number of requests (contacts)",ireq
6427 c      write (iout,*) "req",(req(i),i=1,4)
6428 c      call flush(iout)
6429       if (ireq.gt.0)
6430      & call MPI_Waitall(ireq,req,status_array,ierr)
6431       do iii=1,ntask_cont_from
6432         iproc=itask_cont_from(iii)
6433         nn=ncont_recv(iii)
6434         if (lprn) then
6435         write (iout,*) "Received",nn," contacts from processor",iproc,
6436      &   " of CONT_FROM_COMM group"
6437         call flush(iout)
6438         do i=1,nn
6439           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6440         enddo
6441         call flush(iout)
6442         endif
6443         do i=1,nn
6444           ii=zapas_recv(1,i,iii)
6445 c Flag the received contacts to prevent double-counting
6446           jj=-zapas_recv(2,i,iii)
6447 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6448 c          call flush(iout)
6449           nnn=num_cont_hb(ii)+1
6450           num_cont_hb(ii)=nnn
6451           jcont_hb(nnn,ii)=jj
6452           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6453           ind=3
6454           do kk=1,3
6455             ind=ind+1
6456             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6457           enddo
6458           do kk=1,2
6459             do ll=1,2
6460               ind=ind+1
6461               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6462             enddo
6463           enddo
6464           do jj=1,5
6465             do kk=1,3
6466               do ll=1,2
6467                 do mm=1,2
6468                   ind=ind+1
6469                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6470                 enddo
6471               enddo
6472             enddo
6473           enddo
6474         enddo
6475       enddo
6476       call flush(iout)
6477       if (lprn) then
6478         write (iout,'(a)') 'Contact function values after receive:'
6479         do i=nnt,nct-2
6480           write (iout,'(2i3,50(1x,i3,5f6.3))')
6481      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6482      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6483         enddo
6484         call flush(iout)
6485       endif
6486    30 continue
6487 #endif
6488       if (lprn) then
6489         write (iout,'(a)') 'Contact function values:'
6490         do i=nnt,nct-2
6491           write (iout,'(2i3,50(1x,i2,5f6.3))')
6492      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6493      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6494         enddo
6495       endif
6496       ecorr=0.0D0
6497       ecorr5=0.0d0
6498       ecorr6=0.0d0
6499 C Remove the loop below after debugging !!!
6500       do i=nnt,nct
6501         do j=1,3
6502           gradcorr(j,i)=0.0D0
6503           gradxorr(j,i)=0.0D0
6504         enddo
6505       enddo
6506 C Calculate the dipole-dipole interaction energies
6507       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6508       do i=iatel_s,iatel_e+1
6509         num_conti=num_cont_hb(i)
6510         do jj=1,num_conti
6511           j=jcont_hb(jj,i)
6512 #ifdef MOMENT
6513           call dipole(i,j,jj)
6514 #endif
6515         enddo
6516       enddo
6517       endif
6518 C Calculate the local-electrostatic correlation terms
6519 c                write (iout,*) "gradcorr5 in eello5 before loop"
6520 c                do iii=1,nres
6521 c                  write (iout,'(i5,3f10.5)')
6522 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6523 c                enddo
6524       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6525 c        write (iout,*) "corr loop i",i
6526         i1=i+1
6527         num_conti=num_cont_hb(i)
6528         num_conti1=num_cont_hb(i+1)
6529         do jj=1,num_conti
6530           j=jcont_hb(jj,i)
6531           jp=iabs(j)
6532           do kk=1,num_conti1
6533             j1=jcont_hb(kk,i1)
6534             jp1=iabs(j1)
6535 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6536 c     &         ' jj=',jj,' kk=',kk
6537 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6538             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6539      &          .or. j.lt.0 .and. j1.gt.0) .and.
6540      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6541 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6542 C The system gains extra energy.
6543               n_corr=n_corr+1
6544               sqd1=dsqrt(d_cont(jj,i))
6545               sqd2=dsqrt(d_cont(kk,i1))
6546               sred_geom = sqd1*sqd2
6547               IF (sred_geom.lt.cutoff_corr) THEN
6548                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6549      &            ekont,fprimcont)
6550 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6551 cd     &         ' jj=',jj,' kk=',kk
6552                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6553                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6554                 do l=1,3
6555                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6556                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6557                 enddo
6558                 n_corr1=n_corr1+1
6559 cd               write (iout,*) 'sred_geom=',sred_geom,
6560 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6561 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6562 cd               write (iout,*) "g_contij",g_contij
6563 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6564 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6565                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6566                 if (wcorr4.gt.0.0d0)
6567      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6568                   if (energy_dec.and.wcorr4.gt.0.0d0)
6569      1                 write (iout,'(a6,4i5,0pf7.3)')
6570      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6571 c                write (iout,*) "gradcorr5 before eello5"
6572 c                do iii=1,nres
6573 c                  write (iout,'(i5,3f10.5)')
6574 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6575 c                enddo
6576                 if (wcorr5.gt.0.0d0)
6577      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6578 c                write (iout,*) "gradcorr5 after eello5"
6579 c                do iii=1,nres
6580 c                  write (iout,'(i5,3f10.5)')
6581 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6582 c                enddo
6583                   if (energy_dec.and.wcorr5.gt.0.0d0)
6584      1                 write (iout,'(a6,4i5,0pf7.3)')
6585      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6586 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6587 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6588                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6589      &               .or. wturn6.eq.0.0d0))then
6590 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6591                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6592                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6593      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6594 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6595 cd     &            'ecorr6=',ecorr6
6596 cd                write (iout,'(4e15.5)') sred_geom,
6597 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6598 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6599 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6600                 else if (wturn6.gt.0.0d0
6601      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6602 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6603                   eturn6=eturn6+eello_turn6(i,jj,kk)
6604                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6605      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6606 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6607                 endif
6608               ENDIF
6609 1111          continue
6610             endif
6611           enddo ! kk
6612         enddo ! jj
6613       enddo ! i
6614       do i=1,nres
6615         num_cont_hb(i)=num_cont_hb_old(i)
6616       enddo
6617 c                write (iout,*) "gradcorr5 in eello5"
6618 c                do iii=1,nres
6619 c                  write (iout,'(i5,3f10.5)')
6620 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6621 c                enddo
6622       return
6623       end
6624 c------------------------------------------------------------------------------
6625       subroutine add_hb_contact_eello(ii,jj,itask)
6626       implicit real*8 (a-h,o-z)
6627       include "DIMENSIONS"
6628       include "COMMON.IOUNITS"
6629       integer max_cont
6630       integer max_dim
6631       parameter (max_cont=maxconts)
6632       parameter (max_dim=70)
6633       include "COMMON.CONTACTS"
6634       double precision zapas(max_dim,maxconts,max_fg_procs),
6635      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6636       common /przechowalnia/ zapas
6637       integer i,j,ii,jj,iproc,itask(4),nn
6638 c      write (iout,*) "itask",itask
6639       do i=1,2
6640         iproc=itask(i)
6641         if (iproc.gt.0) then
6642           do j=1,num_cont_hb(ii)
6643             jjc=jcont_hb(j,ii)
6644 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6645             if (jjc.eq.jj) then
6646               ncont_sent(iproc)=ncont_sent(iproc)+1
6647               nn=ncont_sent(iproc)
6648               zapas(1,nn,iproc)=ii
6649               zapas(2,nn,iproc)=jjc
6650               zapas(3,nn,iproc)=d_cont(j,ii)
6651               ind=3
6652               do kk=1,3
6653                 ind=ind+1
6654                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6655               enddo
6656               do kk=1,2
6657                 do ll=1,2
6658                   ind=ind+1
6659                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6660                 enddo
6661               enddo
6662               do jj=1,5
6663                 do kk=1,3
6664                   do ll=1,2
6665                     do mm=1,2
6666                       ind=ind+1
6667                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6668                     enddo
6669                   enddo
6670                 enddo
6671               enddo
6672               exit
6673             endif
6674           enddo
6675         endif
6676       enddo
6677       return
6678       end
6679 c------------------------------------------------------------------------------
6680       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6681       implicit real*8 (a-h,o-z)
6682       include 'DIMENSIONS'
6683       include 'COMMON.IOUNITS'
6684       include 'COMMON.DERIV'
6685       include 'COMMON.INTERACT'
6686       include 'COMMON.CONTACTS'
6687       double precision gx(3),gx1(3)
6688       logical lprn
6689       lprn=.false.
6690       eij=facont_hb(jj,i)
6691       ekl=facont_hb(kk,k)
6692       ees0pij=ees0p(jj,i)
6693       ees0pkl=ees0p(kk,k)
6694       ees0mij=ees0m(jj,i)
6695       ees0mkl=ees0m(kk,k)
6696       ekont=eij*ekl
6697       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6698 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6699 C Following 4 lines for diagnostics.
6700 cd    ees0pkl=0.0D0
6701 cd    ees0pij=1.0D0
6702 cd    ees0mkl=0.0D0
6703 cd    ees0mij=1.0D0
6704 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6705 c     & 'Contacts ',i,j,
6706 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6707 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6708 c     & 'gradcorr_long'
6709 C Calculate the multi-body contribution to energy.
6710 c      ecorr=ecorr+ekont*ees
6711 C Calculate multi-body contributions to the gradient.
6712       coeffpees0pij=coeffp*ees0pij
6713       coeffmees0mij=coeffm*ees0mij
6714       coeffpees0pkl=coeffp*ees0pkl
6715       coeffmees0mkl=coeffm*ees0mkl
6716       do ll=1,3
6717 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6718         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6719      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6720      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6721         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6722      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6723      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6724 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6725         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6726      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6727      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6728         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6729      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6730      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6731         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6732      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6733      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6734         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6735         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6736         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6737      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6738      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6739         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6740         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6741 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6742       enddo
6743 c      write (iout,*)
6744 cgrad      do m=i+1,j-1
6745 cgrad        do ll=1,3
6746 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6747 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6748 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6749 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6750 cgrad        enddo
6751 cgrad      enddo
6752 cgrad      do m=k+1,l-1
6753 cgrad        do ll=1,3
6754 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6755 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6756 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6757 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6758 cgrad        enddo
6759 cgrad      enddo
6760 c      write (iout,*) "ehbcorr",ekont*ees
6761       ehbcorr=ekont*ees
6762       return
6763       end
6764 #ifdef MOMENT
6765 C---------------------------------------------------------------------------
6766       subroutine dipole(i,j,jj)
6767       implicit real*8 (a-h,o-z)
6768       include 'DIMENSIONS'
6769       include 'COMMON.IOUNITS'
6770       include 'COMMON.CHAIN'
6771       include 'COMMON.FFIELD'
6772       include 'COMMON.DERIV'
6773       include 'COMMON.INTERACT'
6774       include 'COMMON.CONTACTS'
6775       include 'COMMON.TORSION'
6776       include 'COMMON.VAR'
6777       include 'COMMON.GEO'
6778       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6779      &  auxmat(2,2)
6780       iti1 = itortyp(itype(i+1))
6781       if (j.lt.nres-1) then
6782         itj1 = itortyp(itype(j+1))
6783       else
6784         itj1=ntortyp+1
6785       endif
6786       do iii=1,2
6787         dipi(iii,1)=Ub2(iii,i)
6788         dipderi(iii)=Ub2der(iii,i)
6789         dipi(iii,2)=b1(iii,iti1)
6790         dipj(iii,1)=Ub2(iii,j)
6791         dipderj(iii)=Ub2der(iii,j)
6792         dipj(iii,2)=b1(iii,itj1)
6793       enddo
6794       kkk=0
6795       do iii=1,2
6796         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6797         do jjj=1,2
6798           kkk=kkk+1
6799           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6800         enddo
6801       enddo
6802       do kkk=1,5
6803         do lll=1,3
6804           mmm=0
6805           do iii=1,2
6806             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6807      &        auxvec(1))
6808             do jjj=1,2
6809               mmm=mmm+1
6810               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6811             enddo
6812           enddo
6813         enddo
6814       enddo
6815       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6816       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6817       do iii=1,2
6818         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6819       enddo
6820       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6821       do iii=1,2
6822         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6823       enddo
6824       return
6825       end
6826 #endif
6827 C---------------------------------------------------------------------------
6828       subroutine calc_eello(i,j,k,l,jj,kk)
6829 C
6830 C This subroutine computes matrices and vectors needed to calculate
6831 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6832 C
6833       implicit real*8 (a-h,o-z)
6834       include 'DIMENSIONS'
6835       include 'COMMON.IOUNITS'
6836       include 'COMMON.CHAIN'
6837       include 'COMMON.DERIV'
6838       include 'COMMON.INTERACT'
6839       include 'COMMON.CONTACTS'
6840       include 'COMMON.TORSION'
6841       include 'COMMON.VAR'
6842       include 'COMMON.GEO'
6843       include 'COMMON.FFIELD'
6844       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6845      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6846       logical lprn
6847       common /kutas/ lprn
6848 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6849 cd     & ' jj=',jj,' kk=',kk
6850 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6851 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6852 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6853       do iii=1,2
6854         do jjj=1,2
6855           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6856           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6857         enddo
6858       enddo
6859       call transpose2(aa1(1,1),aa1t(1,1))
6860       call transpose2(aa2(1,1),aa2t(1,1))
6861       do kkk=1,5
6862         do lll=1,3
6863           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6864      &      aa1tder(1,1,lll,kkk))
6865           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6866      &      aa2tder(1,1,lll,kkk))
6867         enddo
6868       enddo
6869       if (l.eq.j+1) then
6870 C parallel orientation of the two CA-CA-CA frames.
6871         if (i.gt.1) then
6872           iti=itortyp(itype(i))
6873         else
6874           iti=ntortyp+1
6875         endif
6876         itk1=itortyp(itype(k+1))
6877         itj=itortyp(itype(j))
6878         if (l.lt.nres-1) then
6879           itl1=itortyp(itype(l+1))
6880         else
6881           itl1=ntortyp+1
6882         endif
6883 C A1 kernel(j+1) A2T
6884 cd        do iii=1,2
6885 cd          write (iout,'(3f10.5,5x,3f10.5)')
6886 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6887 cd        enddo
6888         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6889      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6890      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6891 C Following matrices are needed only for 6-th order cumulants
6892         IF (wcorr6.gt.0.0d0) THEN
6893         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6894      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6895      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6896         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6897      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6898      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6899      &   ADtEAderx(1,1,1,1,1,1))
6900         lprn=.false.
6901         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6902      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6903      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6904      &   ADtEA1derx(1,1,1,1,1,1))
6905         ENDIF
6906 C End 6-th order cumulants
6907 cd        lprn=.false.
6908 cd        if (lprn) then
6909 cd        write (2,*) 'In calc_eello6'
6910 cd        do iii=1,2
6911 cd          write (2,*) 'iii=',iii
6912 cd          do kkk=1,5
6913 cd            write (2,*) 'kkk=',kkk
6914 cd            do jjj=1,2
6915 cd              write (2,'(3(2f10.5),5x)')
6916 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6917 cd            enddo
6918 cd          enddo
6919 cd        enddo
6920 cd        endif
6921         call transpose2(EUgder(1,1,k),auxmat(1,1))
6922         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6923         call transpose2(EUg(1,1,k),auxmat(1,1))
6924         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6925         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6926         do iii=1,2
6927           do kkk=1,5
6928             do lll=1,3
6929               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6930      &          EAEAderx(1,1,lll,kkk,iii,1))
6931             enddo
6932           enddo
6933         enddo
6934 C A1T kernel(i+1) A2
6935         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6936      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6937      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6938 C Following matrices are needed only for 6-th order cumulants
6939         IF (wcorr6.gt.0.0d0) THEN
6940         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6941      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6942      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6943         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6944      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6945      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6946      &   ADtEAderx(1,1,1,1,1,2))
6947         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6948      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6949      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6950      &   ADtEA1derx(1,1,1,1,1,2))
6951         ENDIF
6952 C End 6-th order cumulants
6953         call transpose2(EUgder(1,1,l),auxmat(1,1))
6954         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6955         call transpose2(EUg(1,1,l),auxmat(1,1))
6956         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6957         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6958         do iii=1,2
6959           do kkk=1,5
6960             do lll=1,3
6961               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6962      &          EAEAderx(1,1,lll,kkk,iii,2))
6963             enddo
6964           enddo
6965         enddo
6966 C AEAb1 and AEAb2
6967 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6968 C They are needed only when the fifth- or the sixth-order cumulants are
6969 C indluded.
6970         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6971         call transpose2(AEA(1,1,1),auxmat(1,1))
6972         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6973         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6974         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6975         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6976         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6977         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6978         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6979         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6980         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6981         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6982         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6983         call transpose2(AEA(1,1,2),auxmat(1,1))
6984         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6985         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6986         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6987         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6988         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6989         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6990         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6991         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6992         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6993         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6994         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6995 C Calculate the Cartesian derivatives of the vectors.
6996         do iii=1,2
6997           do kkk=1,5
6998             do lll=1,3
6999               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7000               call matvec2(auxmat(1,1),b1(1,iti),
7001      &          AEAb1derx(1,lll,kkk,iii,1,1))
7002               call matvec2(auxmat(1,1),Ub2(1,i),
7003      &          AEAb2derx(1,lll,kkk,iii,1,1))
7004               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7005      &          AEAb1derx(1,lll,kkk,iii,2,1))
7006               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7007      &          AEAb2derx(1,lll,kkk,iii,2,1))
7008               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7009               call matvec2(auxmat(1,1),b1(1,itj),
7010      &          AEAb1derx(1,lll,kkk,iii,1,2))
7011               call matvec2(auxmat(1,1),Ub2(1,j),
7012      &          AEAb2derx(1,lll,kkk,iii,1,2))
7013               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7014      &          AEAb1derx(1,lll,kkk,iii,2,2))
7015               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7016      &          AEAb2derx(1,lll,kkk,iii,2,2))
7017             enddo
7018           enddo
7019         enddo
7020         ENDIF
7021 C End vectors
7022       else
7023 C Antiparallel orientation of the two CA-CA-CA frames.
7024         if (i.gt.1) then
7025           iti=itortyp(itype(i))
7026         else
7027           iti=ntortyp+1
7028         endif
7029         itk1=itortyp(itype(k+1))
7030         itl=itortyp(itype(l))
7031         itj=itortyp(itype(j))
7032         if (j.lt.nres-1) then
7033           itj1=itortyp(itype(j+1))
7034         else
7035           itj1=ntortyp+1
7036         endif
7037 C A2 kernel(j-1)T A1T
7038         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7039      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7040      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7041 C Following matrices are needed only for 6-th order cumulants
7042         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7043      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7044         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7045      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7046      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7047         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7048      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7049      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7050      &   ADtEAderx(1,1,1,1,1,1))
7051         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7052      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7053      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7054      &   ADtEA1derx(1,1,1,1,1,1))
7055         ENDIF
7056 C End 6-th order cumulants
7057         call transpose2(EUgder(1,1,k),auxmat(1,1))
7058         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7059         call transpose2(EUg(1,1,k),auxmat(1,1))
7060         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7061         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7062         do iii=1,2
7063           do kkk=1,5
7064             do lll=1,3
7065               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7066      &          EAEAderx(1,1,lll,kkk,iii,1))
7067             enddo
7068           enddo
7069         enddo
7070 C A2T kernel(i+1)T A1
7071         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7072      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7073      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7074 C Following matrices are needed only for 6-th order cumulants
7075         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7076      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7077         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7078      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7079      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7080         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7081      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7082      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7083      &   ADtEAderx(1,1,1,1,1,2))
7084         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7085      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7086      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7087      &   ADtEA1derx(1,1,1,1,1,2))
7088         ENDIF
7089 C End 6-th order cumulants
7090         call transpose2(EUgder(1,1,j),auxmat(1,1))
7091         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7092         call transpose2(EUg(1,1,j),auxmat(1,1))
7093         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7094         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7095         do iii=1,2
7096           do kkk=1,5
7097             do lll=1,3
7098               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7099      &          EAEAderx(1,1,lll,kkk,iii,2))
7100             enddo
7101           enddo
7102         enddo
7103 C AEAb1 and AEAb2
7104 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7105 C They are needed only when the fifth- or the sixth-order cumulants are
7106 C indluded.
7107         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7108      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7109         call transpose2(AEA(1,1,1),auxmat(1,1))
7110         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7111         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7112         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7113         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7114         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7115         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7116         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7117         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7118         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7119         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7120         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7121         call transpose2(AEA(1,1,2),auxmat(1,1))
7122         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7123         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7124         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7125         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7126         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7127         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7128         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7129         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7130         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7131         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7132         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7133 C Calculate the Cartesian derivatives of the vectors.
7134         do iii=1,2
7135           do kkk=1,5
7136             do lll=1,3
7137               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7138               call matvec2(auxmat(1,1),b1(1,iti),
7139      &          AEAb1derx(1,lll,kkk,iii,1,1))
7140               call matvec2(auxmat(1,1),Ub2(1,i),
7141      &          AEAb2derx(1,lll,kkk,iii,1,1))
7142               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7143      &          AEAb1derx(1,lll,kkk,iii,2,1))
7144               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7145      &          AEAb2derx(1,lll,kkk,iii,2,1))
7146               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7147               call matvec2(auxmat(1,1),b1(1,itl),
7148      &          AEAb1derx(1,lll,kkk,iii,1,2))
7149               call matvec2(auxmat(1,1),Ub2(1,l),
7150      &          AEAb2derx(1,lll,kkk,iii,1,2))
7151               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7152      &          AEAb1derx(1,lll,kkk,iii,2,2))
7153               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7154      &          AEAb2derx(1,lll,kkk,iii,2,2))
7155             enddo
7156           enddo
7157         enddo
7158         ENDIF
7159 C End vectors
7160       endif
7161       return
7162       end
7163 C---------------------------------------------------------------------------
7164       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7165      &  KK,KKderg,AKA,AKAderg,AKAderx)
7166       implicit none
7167       integer nderg
7168       logical transp
7169       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7170      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7171      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7172       integer iii,kkk,lll
7173       integer jjj,mmm
7174       logical lprn
7175       common /kutas/ lprn
7176       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7177       do iii=1,nderg
7178         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7179      &    AKAderg(1,1,iii))
7180       enddo
7181 cd      if (lprn) write (2,*) 'In kernel'
7182       do kkk=1,5
7183 cd        if (lprn) write (2,*) 'kkk=',kkk
7184         do lll=1,3
7185           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7186      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7187 cd          if (lprn) then
7188 cd            write (2,*) 'lll=',lll
7189 cd            write (2,*) 'iii=1'
7190 cd            do jjj=1,2
7191 cd              write (2,'(3(2f10.5),5x)')
7192 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7193 cd            enddo
7194 cd          endif
7195           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7196      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7197 cd          if (lprn) then
7198 cd            write (2,*) 'lll=',lll
7199 cd            write (2,*) 'iii=2'
7200 cd            do jjj=1,2
7201 cd              write (2,'(3(2f10.5),5x)')
7202 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7203 cd            enddo
7204 cd          endif
7205         enddo
7206       enddo
7207       return
7208       end
7209 C---------------------------------------------------------------------------
7210       double precision function eello4(i,j,k,l,jj,kk)
7211       implicit real*8 (a-h,o-z)
7212       include 'DIMENSIONS'
7213       include 'COMMON.IOUNITS'
7214       include 'COMMON.CHAIN'
7215       include 'COMMON.DERIV'
7216       include 'COMMON.INTERACT'
7217       include 'COMMON.CONTACTS'
7218       include 'COMMON.TORSION'
7219       include 'COMMON.VAR'
7220       include 'COMMON.GEO'
7221       double precision pizda(2,2),ggg1(3),ggg2(3)
7222 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7223 cd        eello4=0.0d0
7224 cd        return
7225 cd      endif
7226 cd      print *,'eello4:',i,j,k,l,jj,kk
7227 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7228 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7229 cold      eij=facont_hb(jj,i)
7230 cold      ekl=facont_hb(kk,k)
7231 cold      ekont=eij*ekl
7232       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7233 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7234       gcorr_loc(k-1)=gcorr_loc(k-1)
7235      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7236       if (l.eq.j+1) then
7237         gcorr_loc(l-1)=gcorr_loc(l-1)
7238      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7239       else
7240         gcorr_loc(j-1)=gcorr_loc(j-1)
7241      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7242       endif
7243       do iii=1,2
7244         do kkk=1,5
7245           do lll=1,3
7246             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7247      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7248 cd            derx(lll,kkk,iii)=0.0d0
7249           enddo
7250         enddo
7251       enddo
7252 cd      gcorr_loc(l-1)=0.0d0
7253 cd      gcorr_loc(j-1)=0.0d0
7254 cd      gcorr_loc(k-1)=0.0d0
7255 cd      eel4=1.0d0
7256 cd      write (iout,*)'Contacts have occurred for peptide groups',
7257 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7258 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7259       if (j.lt.nres-1) then
7260         j1=j+1
7261         j2=j-1
7262       else
7263         j1=j-1
7264         j2=j-2
7265       endif
7266       if (l.lt.nres-1) then
7267         l1=l+1
7268         l2=l-1
7269       else
7270         l1=l-1
7271         l2=l-2
7272       endif
7273       do ll=1,3
7274 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7275 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7276         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7277         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7278 cgrad        ghalf=0.5d0*ggg1(ll)
7279         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7280         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7281         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7282         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7283         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7284         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7285 cgrad        ghalf=0.5d0*ggg2(ll)
7286         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7287         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7288         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7289         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7290         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7291         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7292       enddo
7293 cgrad      do m=i+1,j-1
7294 cgrad        do ll=1,3
7295 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7296 cgrad        enddo
7297 cgrad      enddo
7298 cgrad      do m=k+1,l-1
7299 cgrad        do ll=1,3
7300 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7301 cgrad        enddo
7302 cgrad      enddo
7303 cgrad      do m=i+2,j2
7304 cgrad        do ll=1,3
7305 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7306 cgrad        enddo
7307 cgrad      enddo
7308 cgrad      do m=k+2,l2
7309 cgrad        do ll=1,3
7310 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7311 cgrad        enddo
7312 cgrad      enddo
7313 cd      do iii=1,nres-3
7314 cd        write (2,*) iii,gcorr_loc(iii)
7315 cd      enddo
7316       eello4=ekont*eel4
7317 cd      write (2,*) 'ekont',ekont
7318 cd      write (iout,*) 'eello4',ekont*eel4
7319       return
7320       end
7321 C---------------------------------------------------------------------------
7322       double precision function eello5(i,j,k,l,jj,kk)
7323       implicit real*8 (a-h,o-z)
7324       include 'DIMENSIONS'
7325       include 'COMMON.IOUNITS'
7326       include 'COMMON.CHAIN'
7327       include 'COMMON.DERIV'
7328       include 'COMMON.INTERACT'
7329       include 'COMMON.CONTACTS'
7330       include 'COMMON.TORSION'
7331       include 'COMMON.VAR'
7332       include 'COMMON.GEO'
7333       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7334       double precision ggg1(3),ggg2(3)
7335 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7336 C                                                                              C
7337 C                            Parallel chains                                   C
7338 C                                                                              C
7339 C          o             o                   o             o                   C
7340 C         /l\           / \             \   / \           / \   /              C
7341 C        /   \         /   \             \ /   \         /   \ /               C
7342 C       j| o |l1       | o |              o| o |         | o |o                C
7343 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7344 C      \i/   \         /   \ /             /   \         /   \                 C
7345 C       o    k1             o                                                  C
7346 C         (I)          (II)                (III)          (IV)                 C
7347 C                                                                              C
7348 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7349 C                                                                              C
7350 C                            Antiparallel chains                               C
7351 C                                                                              C
7352 C          o             o                   o             o                   C
7353 C         /j\           / \             \   / \           / \   /              C
7354 C        /   \         /   \             \ /   \         /   \ /               C
7355 C      j1| o |l        | o |              o| o |         | o |o                C
7356 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7357 C      \i/   \         /   \ /             /   \         /   \                 C
7358 C       o     k1            o                                                  C
7359 C         (I)          (II)                (III)          (IV)                 C
7360 C                                                                              C
7361 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7362 C                                                                              C
7363 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7364 C                                                                              C
7365 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7366 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7367 cd        eello5=0.0d0
7368 cd        return
7369 cd      endif
7370 cd      write (iout,*)
7371 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7372 cd     &   ' and',k,l
7373       itk=itortyp(itype(k))
7374       itl=itortyp(itype(l))
7375       itj=itortyp(itype(j))
7376       eello5_1=0.0d0
7377       eello5_2=0.0d0
7378       eello5_3=0.0d0
7379       eello5_4=0.0d0
7380 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7381 cd     &   eel5_3_num,eel5_4_num)
7382       do iii=1,2
7383         do kkk=1,5
7384           do lll=1,3
7385             derx(lll,kkk,iii)=0.0d0
7386           enddo
7387         enddo
7388       enddo
7389 cd      eij=facont_hb(jj,i)
7390 cd      ekl=facont_hb(kk,k)
7391 cd      ekont=eij*ekl
7392 cd      write (iout,*)'Contacts have occurred for peptide groups',
7393 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7394 cd      goto 1111
7395 C Contribution from the graph I.
7396 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7397 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7398       call transpose2(EUg(1,1,k),auxmat(1,1))
7399       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7400       vv(1)=pizda(1,1)-pizda(2,2)
7401       vv(2)=pizda(1,2)+pizda(2,1)
7402       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7403      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7404 C Explicit gradient in virtual-dihedral angles.
7405       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7406      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7407      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7408       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7409       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7410       vv(1)=pizda(1,1)-pizda(2,2)
7411       vv(2)=pizda(1,2)+pizda(2,1)
7412       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7413      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7414      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7415       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7416       vv(1)=pizda(1,1)-pizda(2,2)
7417       vv(2)=pizda(1,2)+pizda(2,1)
7418       if (l.eq.j+1) then
7419         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7420      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7421      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7422       else
7423         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7424      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7425      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7426       endif
7427 C Cartesian gradient
7428       do iii=1,2
7429         do kkk=1,5
7430           do lll=1,3
7431             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7432      &        pizda(1,1))
7433             vv(1)=pizda(1,1)-pizda(2,2)
7434             vv(2)=pizda(1,2)+pizda(2,1)
7435             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7436      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7437      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7438           enddo
7439         enddo
7440       enddo
7441 c      goto 1112
7442 c1111  continue
7443 C Contribution from graph II
7444       call transpose2(EE(1,1,itk),auxmat(1,1))
7445       call matmat2(auxmat(1,1),AEA(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       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7449      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7450 C Explicit gradient in virtual-dihedral angles.
7451       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7452      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7453       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7454       vv(1)=pizda(1,1)+pizda(2,2)
7455       vv(2)=pizda(2,1)-pizda(1,2)
7456       if (l.eq.j+1) then
7457         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7458      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7459      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7460       else
7461         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7462      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7463      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7464       endif
7465 C Cartesian gradient
7466       do iii=1,2
7467         do kkk=1,5
7468           do lll=1,3
7469             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7470      &        pizda(1,1))
7471             vv(1)=pizda(1,1)+pizda(2,2)
7472             vv(2)=pizda(2,1)-pizda(1,2)
7473             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7474      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7475      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7476           enddo
7477         enddo
7478       enddo
7479 cd      goto 1112
7480 cd1111  continue
7481       if (l.eq.j+1) then
7482 cd        goto 1110
7483 C Parallel orientation
7484 C Contribution from graph III
7485         call transpose2(EUg(1,1,l),auxmat(1,1))
7486         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7487         vv(1)=pizda(1,1)-pizda(2,2)
7488         vv(2)=pizda(1,2)+pizda(2,1)
7489         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7490      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7491 C Explicit gradient in virtual-dihedral angles.
7492         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7493      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7494      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7495         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7496         vv(1)=pizda(1,1)-pizda(2,2)
7497         vv(2)=pizda(1,2)+pizda(2,1)
7498         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7499      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7500      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7501         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7502         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7503         vv(1)=pizda(1,1)-pizda(2,2)
7504         vv(2)=pizda(1,2)+pizda(2,1)
7505         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7506      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7507      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7508 C Cartesian gradient
7509         do iii=1,2
7510           do kkk=1,5
7511             do lll=1,3
7512               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7513      &          pizda(1,1))
7514               vv(1)=pizda(1,1)-pizda(2,2)
7515               vv(2)=pizda(1,2)+pizda(2,1)
7516               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7517      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7518      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7519             enddo
7520           enddo
7521         enddo
7522 cd        goto 1112
7523 C Contribution from graph IV
7524 cd1110    continue
7525         call transpose2(EE(1,1,itl),auxmat(1,1))
7526         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7530      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7531 C Explicit gradient in virtual-dihedral angles.
7532         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7533      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7534         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7535         vv(1)=pizda(1,1)+pizda(2,2)
7536         vv(2)=pizda(2,1)-pizda(1,2)
7537         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7538      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7539      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7540 C Cartesian gradient
7541         do iii=1,2
7542           do kkk=1,5
7543             do lll=1,3
7544               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7545      &          pizda(1,1))
7546               vv(1)=pizda(1,1)+pizda(2,2)
7547               vv(2)=pizda(2,1)-pizda(1,2)
7548               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7549      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7550      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7551             enddo
7552           enddo
7553         enddo
7554       else
7555 C Antiparallel orientation
7556 C Contribution from graph III
7557 c        goto 1110
7558         call transpose2(EUg(1,1,j),auxmat(1,1))
7559         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7560         vv(1)=pizda(1,1)-pizda(2,2)
7561         vv(2)=pizda(1,2)+pizda(2,1)
7562         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7563      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7564 C Explicit gradient in virtual-dihedral angles.
7565         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7566      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7567      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7568         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7569         vv(1)=pizda(1,1)-pizda(2,2)
7570         vv(2)=pizda(1,2)+pizda(2,1)
7571         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7572      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7573      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7574         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7575         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7576         vv(1)=pizda(1,1)-pizda(2,2)
7577         vv(2)=pizda(1,2)+pizda(2,1)
7578         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7579      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7580      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7581 C Cartesian gradient
7582         do iii=1,2
7583           do kkk=1,5
7584             do lll=1,3
7585               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7586      &          pizda(1,1))
7587               vv(1)=pizda(1,1)-pizda(2,2)
7588               vv(2)=pizda(1,2)+pizda(2,1)
7589               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7590      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7591      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7592             enddo
7593           enddo
7594         enddo
7595 cd        goto 1112
7596 C Contribution from graph IV
7597 1110    continue
7598         call transpose2(EE(1,1,itj),auxmat(1,1))
7599         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7603      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7604 C Explicit gradient in virtual-dihedral angles.
7605         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7606      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7607         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7608         vv(1)=pizda(1,1)+pizda(2,2)
7609         vv(2)=pizda(2,1)-pizda(1,2)
7610         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7611      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7612      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7613 C Cartesian gradient
7614         do iii=1,2
7615           do kkk=1,5
7616             do lll=1,3
7617               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7618      &          pizda(1,1))
7619               vv(1)=pizda(1,1)+pizda(2,2)
7620               vv(2)=pizda(2,1)-pizda(1,2)
7621               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7622      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7623      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7624             enddo
7625           enddo
7626         enddo
7627       endif
7628 1112  continue
7629       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7630 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7631 cd        write (2,*) 'ijkl',i,j,k,l
7632 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7633 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7634 cd      endif
7635 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7636 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7637 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7638 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7639       if (j.lt.nres-1) then
7640         j1=j+1
7641         j2=j-1
7642       else
7643         j1=j-1
7644         j2=j-2
7645       endif
7646       if (l.lt.nres-1) then
7647         l1=l+1
7648         l2=l-1
7649       else
7650         l1=l-1
7651         l2=l-2
7652       endif
7653 cd      eij=1.0d0
7654 cd      ekl=1.0d0
7655 cd      ekont=1.0d0
7656 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7657 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7658 C        summed up outside the subrouine as for the other subroutines
7659 C        handling long-range interactions. The old code is commented out
7660 C        with "cgrad" to keep track of changes.
7661       do ll=1,3
7662 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7663 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7664         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7665         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7666 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7667 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7668 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7669 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7670 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7671 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7672 c     &   gradcorr5ij,
7673 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7674 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7675 cgrad        ghalf=0.5d0*ggg1(ll)
7676 cd        ghalf=0.0d0
7677         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7678         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7679         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7680         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7681         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7682         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7683 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7684 cgrad        ghalf=0.5d0*ggg2(ll)
7685 cd        ghalf=0.0d0
7686         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7687         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7688         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7689         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7690         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7691         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7692       enddo
7693 cd      goto 1112
7694 cgrad      do m=i+1,j-1
7695 cgrad        do ll=1,3
7696 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7697 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7698 cgrad        enddo
7699 cgrad      enddo
7700 cgrad      do m=k+1,l-1
7701 cgrad        do ll=1,3
7702 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7703 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7704 cgrad        enddo
7705 cgrad      enddo
7706 c1112  continue
7707 cgrad      do m=i+2,j2
7708 cgrad        do ll=1,3
7709 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7710 cgrad        enddo
7711 cgrad      enddo
7712 cgrad      do m=k+2,l2
7713 cgrad        do ll=1,3
7714 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7715 cgrad        enddo
7716 cgrad      enddo
7717 cd      do iii=1,nres-3
7718 cd        write (2,*) iii,g_corr5_loc(iii)
7719 cd      enddo
7720       eello5=ekont*eel5
7721 cd      write (2,*) 'ekont',ekont
7722 cd      write (iout,*) 'eello5',ekont*eel5
7723       return
7724       end
7725 c--------------------------------------------------------------------------
7726       double precision function eello6(i,j,k,l,jj,kk)
7727       implicit real*8 (a-h,o-z)
7728       include 'DIMENSIONS'
7729       include 'COMMON.IOUNITS'
7730       include 'COMMON.CHAIN'
7731       include 'COMMON.DERIV'
7732       include 'COMMON.INTERACT'
7733       include 'COMMON.CONTACTS'
7734       include 'COMMON.TORSION'
7735       include 'COMMON.VAR'
7736       include 'COMMON.GEO'
7737       include 'COMMON.FFIELD'
7738       double precision ggg1(3),ggg2(3)
7739 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7740 cd        eello6=0.0d0
7741 cd        return
7742 cd      endif
7743 cd      write (iout,*)
7744 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7745 cd     &   ' and',k,l
7746       eello6_1=0.0d0
7747       eello6_2=0.0d0
7748       eello6_3=0.0d0
7749       eello6_4=0.0d0
7750       eello6_5=0.0d0
7751       eello6_6=0.0d0
7752 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7753 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7754       do iii=1,2
7755         do kkk=1,5
7756           do lll=1,3
7757             derx(lll,kkk,iii)=0.0d0
7758           enddo
7759         enddo
7760       enddo
7761 cd      eij=facont_hb(jj,i)
7762 cd      ekl=facont_hb(kk,k)
7763 cd      ekont=eij*ekl
7764 cd      eij=1.0d0
7765 cd      ekl=1.0d0
7766 cd      ekont=1.0d0
7767       if (l.eq.j+1) then
7768         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7769         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7770         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7771         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7772         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7773         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7774       else
7775         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7776         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7777         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7778         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7779         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7780           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7781         else
7782           eello6_5=0.0d0
7783         endif
7784         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7785       endif
7786 C If turn contributions are considered, they will be handled separately.
7787       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7788 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7789 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7790 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7791 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7792 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7793 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7794 cd      goto 1112
7795       if (j.lt.nres-1) then
7796         j1=j+1
7797         j2=j-1
7798       else
7799         j1=j-1
7800         j2=j-2
7801       endif
7802       if (l.lt.nres-1) then
7803         l1=l+1
7804         l2=l-1
7805       else
7806         l1=l-1
7807         l2=l-2
7808       endif
7809       do ll=1,3
7810 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7811 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7812 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7813 cgrad        ghalf=0.5d0*ggg1(ll)
7814 cd        ghalf=0.0d0
7815         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7816         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7817         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7818         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7819         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7820         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7821         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7822         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7823 cgrad        ghalf=0.5d0*ggg2(ll)
7824 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7825 cd        ghalf=0.0d0
7826         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7827         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7828         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7829         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7830         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7831         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7832       enddo
7833 cd      goto 1112
7834 cgrad      do m=i+1,j-1
7835 cgrad        do ll=1,3
7836 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7837 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7838 cgrad        enddo
7839 cgrad      enddo
7840 cgrad      do m=k+1,l-1
7841 cgrad        do ll=1,3
7842 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7843 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7844 cgrad        enddo
7845 cgrad      enddo
7846 cgrad1112  continue
7847 cgrad      do m=i+2,j2
7848 cgrad        do ll=1,3
7849 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7850 cgrad        enddo
7851 cgrad      enddo
7852 cgrad      do m=k+2,l2
7853 cgrad        do ll=1,3
7854 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7855 cgrad        enddo
7856 cgrad      enddo
7857 cd      do iii=1,nres-3
7858 cd        write (2,*) iii,g_corr6_loc(iii)
7859 cd      enddo
7860       eello6=ekont*eel6
7861 cd      write (2,*) 'ekont',ekont
7862 cd      write (iout,*) 'eello6',ekont*eel6
7863       return
7864       end
7865 c--------------------------------------------------------------------------
7866       double precision function eello6_graph1(i,j,k,l,imat,swap)
7867       implicit real*8 (a-h,o-z)
7868       include 'DIMENSIONS'
7869       include 'COMMON.IOUNITS'
7870       include 'COMMON.CHAIN'
7871       include 'COMMON.DERIV'
7872       include 'COMMON.INTERACT'
7873       include 'COMMON.CONTACTS'
7874       include 'COMMON.TORSION'
7875       include 'COMMON.VAR'
7876       include 'COMMON.GEO'
7877       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7878       logical swap
7879       logical lprn
7880       common /kutas/ lprn
7881 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7882 C                                                                              C
7883 C      Parallel       Antiparallel                                             C
7884 C                                                                              C
7885 C          o             o                                                     C
7886 C         /l\           /j\                                                    C
7887 C        /   \         /   \                                                   C
7888 C       /| o |         | o |\                                                  C
7889 C     \ j|/k\|  /   \  |/k\|l /                                                C
7890 C      \ /   \ /     \ /   \ /                                                 C
7891 C       o     o       o     o                                                  C
7892 C       i             i                                                        C
7893 C                                                                              C
7894 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7895       itk=itortyp(itype(k))
7896       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7897       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7898       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7899       call transpose2(EUgC(1,1,k),auxmat(1,1))
7900       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7901       vv1(1)=pizda1(1,1)-pizda1(2,2)
7902       vv1(2)=pizda1(1,2)+pizda1(2,1)
7903       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7904       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7905       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7906       s5=scalar2(vv(1),Dtobr2(1,i))
7907 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7908       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7909       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7910      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7911      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7912      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7913      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7914      & +scalar2(vv(1),Dtobr2der(1,i)))
7915       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7916       vv1(1)=pizda1(1,1)-pizda1(2,2)
7917       vv1(2)=pizda1(1,2)+pizda1(2,1)
7918       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7919       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7920       if (l.eq.j+1) then
7921         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7922      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7923      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7924      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7925      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7926       else
7927         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7928      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7929      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7930      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7931      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7932       endif
7933       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7934       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7935       vv1(1)=pizda1(1,1)-pizda1(2,2)
7936       vv1(2)=pizda1(1,2)+pizda1(2,1)
7937       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7938      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7939      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7940      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7941       do iii=1,2
7942         if (swap) then
7943           ind=3-iii
7944         else
7945           ind=iii
7946         endif
7947         do kkk=1,5
7948           do lll=1,3
7949             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7950             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7951             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7952             call transpose2(EUgC(1,1,k),auxmat(1,1))
7953             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7954      &        pizda1(1,1))
7955             vv1(1)=pizda1(1,1)-pizda1(2,2)
7956             vv1(2)=pizda1(1,2)+pizda1(2,1)
7957             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7958             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7959      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7960             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7961      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7962             s5=scalar2(vv(1),Dtobr2(1,i))
7963             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7964           enddo
7965         enddo
7966       enddo
7967       return
7968       end
7969 c----------------------------------------------------------------------------
7970       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7971       implicit real*8 (a-h,o-z)
7972       include 'DIMENSIONS'
7973       include 'COMMON.IOUNITS'
7974       include 'COMMON.CHAIN'
7975       include 'COMMON.DERIV'
7976       include 'COMMON.INTERACT'
7977       include 'COMMON.CONTACTS'
7978       include 'COMMON.TORSION'
7979       include 'COMMON.VAR'
7980       include 'COMMON.GEO'
7981       logical swap
7982       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7983      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7984       logical lprn
7985       common /kutas/ lprn
7986 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7987 C                                                                              C
7988 C      Parallel       Antiparallel                                             C
7989 C                                                                              C
7990 C          o             o                                                     C
7991 C     \   /l\           /j\   /                                                C
7992 C      \ /   \         /   \ /                                                 C
7993 C       o| o |         | o |o                                                  C
7994 C     \ j|/k\|      \  |/k\|l                                                  C
7995 C      \ /   \       \ /   \                                                   C
7996 C       o             o                                                        C
7997 C       i             i                                                        C
7998 C                                                                              C
7999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8000 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8001 C AL 7/4/01 s1 would occur in the sixth-order moment,
8002 C           but not in a cluster cumulant
8003 #ifdef MOMENT
8004       s1=dip(1,jj,i)*dip(1,kk,k)
8005 #endif
8006       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8007       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8008       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8009       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8010       call transpose2(EUg(1,1,k),auxmat(1,1))
8011       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8012       vv(1)=pizda(1,1)-pizda(2,2)
8013       vv(2)=pizda(1,2)+pizda(2,1)
8014       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8015 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8016 #ifdef MOMENT
8017       eello6_graph2=-(s1+s2+s3+s4)
8018 #else
8019       eello6_graph2=-(s2+s3+s4)
8020 #endif
8021 c      eello6_graph2=-s3
8022 C Derivatives in gamma(i-1)
8023       if (i.gt.1) then
8024 #ifdef MOMENT
8025         s1=dipderg(1,jj,i)*dip(1,kk,k)
8026 #endif
8027         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8028         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8029         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8030         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8031 #ifdef MOMENT
8032         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8033 #else
8034         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8035 #endif
8036 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8037       endif
8038 C Derivatives in gamma(k-1)
8039 #ifdef MOMENT
8040       s1=dip(1,jj,i)*dipderg(1,kk,k)
8041 #endif
8042       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8043       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8044       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8045       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8046       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8047       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8048       vv(1)=pizda(1,1)-pizda(2,2)
8049       vv(2)=pizda(1,2)+pizda(2,1)
8050       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8051 #ifdef MOMENT
8052       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8053 #else
8054       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8055 #endif
8056 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8057 C Derivatives in gamma(j-1) or gamma(l-1)
8058       if (j.gt.1) then
8059 #ifdef MOMENT
8060         s1=dipderg(3,jj,i)*dip(1,kk,k)
8061 #endif
8062         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8063         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8064         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8065         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8066         vv(1)=pizda(1,1)-pizda(2,2)
8067         vv(2)=pizda(1,2)+pizda(2,1)
8068         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8069 #ifdef MOMENT
8070         if (swap) then
8071           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8072         else
8073           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8074         endif
8075 #endif
8076         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8077 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8078       endif
8079 C Derivatives in gamma(l-1) or gamma(j-1)
8080       if (l.gt.1) then
8081 #ifdef MOMENT
8082         s1=dip(1,jj,i)*dipderg(3,kk,k)
8083 #endif
8084         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8085         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8086         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8087         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8088         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8089         vv(1)=pizda(1,1)-pizda(2,2)
8090         vv(2)=pizda(1,2)+pizda(2,1)
8091         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8092 #ifdef MOMENT
8093         if (swap) then
8094           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8095         else
8096           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8097         endif
8098 #endif
8099         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8100 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8101       endif
8102 C Cartesian derivatives.
8103       if (lprn) then
8104         write (2,*) 'In eello6_graph2'
8105         do iii=1,2
8106           write (2,*) 'iii=',iii
8107           do kkk=1,5
8108             write (2,*) 'kkk=',kkk
8109             do jjj=1,2
8110               write (2,'(3(2f10.5),5x)')
8111      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8112             enddo
8113           enddo
8114         enddo
8115       endif
8116       do iii=1,2
8117         do kkk=1,5
8118           do lll=1,3
8119 #ifdef MOMENT
8120             if (iii.eq.1) then
8121               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8122             else
8123               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8124             endif
8125 #endif
8126             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8127      &        auxvec(1))
8128             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8129             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8130      &        auxvec(1))
8131             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8132             call transpose2(EUg(1,1,k),auxmat(1,1))
8133             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8134      &        pizda(1,1))
8135             vv(1)=pizda(1,1)-pizda(2,2)
8136             vv(2)=pizda(1,2)+pizda(2,1)
8137             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8138 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8139 #ifdef MOMENT
8140             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8141 #else
8142             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8143 #endif
8144             if (swap) then
8145               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8146             else
8147               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8148             endif
8149           enddo
8150         enddo
8151       enddo
8152       return
8153       end
8154 c----------------------------------------------------------------------------
8155       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8156       implicit real*8 (a-h,o-z)
8157       include 'DIMENSIONS'
8158       include 'COMMON.IOUNITS'
8159       include 'COMMON.CHAIN'
8160       include 'COMMON.DERIV'
8161       include 'COMMON.INTERACT'
8162       include 'COMMON.CONTACTS'
8163       include 'COMMON.TORSION'
8164       include 'COMMON.VAR'
8165       include 'COMMON.GEO'
8166       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8167       logical swap
8168 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8169 C                                                                              C
8170 C      Parallel       Antiparallel                                             C
8171 C                                                                              C
8172 C          o             o                                                     C
8173 C         /l\   /   \   /j\                                                    C
8174 C        /   \ /     \ /   \                                                   C
8175 C       /| o |o       o| o |\                                                  C
8176 C       j|/k\|  /      |/k\|l /                                                C
8177 C        /   \ /       /   \ /                                                 C
8178 C       /     o       /     o                                                  C
8179 C       i             i                                                        C
8180 C                                                                              C
8181 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8182 C
8183 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8184 C           energy moment and not to the cluster cumulant.
8185       iti=itortyp(itype(i))
8186       if (j.lt.nres-1) then
8187         itj1=itortyp(itype(j+1))
8188       else
8189         itj1=ntortyp+1
8190       endif
8191       itk=itortyp(itype(k))
8192       itk1=itortyp(itype(k+1))
8193       if (l.lt.nres-1) then
8194         itl1=itortyp(itype(l+1))
8195       else
8196         itl1=ntortyp+1
8197       endif
8198 #ifdef MOMENT
8199       s1=dip(4,jj,i)*dip(4,kk,k)
8200 #endif
8201       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8202       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8203       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8204       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8205       call transpose2(EE(1,1,itk),auxmat(1,1))
8206       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8207       vv(1)=pizda(1,1)+pizda(2,2)
8208       vv(2)=pizda(2,1)-pizda(1,2)
8209       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8210 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8211 cd     & "sum",-(s2+s3+s4)
8212 #ifdef MOMENT
8213       eello6_graph3=-(s1+s2+s3+s4)
8214 #else
8215       eello6_graph3=-(s2+s3+s4)
8216 #endif
8217 c      eello6_graph3=-s4
8218 C Derivatives in gamma(k-1)
8219       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8220       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8221       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8222       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8223 C Derivatives in gamma(l-1)
8224       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8225       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8226       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8227       vv(1)=pizda(1,1)+pizda(2,2)
8228       vv(2)=pizda(2,1)-pizda(1,2)
8229       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8230       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8231 C Cartesian derivatives.
8232       do iii=1,2
8233         do kkk=1,5
8234           do lll=1,3
8235 #ifdef MOMENT
8236             if (iii.eq.1) then
8237               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8238             else
8239               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8240             endif
8241 #endif
8242             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8243      &        auxvec(1))
8244             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8245             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8246      &        auxvec(1))
8247             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8248             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8249      &        pizda(1,1))
8250             vv(1)=pizda(1,1)+pizda(2,2)
8251             vv(2)=pizda(2,1)-pizda(1,2)
8252             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8253 #ifdef MOMENT
8254             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8255 #else
8256             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8257 #endif
8258             if (swap) then
8259               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8260             else
8261               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8262             endif
8263 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8264           enddo
8265         enddo
8266       enddo
8267       return
8268       end
8269 c----------------------------------------------------------------------------
8270       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8271       implicit real*8 (a-h,o-z)
8272       include 'DIMENSIONS'
8273       include 'COMMON.IOUNITS'
8274       include 'COMMON.CHAIN'
8275       include 'COMMON.DERIV'
8276       include 'COMMON.INTERACT'
8277       include 'COMMON.CONTACTS'
8278       include 'COMMON.TORSION'
8279       include 'COMMON.VAR'
8280       include 'COMMON.GEO'
8281       include 'COMMON.FFIELD'
8282       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8283      & auxvec1(2),auxmat1(2,2)
8284       logical swap
8285 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8286 C                                                                              C
8287 C      Parallel       Antiparallel                                             C
8288 C                                                                              C
8289 C          o             o                                                     C
8290 C         /l\   /   \   /j\                                                    C
8291 C        /   \ /     \ /   \                                                   C
8292 C       /| o |o       o| o |\                                                  C
8293 C     \ j|/k\|      \  |/k\|l                                                  C
8294 C      \ /   \       \ /   \                                                   C
8295 C       o     \       o     \                                                  C
8296 C       i             i                                                        C
8297 C                                                                              C
8298 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8299 C
8300 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8301 C           energy moment and not to the cluster cumulant.
8302 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8303       iti=itortyp(itype(i))
8304       itj=itortyp(itype(j))
8305       if (j.lt.nres-1) then
8306         itj1=itortyp(itype(j+1))
8307       else
8308         itj1=ntortyp+1
8309       endif
8310       itk=itortyp(itype(k))
8311       if (k.lt.nres-1) then
8312         itk1=itortyp(itype(k+1))
8313       else
8314         itk1=ntortyp+1
8315       endif
8316       itl=itortyp(itype(l))
8317       if (l.lt.nres-1) then
8318         itl1=itortyp(itype(l+1))
8319       else
8320         itl1=ntortyp+1
8321       endif
8322 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8323 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8324 cd     & ' itl',itl,' itl1',itl1
8325 #ifdef MOMENT
8326       if (imat.eq.1) then
8327         s1=dip(3,jj,i)*dip(3,kk,k)
8328       else
8329         s1=dip(2,jj,j)*dip(2,kk,l)
8330       endif
8331 #endif
8332       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8333       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8334       if (j.eq.l+1) then
8335         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8336         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8337       else
8338         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8339         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8340       endif
8341       call transpose2(EUg(1,1,k),auxmat(1,1))
8342       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8343       vv(1)=pizda(1,1)-pizda(2,2)
8344       vv(2)=pizda(2,1)+pizda(1,2)
8345       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8346 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8347 #ifdef MOMENT
8348       eello6_graph4=-(s1+s2+s3+s4)
8349 #else
8350       eello6_graph4=-(s2+s3+s4)
8351 #endif
8352 C Derivatives in gamma(i-1)
8353       if (i.gt.1) then
8354 #ifdef MOMENT
8355         if (imat.eq.1) then
8356           s1=dipderg(2,jj,i)*dip(3,kk,k)
8357         else
8358           s1=dipderg(4,jj,j)*dip(2,kk,l)
8359         endif
8360 #endif
8361         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8362         if (j.eq.l+1) then
8363           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8364           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8365         else
8366           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8367           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8368         endif
8369         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8370         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8371 cd          write (2,*) 'turn6 derivatives'
8372 #ifdef MOMENT
8373           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8374 #else
8375           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8376 #endif
8377         else
8378 #ifdef MOMENT
8379           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8380 #else
8381           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8382 #endif
8383         endif
8384       endif
8385 C Derivatives in gamma(k-1)
8386 #ifdef MOMENT
8387       if (imat.eq.1) then
8388         s1=dip(3,jj,i)*dipderg(2,kk,k)
8389       else
8390         s1=dip(2,jj,j)*dipderg(4,kk,l)
8391       endif
8392 #endif
8393       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8394       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8395       if (j.eq.l+1) then
8396         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8397         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8398       else
8399         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8400         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8401       endif
8402       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8403       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8404       vv(1)=pizda(1,1)-pizda(2,2)
8405       vv(2)=pizda(2,1)+pizda(1,2)
8406       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8407       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8408 #ifdef MOMENT
8409         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8410 #else
8411         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8412 #endif
8413       else
8414 #ifdef MOMENT
8415         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8416 #else
8417         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8418 #endif
8419       endif
8420 C Derivatives in gamma(j-1) or gamma(l-1)
8421       if (l.eq.j+1 .and. l.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         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8429       else if (j.gt.1) then
8430         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8431         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8432         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8433         vv(1)=pizda(1,1)-pizda(2,2)
8434         vv(2)=pizda(2,1)+pizda(1,2)
8435         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8436         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8437           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8438         else
8439           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8440         endif
8441       endif
8442 C Cartesian derivatives.
8443       do iii=1,2
8444         do kkk=1,5
8445           do lll=1,3
8446 #ifdef MOMENT
8447             if (iii.eq.1) then
8448               if (imat.eq.1) then
8449                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8450               else
8451                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8452               endif
8453             else
8454               if (imat.eq.1) then
8455                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8456               else
8457                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8458               endif
8459             endif
8460 #endif
8461             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8462      &        auxvec(1))
8463             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8464             if (j.eq.l+1) then
8465               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8466      &          b1(1,itj1),auxvec(1))
8467               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8468             else
8469               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8470      &          b1(1,itl1),auxvec(1))
8471               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8472             endif
8473             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8474      &        pizda(1,1))
8475             vv(1)=pizda(1,1)-pizda(2,2)
8476             vv(2)=pizda(2,1)+pizda(1,2)
8477             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8478             if (swap) then
8479               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8480 #ifdef MOMENT
8481                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8482      &             -(s1+s2+s4)
8483 #else
8484                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8485      &             -(s2+s4)
8486 #endif
8487                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8488               else
8489 #ifdef MOMENT
8490                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8491 #else
8492                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8493 #endif
8494                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8495               endif
8496             else
8497 #ifdef MOMENT
8498               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8499 #else
8500               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8501 #endif
8502               if (l.eq.j+1) then
8503                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8504               else
8505                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8506               endif
8507             endif
8508           enddo
8509         enddo
8510       enddo
8511       return
8512       end
8513 c----------------------------------------------------------------------------
8514       double precision function eello_turn6(i,jj,kk)
8515       implicit real*8 (a-h,o-z)
8516       include 'DIMENSIONS'
8517       include 'COMMON.IOUNITS'
8518       include 'COMMON.CHAIN'
8519       include 'COMMON.DERIV'
8520       include 'COMMON.INTERACT'
8521       include 'COMMON.CONTACTS'
8522       include 'COMMON.TORSION'
8523       include 'COMMON.VAR'
8524       include 'COMMON.GEO'
8525       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8526      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8527      &  ggg1(3),ggg2(3)
8528       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8529      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8530 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8531 C           the respective energy moment and not to the cluster cumulant.
8532       s1=0.0d0
8533       s8=0.0d0
8534       s13=0.0d0
8535 c
8536       eello_turn6=0.0d0
8537       j=i+4
8538       k=i+1
8539       l=i+3
8540       iti=itortyp(itype(i))
8541       itk=itortyp(itype(k))
8542       itk1=itortyp(itype(k+1))
8543       itl=itortyp(itype(l))
8544       itj=itortyp(itype(j))
8545 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8546 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8547 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8548 cd        eello6=0.0d0
8549 cd        return
8550 cd      endif
8551 cd      write (iout,*)
8552 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8553 cd     &   ' and',k,l
8554 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8555       do iii=1,2
8556         do kkk=1,5
8557           do lll=1,3
8558             derx_turn(lll,kkk,iii)=0.0d0
8559           enddo
8560         enddo
8561       enddo
8562 cd      eij=1.0d0
8563 cd      ekl=1.0d0
8564 cd      ekont=1.0d0
8565       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8566 cd      eello6_5=0.0d0
8567 cd      write (2,*) 'eello6_5',eello6_5
8568 #ifdef MOMENT
8569       call transpose2(AEA(1,1,1),auxmat(1,1))
8570       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8571       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8572       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8573 #endif
8574       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8575       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8576       s2 = scalar2(b1(1,itk),vtemp1(1))
8577 #ifdef MOMENT
8578       call transpose2(AEA(1,1,2),atemp(1,1))
8579       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8580       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8581       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8582 #endif
8583       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8584       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8585       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8586 #ifdef MOMENT
8587       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8588       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8589       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8590       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8591       ss13 = scalar2(b1(1,itk),vtemp4(1))
8592       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8593 #endif
8594 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8595 c      s1=0.0d0
8596 c      s2=0.0d0
8597 c      s8=0.0d0
8598 c      s12=0.0d0
8599 c      s13=0.0d0
8600       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8601 C Derivatives in gamma(i+2)
8602       s1d =0.0d0
8603       s8d =0.0d0
8604 #ifdef MOMENT
8605       call transpose2(AEA(1,1,1),auxmatd(1,1))
8606       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8607       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8608       call transpose2(AEAderg(1,1,2),atempd(1,1))
8609       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8610       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8611 #endif
8612       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8613       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8614       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8615 c      s1d=0.0d0
8616 c      s2d=0.0d0
8617 c      s8d=0.0d0
8618 c      s12d=0.0d0
8619 c      s13d=0.0d0
8620       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8621 C Derivatives in gamma(i+3)
8622 #ifdef MOMENT
8623       call transpose2(AEA(1,1,1),auxmatd(1,1))
8624       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8625       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8626       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8627 #endif
8628       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8629       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8630       s2d = scalar2(b1(1,itk),vtemp1d(1))
8631 #ifdef MOMENT
8632       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8633       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8634 #endif
8635       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8636 #ifdef MOMENT
8637       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8638       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8639       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8640 #endif
8641 c      s1d=0.0d0
8642 c      s2d=0.0d0
8643 c      s8d=0.0d0
8644 c      s12d=0.0d0
8645 c      s13d=0.0d0
8646 #ifdef MOMENT
8647       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8648      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8649 #else
8650       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8651      &               -0.5d0*ekont*(s2d+s12d)
8652 #endif
8653 C Derivatives in gamma(i+4)
8654       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8655       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8656       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8657 #ifdef MOMENT
8658       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8659       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8660       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8661 #endif
8662 c      s1d=0.0d0
8663 c      s2d=0.0d0
8664 c      s8d=0.0d0
8665 C      s12d=0.0d0
8666 c      s13d=0.0d0
8667 #ifdef MOMENT
8668       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8669 #else
8670       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8671 #endif
8672 C Derivatives in gamma(i+5)
8673 #ifdef MOMENT
8674       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8675       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8676       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8677 #endif
8678       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8679       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8680       s2d = scalar2(b1(1,itk),vtemp1d(1))
8681 #ifdef MOMENT
8682       call transpose2(AEA(1,1,2),atempd(1,1))
8683       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8684       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8685 #endif
8686       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8687       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8688 #ifdef MOMENT
8689       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8690       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8691       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8692 #endif
8693 c      s1d=0.0d0
8694 c      s2d=0.0d0
8695 c      s8d=0.0d0
8696 c      s12d=0.0d0
8697 c      s13d=0.0d0
8698 #ifdef MOMENT
8699       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8700      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8701 #else
8702       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8703      &               -0.5d0*ekont*(s2d+s12d)
8704 #endif
8705 C Cartesian derivatives
8706       do iii=1,2
8707         do kkk=1,5
8708           do lll=1,3
8709 #ifdef MOMENT
8710             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8711             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8712             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8713 #endif
8714             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8715             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8716      &          vtemp1d(1))
8717             s2d = scalar2(b1(1,itk),vtemp1d(1))
8718 #ifdef MOMENT
8719             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8720             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8721             s8d = -(atempd(1,1)+atempd(2,2))*
8722      &           scalar2(cc(1,1,itl),vtemp2(1))
8723 #endif
8724             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8725      &           auxmatd(1,1))
8726             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8727             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8728 c      s1d=0.0d0
8729 c      s2d=0.0d0
8730 c      s8d=0.0d0
8731 c      s12d=0.0d0
8732 c      s13d=0.0d0
8733 #ifdef MOMENT
8734             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8735      &        - 0.5d0*(s1d+s2d)
8736 #else
8737             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8738      &        - 0.5d0*s2d
8739 #endif
8740 #ifdef MOMENT
8741             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8742      &        - 0.5d0*(s8d+s12d)
8743 #else
8744             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8745      &        - 0.5d0*s12d
8746 #endif
8747           enddo
8748         enddo
8749       enddo
8750 #ifdef MOMENT
8751       do kkk=1,5
8752         do lll=1,3
8753           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8754      &      achuj_tempd(1,1))
8755           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8756           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8757           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8758           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8759           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8760      &      vtemp4d(1))
8761           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8762           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8763           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8764         enddo
8765       enddo
8766 #endif
8767 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8768 cd     &  16*eel_turn6_num
8769 cd      goto 1112
8770       if (j.lt.nres-1) then
8771         j1=j+1
8772         j2=j-1
8773       else
8774         j1=j-1
8775         j2=j-2
8776       endif
8777       if (l.lt.nres-1) then
8778         l1=l+1
8779         l2=l-1
8780       else
8781         l1=l-1
8782         l2=l-2
8783       endif
8784       do ll=1,3
8785 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8786 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8787 cgrad        ghalf=0.5d0*ggg1(ll)
8788 cd        ghalf=0.0d0
8789         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8790         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8791         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8792      &    +ekont*derx_turn(ll,2,1)
8793         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8794         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8795      &    +ekont*derx_turn(ll,4,1)
8796         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8797         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8798         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8799 cgrad        ghalf=0.5d0*ggg2(ll)
8800 cd        ghalf=0.0d0
8801         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8802      &    +ekont*derx_turn(ll,2,2)
8803         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8804         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8805      &    +ekont*derx_turn(ll,4,2)
8806         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8807         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8808         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8809       enddo
8810 cd      goto 1112
8811 cgrad      do m=i+1,j-1
8812 cgrad        do ll=1,3
8813 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8814 cgrad        enddo
8815 cgrad      enddo
8816 cgrad      do m=k+1,l-1
8817 cgrad        do ll=1,3
8818 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8819 cgrad        enddo
8820 cgrad      enddo
8821 cgrad1112  continue
8822 cgrad      do m=i+2,j2
8823 cgrad        do ll=1,3
8824 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8825 cgrad        enddo
8826 cgrad      enddo
8827 cgrad      do m=k+2,l2
8828 cgrad        do ll=1,3
8829 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8830 cgrad        enddo
8831 cgrad      enddo
8832 cd      do iii=1,nres-3
8833 cd        write (2,*) iii,g_corr6_loc(iii)
8834 cd      enddo
8835       eello_turn6=ekont*eel_turn6
8836 cd      write (2,*) 'ekont',ekont
8837 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8838       return
8839       end
8840
8841 C-----------------------------------------------------------------------------
8842       double precision function scalar(u,v)
8843 !DIR$ INLINEALWAYS scalar
8844 #ifndef OSF
8845 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8846 #endif
8847       implicit none
8848       double precision u(3),v(3)
8849 cd      double precision sc
8850 cd      integer i
8851 cd      sc=0.0d0
8852 cd      do i=1,3
8853 cd        sc=sc+u(i)*v(i)
8854 cd      enddo
8855 cd      scalar=sc
8856
8857       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8858       return
8859       end
8860 crc-------------------------------------------------
8861       SUBROUTINE MATVEC2(A1,V1,V2)
8862 !DIR$ INLINEALWAYS MATVEC2
8863 #ifndef OSF
8864 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8865 #endif
8866       implicit real*8 (a-h,o-z)
8867       include 'DIMENSIONS'
8868       DIMENSION A1(2,2),V1(2),V2(2)
8869 c      DO 1 I=1,2
8870 c        VI=0.0
8871 c        DO 3 K=1,2
8872 c    3     VI=VI+A1(I,K)*V1(K)
8873 c        Vaux(I)=VI
8874 c    1 CONTINUE
8875
8876       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8877       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8878
8879       v2(1)=vaux1
8880       v2(2)=vaux2
8881       END
8882 C---------------------------------------
8883       SUBROUTINE MATMAT2(A1,A2,A3)
8884 #ifndef OSF
8885 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8886 #endif
8887       implicit real*8 (a-h,o-z)
8888       include 'DIMENSIONS'
8889       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8890 c      DIMENSION AI3(2,2)
8891 c        DO  J=1,2
8892 c          A3IJ=0.0
8893 c          DO K=1,2
8894 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8895 c          enddo
8896 c          A3(I,J)=A3IJ
8897 c       enddo
8898 c      enddo
8899
8900       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8901       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8902       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8903       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8904
8905       A3(1,1)=AI3_11
8906       A3(2,1)=AI3_21
8907       A3(1,2)=AI3_12
8908       A3(2,2)=AI3_22
8909       END
8910
8911 c-------------------------------------------------------------------------
8912       double precision function scalar2(u,v)
8913 !DIR$ INLINEALWAYS scalar2
8914       implicit none
8915       double precision u(2),v(2)
8916       double precision sc
8917       integer i
8918       scalar2=u(1)*v(1)+u(2)*v(2)
8919       return
8920       end
8921
8922 C-----------------------------------------------------------------------------
8923
8924       subroutine transpose2(a,at)
8925 !DIR$ INLINEALWAYS transpose2
8926 #ifndef OSF
8927 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8928 #endif
8929       implicit none
8930       double precision a(2,2),at(2,2)
8931       at(1,1)=a(1,1)
8932       at(1,2)=a(2,1)
8933       at(2,1)=a(1,2)
8934       at(2,2)=a(2,2)
8935       return
8936       end
8937 c--------------------------------------------------------------------------
8938       subroutine transpose(n,a,at)
8939       implicit none
8940       integer n,i,j
8941       double precision a(n,n),at(n,n)
8942       do i=1,n
8943         do j=1,n
8944           at(j,i)=a(i,j)
8945         enddo
8946       enddo
8947       return
8948       end
8949 C---------------------------------------------------------------------------
8950       subroutine prodmat3(a1,a2,kk,transp,prod)
8951 !DIR$ INLINEALWAYS prodmat3
8952 #ifndef OSF
8953 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8954 #endif
8955       implicit none
8956       integer i,j
8957       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8958       logical transp
8959 crc      double precision auxmat(2,2),prod_(2,2)
8960
8961       if (transp) then
8962 crc        call transpose2(kk(1,1),auxmat(1,1))
8963 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8964 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8965
8966            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8967      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8968            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8969      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8970            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8971      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8972            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8973      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8974
8975       else
8976 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8977 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8978
8979            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8980      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8981            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8982      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8983            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8984      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8985            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8986      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8987
8988       endif
8989 c      call transpose2(a2(1,1),a2t(1,1))
8990
8991 crc      print *,transp
8992 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8993 crc      print *,((prod(i,j),i=1,2),j=1,2)
8994
8995       return
8996       end
8997