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 #undef 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 #undef 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       include 'COMMON.CONTROL'
5652       logical lprn
5653 C Set lprn=.true. for debugging
5654       lprn=.false.
5655 c     lprn=.true.
5656       etors_d=0.0D0
5657 C      write(iout,*) "a tu??"
5658       do i=iphid_start,iphid_end
5659         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5660      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21
5661      &       .or. itype(i-3).eq.ntyp1) cycle
5662         etors_d_ii=0.0D0
5663         itori=itortyp(itype(i-2))
5664         itori1=itortyp(itype(i-1))
5665         itori2=itortyp(itype(i))
5666         phii=phi(i)
5667         phii1=phi(i+1)
5668         gloci1=0.0D0
5669         gloci2=0.0D0
5670 C Regular cosine and sine terms
5671         do j=1,ntermd_1(itori,itori1,itori2)
5672           v1cij=v1c(1,j,itori,itori1,itori2)
5673           v1sij=v1s(1,j,itori,itori1,itori2)
5674           v2cij=v1c(2,j,itori,itori1,itori2)
5675           v2sij=v1s(2,j,itori,itori1,itori2)
5676           cosphi1=dcos(j*phii)
5677           sinphi1=dsin(j*phii)
5678           cosphi2=dcos(j*phii1)
5679           sinphi2=dsin(j*phii1)
5680           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5681      &     v2cij*cosphi2+v2sij*sinphi2
5682           if (energy_dec) etors_d_ii=etors_d_ii+
5683      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5684           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5685           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5686         enddo
5687         do k=2,ntermd_2(itori,itori1,itori2)
5688           do l=1,k-1
5689             v1cdij = v2c(k,l,itori,itori1,itori2)
5690             v2cdij = v2c(l,k,itori,itori1,itori2)
5691             v1sdij = v2s(k,l,itori,itori1,itori2)
5692             v2sdij = v2s(l,k,itori,itori1,itori2)
5693             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5694             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5695             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5696             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5697             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5698      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5699             if (energy_dec) etors_d_ii=etors_d_ii+
5700      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5701      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5702             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5703      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5704             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5705      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5706           enddo
5707         enddo
5708           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5709      &         'etor_d',i,etors_d_ii
5710         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5711         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5712       enddo
5713       return
5714       end
5715 #endif
5716 c------------------------------------------------------------------------------
5717       subroutine eback_sc_corr(esccor)
5718 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5719 c        conformational states; temporarily implemented as differences
5720 c        between UNRES torsional potentials (dependent on three types of
5721 c        residues) and the torsional potentials dependent on all 20 types
5722 c        of residues computed from AM1  energy surfaces of terminally-blocked
5723 c        amino-acid residues.
5724       implicit real*8 (a-h,o-z)
5725       include 'DIMENSIONS'
5726       include 'COMMON.VAR'
5727       include 'COMMON.GEO'
5728       include 'COMMON.LOCAL'
5729       include 'COMMON.TORSION'
5730       include 'COMMON.SCCOR'
5731       include 'COMMON.INTERACT'
5732       include 'COMMON.DERIV'
5733       include 'COMMON.CHAIN'
5734       include 'COMMON.NAMES'
5735       include 'COMMON.IOUNITS'
5736       include 'COMMON.FFIELD'
5737       include 'COMMON.CONTROL'
5738       logical lprn
5739 C Set lprn=.true. for debugging
5740       lprn=.false.
5741 c      lprn=.true.
5742 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5743       esccor=0.0D0
5744       do i=itau_start,itau_end
5745         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5746         esccor_ii=0.0D0
5747         isccori=isccortyp(itype(i-2))
5748         isccori1=isccortyp(itype(i-1))
5749 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5750         phii=phi(i)
5751         do intertyp=1,3 !intertyp
5752 cc Added 09 May 2012 (Adasko)
5753 cc  Intertyp means interaction type of backbone mainchain correlation:
5754 c   1 = SC...Ca...Ca...Ca
5755 c   2 = Ca...Ca...Ca...SC
5756 c   3 = SC...Ca...Ca...SCi
5757         gloci=0.0D0
5758         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5759      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5760      &      (itype(i-1).eq.ntyp1)))
5761      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5762      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5763      &     .or.(itype(i).eq.ntyp1)))
5764      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5765      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5766      &      (itype(i-3).eq.ntyp1)))) cycle
5767         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5768         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5769      & cycle
5770        do j=1,nterm_sccor(isccori,isccori1)
5771           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5772           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5773           cosphi=dcos(j*tauangle(intertyp,i))
5774           sinphi=dsin(j*tauangle(intertyp,i))
5775           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5776           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5777         enddo
5778 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5779         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5780         if (lprn)
5781      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5782      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5783      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5784      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5785         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5786        enddo !intertyp
5787       enddo
5788
5789       return
5790       end
5791 c----------------------------------------------------------------------------
5792       subroutine multibody(ecorr)
5793 C This subroutine calculates multi-body contributions to energy following
5794 C the idea of Skolnick et al. If side chains I and J make a contact and
5795 C at the same time side chains I+1 and J+1 make a contact, an extra
5796 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5797       implicit real*8 (a-h,o-z)
5798       include 'DIMENSIONS'
5799       include 'COMMON.IOUNITS'
5800       include 'COMMON.DERIV'
5801       include 'COMMON.INTERACT'
5802       include 'COMMON.CONTACTS'
5803       double precision gx(3),gx1(3)
5804       logical lprn
5805
5806 C Set lprn=.true. for debugging
5807       lprn=.false.
5808
5809       if (lprn) then
5810         write (iout,'(a)') 'Contact function values:'
5811         do i=nnt,nct-2
5812           write (iout,'(i2,20(1x,i2,f10.5))')
5813      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5814         enddo
5815       endif
5816       ecorr=0.0D0
5817       do i=nnt,nct
5818         do j=1,3
5819           gradcorr(j,i)=0.0D0
5820           gradxorr(j,i)=0.0D0
5821         enddo
5822       enddo
5823       do i=nnt,nct-2
5824
5825         DO ISHIFT = 3,4
5826
5827         i1=i+ishift
5828         num_conti=num_cont(i)
5829         num_conti1=num_cont(i1)
5830         do jj=1,num_conti
5831           j=jcont(jj,i)
5832           do kk=1,num_conti1
5833             j1=jcont(kk,i1)
5834             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5835 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5836 cd   &                   ' ishift=',ishift
5837 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5838 C The system gains extra energy.
5839               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5840             endif   ! j1==j+-ishift
5841           enddo     ! kk
5842         enddo       ! jj
5843
5844         ENDDO ! ISHIFT
5845
5846       enddo         ! i
5847       return
5848       end
5849 c------------------------------------------------------------------------------
5850       double precision function esccorr(i,j,k,l,jj,kk)
5851       implicit real*8 (a-h,o-z)
5852       include 'DIMENSIONS'
5853       include 'COMMON.IOUNITS'
5854       include 'COMMON.DERIV'
5855       include 'COMMON.INTERACT'
5856       include 'COMMON.CONTACTS'
5857       double precision gx(3),gx1(3)
5858       logical lprn
5859       lprn=.false.
5860       eij=facont(jj,i)
5861       ekl=facont(kk,k)
5862 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5863 C Calculate the multi-body contribution to energy.
5864 C Calculate multi-body contributions to the gradient.
5865 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5866 cd   & k,l,(gacont(m,kk,k),m=1,3)
5867       do m=1,3
5868         gx(m) =ekl*gacont(m,jj,i)
5869         gx1(m)=eij*gacont(m,kk,k)
5870         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5871         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5872         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5873         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5874       enddo
5875       do m=i,j-1
5876         do ll=1,3
5877           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5878         enddo
5879       enddo
5880       do m=k,l-1
5881         do ll=1,3
5882           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5883         enddo
5884       enddo
5885       esccorr=-eij*ekl
5886       return
5887       end
5888 c------------------------------------------------------------------------------
5889       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5890 C This subroutine calculates multi-body contributions to hydrogen-bonding
5891       implicit real*8 (a-h,o-z)
5892       include 'DIMENSIONS'
5893       include 'COMMON.IOUNITS'
5894 #ifdef MPI
5895       include "mpif.h"
5896       parameter (max_cont=maxconts)
5897       parameter (max_dim=26)
5898       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5899       double precision zapas(max_dim,maxconts,max_fg_procs),
5900      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5901       common /przechowalnia/ zapas
5902       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5903      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5904 #endif
5905       include 'COMMON.SETUP'
5906       include 'COMMON.FFIELD'
5907       include 'COMMON.DERIV'
5908       include 'COMMON.INTERACT'
5909       include 'COMMON.CONTACTS'
5910       include 'COMMON.CONTROL'
5911       include 'COMMON.LOCAL'
5912       double precision gx(3),gx1(3),time00
5913       logical lprn,ldone
5914
5915 C Set lprn=.true. for debugging
5916       lprn=.false.
5917 #ifdef MPI
5918       n_corr=0
5919       n_corr1=0
5920       if (nfgtasks.le.1) goto 30
5921       if (lprn) then
5922         write (iout,'(a)') 'Contact function values before RECEIVE:'
5923         do i=nnt,nct-2
5924           write (iout,'(2i3,50(1x,i2,f5.2))')
5925      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5926      &    j=1,num_cont_hb(i))
5927         enddo
5928       endif
5929       call flush(iout)
5930       do i=1,ntask_cont_from
5931         ncont_recv(i)=0
5932       enddo
5933       do i=1,ntask_cont_to
5934         ncont_sent(i)=0
5935       enddo
5936 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5937 c     & ntask_cont_to
5938 C Make the list of contacts to send to send to other procesors
5939 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5940 c      call flush(iout)
5941       do i=iturn3_start,iturn3_end
5942 c        write (iout,*) "make contact list turn3",i," num_cont",
5943 c     &    num_cont_hb(i)
5944         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5945       enddo
5946       do i=iturn4_start,iturn4_end
5947 c        write (iout,*) "make contact list turn4",i," num_cont",
5948 c     &   num_cont_hb(i)
5949         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5950       enddo
5951       do ii=1,nat_sent
5952         i=iat_sent(ii)
5953 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5954 c     &    num_cont_hb(i)
5955         do j=1,num_cont_hb(i)
5956         do k=1,4
5957           jjc=jcont_hb(j,i)
5958           iproc=iint_sent_local(k,jjc,ii)
5959 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5960           if (iproc.gt.0) then
5961             ncont_sent(iproc)=ncont_sent(iproc)+1
5962             nn=ncont_sent(iproc)
5963             zapas(1,nn,iproc)=i
5964             zapas(2,nn,iproc)=jjc
5965             zapas(3,nn,iproc)=facont_hb(j,i)
5966             zapas(4,nn,iproc)=ees0p(j,i)
5967             zapas(5,nn,iproc)=ees0m(j,i)
5968             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5969             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5970             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5971             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5972             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5973             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5974             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5975             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5976             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5977             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5978             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5979             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5980             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5981             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5982             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5983             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5984             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5985             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5986             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5987             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5988             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5989           endif
5990         enddo
5991         enddo
5992       enddo
5993       if (lprn) then
5994       write (iout,*)
5995      &  "Numbers of contacts to be sent to other processors",
5996      &  (ncont_sent(i),i=1,ntask_cont_to)
5997       write (iout,*) "Contacts sent"
5998       do ii=1,ntask_cont_to
5999         nn=ncont_sent(ii)
6000         iproc=itask_cont_to(ii)
6001         write (iout,*) nn," contacts to processor",iproc,
6002      &   " of CONT_TO_COMM group"
6003         do i=1,nn
6004           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6005         enddo
6006       enddo
6007       call flush(iout)
6008       endif
6009       CorrelType=477
6010       CorrelID=fg_rank+1
6011       CorrelType1=478
6012       CorrelID1=nfgtasks+fg_rank+1
6013       ireq=0
6014 C Receive the numbers of needed contacts from other processors
6015       do ii=1,ntask_cont_from
6016         iproc=itask_cont_from(ii)
6017         ireq=ireq+1
6018         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6019      &    FG_COMM,req(ireq),IERR)
6020       enddo
6021 c      write (iout,*) "IRECV ended"
6022 c      call flush(iout)
6023 C Send the number of contacts needed by other processors
6024       do ii=1,ntask_cont_to
6025         iproc=itask_cont_to(ii)
6026         ireq=ireq+1
6027         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6028      &    FG_COMM,req(ireq),IERR)
6029       enddo
6030 c      write (iout,*) "ISEND ended"
6031 c      write (iout,*) "number of requests (nn)",ireq
6032       call flush(iout)
6033       if (ireq.gt.0)
6034      &  call MPI_Waitall(ireq,req,status_array,ierr)
6035 c      write (iout,*)
6036 c     &  "Numbers of contacts to be received from other processors",
6037 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6038 c      call flush(iout)
6039 C Receive contacts
6040       ireq=0
6041       do ii=1,ntask_cont_from
6042         iproc=itask_cont_from(ii)
6043         nn=ncont_recv(ii)
6044 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6045 c     &   " of CONT_TO_COMM group"
6046         call flush(iout)
6047         if (nn.gt.0) then
6048           ireq=ireq+1
6049           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6050      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6051 c          write (iout,*) "ireq,req",ireq,req(ireq)
6052         endif
6053       enddo
6054 C Send the contacts to processors that need them
6055       do ii=1,ntask_cont_to
6056         iproc=itask_cont_to(ii)
6057         nn=ncont_sent(ii)
6058 c        write (iout,*) nn," contacts to processor",iproc,
6059 c     &   " of CONT_TO_COMM group"
6060         if (nn.gt.0) then
6061           ireq=ireq+1
6062           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6063      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6064 c          write (iout,*) "ireq,req",ireq,req(ireq)
6065 c          do i=1,nn
6066 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6067 c          enddo
6068         endif
6069       enddo
6070 c      write (iout,*) "number of requests (contacts)",ireq
6071 c      write (iout,*) "req",(req(i),i=1,4)
6072 c      call flush(iout)
6073       if (ireq.gt.0)
6074      & call MPI_Waitall(ireq,req,status_array,ierr)
6075       do iii=1,ntask_cont_from
6076         iproc=itask_cont_from(iii)
6077         nn=ncont_recv(iii)
6078         if (lprn) then
6079         write (iout,*) "Received",nn," contacts from processor",iproc,
6080      &   " of CONT_FROM_COMM group"
6081         call flush(iout)
6082         do i=1,nn
6083           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6084         enddo
6085         call flush(iout)
6086         endif
6087         do i=1,nn
6088           ii=zapas_recv(1,i,iii)
6089 c Flag the received contacts to prevent double-counting
6090           jj=-zapas_recv(2,i,iii)
6091 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6092 c          call flush(iout)
6093           nnn=num_cont_hb(ii)+1
6094           num_cont_hb(ii)=nnn
6095           jcont_hb(nnn,ii)=jj
6096           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6097           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6098           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6099           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6100           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6101           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6102           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6103           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6104           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6105           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6106           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6107           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6108           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6109           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6110           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6111           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6112           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6113           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6114           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6115           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6116           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6117           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6118           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6119           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6120         enddo
6121       enddo
6122       call flush(iout)
6123       if (lprn) then
6124         write (iout,'(a)') 'Contact function values after receive:'
6125         do i=nnt,nct-2
6126           write (iout,'(2i3,50(1x,i3,f5.2))')
6127      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6128      &    j=1,num_cont_hb(i))
6129         enddo
6130         call flush(iout)
6131       endif
6132    30 continue
6133 #endif
6134       if (lprn) then
6135         write (iout,'(a)') 'Contact function values:'
6136         do i=nnt,nct-2
6137           write (iout,'(2i3,50(1x,i3,f5.2))')
6138      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6139      &    j=1,num_cont_hb(i))
6140         enddo
6141       endif
6142       ecorr=0.0D0
6143 C Remove the loop below after debugging !!!
6144       do i=nnt,nct
6145         do j=1,3
6146           gradcorr(j,i)=0.0D0
6147           gradxorr(j,i)=0.0D0
6148         enddo
6149       enddo
6150 C Calculate the local-electrostatic correlation terms
6151       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6152         i1=i+1
6153         num_conti=num_cont_hb(i)
6154         num_conti1=num_cont_hb(i+1)
6155         do jj=1,num_conti
6156           j=jcont_hb(jj,i)
6157           jp=iabs(j)
6158           do kk=1,num_conti1
6159             j1=jcont_hb(kk,i1)
6160             jp1=iabs(j1)
6161 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6162 c     &         ' jj=',jj,' kk=',kk
6163             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6164      &          .or. j.lt.0 .and. j1.gt.0) .and.
6165      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6166 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6167 C The system gains extra energy.
6168               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6169               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6170      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6171               n_corr=n_corr+1
6172             else if (j1.eq.j) then
6173 C Contacts I-J and I-(J+1) occur simultaneously.
6174 C The system loses extra energy.
6175 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6176             endif
6177           enddo ! kk
6178           do kk=1,num_conti
6179             j1=jcont_hb(kk,i)
6180 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6181 c    &         ' jj=',jj,' kk=',kk
6182             if (j1.eq.j+1) then
6183 C Contacts I-J and (I+1)-J occur simultaneously.
6184 C The system loses extra energy.
6185 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6186             endif ! j1==j+1
6187           enddo ! kk
6188         enddo ! jj
6189       enddo ! i
6190       return
6191       end
6192 c------------------------------------------------------------------------------
6193       subroutine add_hb_contact(ii,jj,itask)
6194       implicit real*8 (a-h,o-z)
6195       include "DIMENSIONS"
6196       include "COMMON.IOUNITS"
6197       integer max_cont
6198       integer max_dim
6199       parameter (max_cont=maxconts)
6200       parameter (max_dim=26)
6201       include "COMMON.CONTACTS"
6202       double precision zapas(max_dim,maxconts,max_fg_procs),
6203      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6204       common /przechowalnia/ zapas
6205       integer i,j,ii,jj,iproc,itask(4),nn
6206 c      write (iout,*) "itask",itask
6207       do i=1,2
6208         iproc=itask(i)
6209         if (iproc.gt.0) then
6210           do j=1,num_cont_hb(ii)
6211             jjc=jcont_hb(j,ii)
6212 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6213             if (jjc.eq.jj) then
6214               ncont_sent(iproc)=ncont_sent(iproc)+1
6215               nn=ncont_sent(iproc)
6216               zapas(1,nn,iproc)=ii
6217               zapas(2,nn,iproc)=jjc
6218               zapas(3,nn,iproc)=facont_hb(j,ii)
6219               zapas(4,nn,iproc)=ees0p(j,ii)
6220               zapas(5,nn,iproc)=ees0m(j,ii)
6221               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6222               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6223               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6224               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6225               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6226               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6227               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6228               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6229               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6230               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6231               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6232               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6233               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6234               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6235               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6236               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6237               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6238               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6239               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6240               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6241               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6242               exit
6243             endif
6244           enddo
6245         endif
6246       enddo
6247       return
6248       end
6249 c------------------------------------------------------------------------------
6250       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6251      &  n_corr1)
6252 C This subroutine calculates multi-body contributions to hydrogen-bonding
6253       implicit real*8 (a-h,o-z)
6254       include 'DIMENSIONS'
6255       include 'COMMON.IOUNITS'
6256 #ifdef MPI
6257       include "mpif.h"
6258       parameter (max_cont=maxconts)
6259       parameter (max_dim=70)
6260       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6261       double precision zapas(max_dim,maxconts,max_fg_procs),
6262      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6263       common /przechowalnia/ zapas
6264       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6265      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6266 #endif
6267       include 'COMMON.SETUP'
6268       include 'COMMON.FFIELD'
6269       include 'COMMON.DERIV'
6270       include 'COMMON.LOCAL'
6271       include 'COMMON.INTERACT'
6272       include 'COMMON.CONTACTS'
6273       include 'COMMON.CHAIN'
6274       include 'COMMON.CONTROL'
6275       double precision gx(3),gx1(3)
6276       integer num_cont_hb_old(maxres)
6277       logical lprn,ldone
6278       double precision eello4,eello5,eelo6,eello_turn6
6279       external eello4,eello5,eello6,eello_turn6
6280 C Set lprn=.true. for debugging
6281       lprn=.false.
6282       eturn6=0.0d0
6283 #ifdef MPI
6284       do i=1,nres
6285         num_cont_hb_old(i)=num_cont_hb(i)
6286       enddo
6287       n_corr=0
6288       n_corr1=0
6289       if (nfgtasks.le.1) goto 30
6290       if (lprn) then
6291         write (iout,'(a)') 'Contact function values before RECEIVE:'
6292         do i=nnt,nct-2
6293           write (iout,'(2i3,50(1x,i2,f5.2))')
6294      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6295      &    j=1,num_cont_hb(i))
6296         enddo
6297       endif
6298       call flush(iout)
6299       do i=1,ntask_cont_from
6300         ncont_recv(i)=0
6301       enddo
6302       do i=1,ntask_cont_to
6303         ncont_sent(i)=0
6304       enddo
6305 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6306 c     & ntask_cont_to
6307 C Make the list of contacts to send to send to other procesors
6308       do i=iturn3_start,iturn3_end
6309 c        write (iout,*) "make contact list turn3",i," num_cont",
6310 c     &    num_cont_hb(i)
6311         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6312       enddo
6313       do i=iturn4_start,iturn4_end
6314 c        write (iout,*) "make contact list turn4",i," num_cont",
6315 c     &   num_cont_hb(i)
6316         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6317       enddo
6318       do ii=1,nat_sent
6319         i=iat_sent(ii)
6320 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6321 c     &    num_cont_hb(i)
6322         do j=1,num_cont_hb(i)
6323         do k=1,4
6324           jjc=jcont_hb(j,i)
6325           iproc=iint_sent_local(k,jjc,ii)
6326 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6327           if (iproc.ne.0) then
6328             ncont_sent(iproc)=ncont_sent(iproc)+1
6329             nn=ncont_sent(iproc)
6330             zapas(1,nn,iproc)=i
6331             zapas(2,nn,iproc)=jjc
6332             zapas(3,nn,iproc)=d_cont(j,i)
6333             ind=3
6334             do kk=1,3
6335               ind=ind+1
6336               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6337             enddo
6338             do kk=1,2
6339               do ll=1,2
6340                 ind=ind+1
6341                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6342               enddo
6343             enddo
6344             do jj=1,5
6345               do kk=1,3
6346                 do ll=1,2
6347                   do mm=1,2
6348                     ind=ind+1
6349                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6350                   enddo
6351                 enddo
6352               enddo
6353             enddo
6354           endif
6355         enddo
6356         enddo
6357       enddo
6358       if (lprn) then
6359       write (iout,*)
6360      &  "Numbers of contacts to be sent to other processors",
6361      &  (ncont_sent(i),i=1,ntask_cont_to)
6362       write (iout,*) "Contacts sent"
6363       do ii=1,ntask_cont_to
6364         nn=ncont_sent(ii)
6365         iproc=itask_cont_to(ii)
6366         write (iout,*) nn," contacts to processor",iproc,
6367      &   " of CONT_TO_COMM group"
6368         do i=1,nn
6369           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6370         enddo
6371       enddo
6372       call flush(iout)
6373       endif
6374       CorrelType=477
6375       CorrelID=fg_rank+1
6376       CorrelType1=478
6377       CorrelID1=nfgtasks+fg_rank+1
6378       ireq=0
6379 C Receive the numbers of needed contacts from other processors
6380       do ii=1,ntask_cont_from
6381         iproc=itask_cont_from(ii)
6382         ireq=ireq+1
6383         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6384      &    FG_COMM,req(ireq),IERR)
6385       enddo
6386 c      write (iout,*) "IRECV ended"
6387 c      call flush(iout)
6388 C Send the number of contacts needed by other processors
6389       do ii=1,ntask_cont_to
6390         iproc=itask_cont_to(ii)
6391         ireq=ireq+1
6392         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6393      &    FG_COMM,req(ireq),IERR)
6394       enddo
6395 c      write (iout,*) "ISEND ended"
6396 c      write (iout,*) "number of requests (nn)",ireq
6397       call flush(iout)
6398       if (ireq.gt.0)
6399      &  call MPI_Waitall(ireq,req,status_array,ierr)
6400 c      write (iout,*)
6401 c     &  "Numbers of contacts to be received from other processors",
6402 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6403 c      call flush(iout)
6404 C Receive contacts
6405       ireq=0
6406       do ii=1,ntask_cont_from
6407         iproc=itask_cont_from(ii)
6408         nn=ncont_recv(ii)
6409 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6410 c     &   " of CONT_TO_COMM group"
6411         call flush(iout)
6412         if (nn.gt.0) then
6413           ireq=ireq+1
6414           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6415      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6416 c          write (iout,*) "ireq,req",ireq,req(ireq)
6417         endif
6418       enddo
6419 C Send the contacts to processors that need them
6420       do ii=1,ntask_cont_to
6421         iproc=itask_cont_to(ii)
6422         nn=ncont_sent(ii)
6423 c        write (iout,*) nn," contacts to processor",iproc,
6424 c     &   " of CONT_TO_COMM group"
6425         if (nn.gt.0) then
6426           ireq=ireq+1
6427           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6428      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6429 c          write (iout,*) "ireq,req",ireq,req(ireq)
6430 c          do i=1,nn
6431 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6432 c          enddo
6433         endif
6434       enddo
6435 c      write (iout,*) "number of requests (contacts)",ireq
6436 c      write (iout,*) "req",(req(i),i=1,4)
6437 c      call flush(iout)
6438       if (ireq.gt.0)
6439      & call MPI_Waitall(ireq,req,status_array,ierr)
6440       do iii=1,ntask_cont_from
6441         iproc=itask_cont_from(iii)
6442         nn=ncont_recv(iii)
6443         if (lprn) then
6444         write (iout,*) "Received",nn," contacts from processor",iproc,
6445      &   " of CONT_FROM_COMM group"
6446         call flush(iout)
6447         do i=1,nn
6448           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6449         enddo
6450         call flush(iout)
6451         endif
6452         do i=1,nn
6453           ii=zapas_recv(1,i,iii)
6454 c Flag the received contacts to prevent double-counting
6455           jj=-zapas_recv(2,i,iii)
6456 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6457 c          call flush(iout)
6458           nnn=num_cont_hb(ii)+1
6459           num_cont_hb(ii)=nnn
6460           jcont_hb(nnn,ii)=jj
6461           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6462           ind=3
6463           do kk=1,3
6464             ind=ind+1
6465             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6466           enddo
6467           do kk=1,2
6468             do ll=1,2
6469               ind=ind+1
6470               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6471             enddo
6472           enddo
6473           do jj=1,5
6474             do kk=1,3
6475               do ll=1,2
6476                 do mm=1,2
6477                   ind=ind+1
6478                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6479                 enddo
6480               enddo
6481             enddo
6482           enddo
6483         enddo
6484       enddo
6485       call flush(iout)
6486       if (lprn) then
6487         write (iout,'(a)') 'Contact function values after receive:'
6488         do i=nnt,nct-2
6489           write (iout,'(2i3,50(1x,i3,5f6.3))')
6490      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6491      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6492         enddo
6493         call flush(iout)
6494       endif
6495    30 continue
6496 #endif
6497       if (lprn) then
6498         write (iout,'(a)') 'Contact function values:'
6499         do i=nnt,nct-2
6500           write (iout,'(2i3,50(1x,i2,5f6.3))')
6501      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6502      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6503         enddo
6504       endif
6505       ecorr=0.0D0
6506       ecorr5=0.0d0
6507       ecorr6=0.0d0
6508 C Remove the loop below after debugging !!!
6509       do i=nnt,nct
6510         do j=1,3
6511           gradcorr(j,i)=0.0D0
6512           gradxorr(j,i)=0.0D0
6513         enddo
6514       enddo
6515 C Calculate the dipole-dipole interaction energies
6516       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6517       do i=iatel_s,iatel_e+1
6518         num_conti=num_cont_hb(i)
6519         do jj=1,num_conti
6520           j=jcont_hb(jj,i)
6521 #ifdef MOMENT
6522           call dipole(i,j,jj)
6523 #endif
6524         enddo
6525       enddo
6526       endif
6527 C Calculate the local-electrostatic correlation terms
6528 c                write (iout,*) "gradcorr5 in eello5 before loop"
6529 c                do iii=1,nres
6530 c                  write (iout,'(i5,3f10.5)')
6531 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6532 c                enddo
6533       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6534 c        write (iout,*) "corr loop i",i
6535         i1=i+1
6536         num_conti=num_cont_hb(i)
6537         num_conti1=num_cont_hb(i+1)
6538         do jj=1,num_conti
6539           j=jcont_hb(jj,i)
6540           jp=iabs(j)
6541           do kk=1,num_conti1
6542             j1=jcont_hb(kk,i1)
6543             jp1=iabs(j1)
6544 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6545 c     &         ' jj=',jj,' kk=',kk
6546 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6547             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6548      &          .or. j.lt.0 .and. j1.gt.0) .and.
6549      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6550 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6551 C The system gains extra energy.
6552               n_corr=n_corr+1
6553               sqd1=dsqrt(d_cont(jj,i))
6554               sqd2=dsqrt(d_cont(kk,i1))
6555               sred_geom = sqd1*sqd2
6556               IF (sred_geom.lt.cutoff_corr) THEN
6557                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6558      &            ekont,fprimcont)
6559 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6560 cd     &         ' jj=',jj,' kk=',kk
6561                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6562                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6563                 do l=1,3
6564                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6565                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6566                 enddo
6567                 n_corr1=n_corr1+1
6568 cd               write (iout,*) 'sred_geom=',sred_geom,
6569 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6570 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6571 cd               write (iout,*) "g_contij",g_contij
6572 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6573 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6574                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6575                 if (wcorr4.gt.0.0d0)
6576      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6577                   if (energy_dec.and.wcorr4.gt.0.0d0)
6578      1                 write (iout,'(a6,4i5,0pf7.3)')
6579      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6580 c                write (iout,*) "gradcorr5 before eello5"
6581 c                do iii=1,nres
6582 c                  write (iout,'(i5,3f10.5)')
6583 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6584 c                enddo
6585                 if (wcorr5.gt.0.0d0)
6586      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6587 c                write (iout,*) "gradcorr5 after eello5"
6588 c                do iii=1,nres
6589 c                  write (iout,'(i5,3f10.5)')
6590 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6591 c                enddo
6592                   if (energy_dec.and.wcorr5.gt.0.0d0)
6593      1                 write (iout,'(a6,4i5,0pf7.3)')
6594      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6595 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6596 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6597                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6598      &               .or. wturn6.eq.0.0d0))then
6599 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6600                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6601                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6602      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6603 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6604 cd     &            'ecorr6=',ecorr6
6605 cd                write (iout,'(4e15.5)') sred_geom,
6606 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6607 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6608 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6609                 else if (wturn6.gt.0.0d0
6610      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6611 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6612                   eturn6=eturn6+eello_turn6(i,jj,kk)
6613                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6614      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6615 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6616                 endif
6617               ENDIF
6618 1111          continue
6619             endif
6620           enddo ! kk
6621         enddo ! jj
6622       enddo ! i
6623       do i=1,nres
6624         num_cont_hb(i)=num_cont_hb_old(i)
6625       enddo
6626 c                write (iout,*) "gradcorr5 in eello5"
6627 c                do iii=1,nres
6628 c                  write (iout,'(i5,3f10.5)')
6629 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6630 c                enddo
6631       return
6632       end
6633 c------------------------------------------------------------------------------
6634       subroutine add_hb_contact_eello(ii,jj,itask)
6635       implicit real*8 (a-h,o-z)
6636       include "DIMENSIONS"
6637       include "COMMON.IOUNITS"
6638       integer max_cont
6639       integer max_dim
6640       parameter (max_cont=maxconts)
6641       parameter (max_dim=70)
6642       include "COMMON.CONTACTS"
6643       double precision zapas(max_dim,maxconts,max_fg_procs),
6644      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6645       common /przechowalnia/ zapas
6646       integer i,j,ii,jj,iproc,itask(4),nn
6647 c      write (iout,*) "itask",itask
6648       do i=1,2
6649         iproc=itask(i)
6650         if (iproc.gt.0) then
6651           do j=1,num_cont_hb(ii)
6652             jjc=jcont_hb(j,ii)
6653 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6654             if (jjc.eq.jj) then
6655               ncont_sent(iproc)=ncont_sent(iproc)+1
6656               nn=ncont_sent(iproc)
6657               zapas(1,nn,iproc)=ii
6658               zapas(2,nn,iproc)=jjc
6659               zapas(3,nn,iproc)=d_cont(j,ii)
6660               ind=3
6661               do kk=1,3
6662                 ind=ind+1
6663                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6664               enddo
6665               do kk=1,2
6666                 do ll=1,2
6667                   ind=ind+1
6668                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6669                 enddo
6670               enddo
6671               do jj=1,5
6672                 do kk=1,3
6673                   do ll=1,2
6674                     do mm=1,2
6675                       ind=ind+1
6676                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6677                     enddo
6678                   enddo
6679                 enddo
6680               enddo
6681               exit
6682             endif
6683           enddo
6684         endif
6685       enddo
6686       return
6687       end
6688 c------------------------------------------------------------------------------
6689       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6690       implicit real*8 (a-h,o-z)
6691       include 'DIMENSIONS'
6692       include 'COMMON.IOUNITS'
6693       include 'COMMON.DERIV'
6694       include 'COMMON.INTERACT'
6695       include 'COMMON.CONTACTS'
6696       double precision gx(3),gx1(3)
6697       logical lprn
6698       lprn=.false.
6699       eij=facont_hb(jj,i)
6700       ekl=facont_hb(kk,k)
6701       ees0pij=ees0p(jj,i)
6702       ees0pkl=ees0p(kk,k)
6703       ees0mij=ees0m(jj,i)
6704       ees0mkl=ees0m(kk,k)
6705       ekont=eij*ekl
6706       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6707 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6708 C Following 4 lines for diagnostics.
6709 cd    ees0pkl=0.0D0
6710 cd    ees0pij=1.0D0
6711 cd    ees0mkl=0.0D0
6712 cd    ees0mij=1.0D0
6713 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6714 c     & 'Contacts ',i,j,
6715 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6716 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6717 c     & 'gradcorr_long'
6718 C Calculate the multi-body contribution to energy.
6719 c      ecorr=ecorr+ekont*ees
6720 C Calculate multi-body contributions to the gradient.
6721       coeffpees0pij=coeffp*ees0pij
6722       coeffmees0mij=coeffm*ees0mij
6723       coeffpees0pkl=coeffp*ees0pkl
6724       coeffmees0mkl=coeffm*ees0mkl
6725       do ll=1,3
6726 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6727         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6728      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6729      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6730         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6731      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6732      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6733 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6734         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6735      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6736      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6737         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6738      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6739      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6740         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6741      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6742      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6743         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6744         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6745         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6746      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6747      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6748         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6749         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6750 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6751       enddo
6752 c      write (iout,*)
6753 cgrad      do m=i+1,j-1
6754 cgrad        do ll=1,3
6755 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6756 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6757 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6758 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6759 cgrad        enddo
6760 cgrad      enddo
6761 cgrad      do m=k+1,l-1
6762 cgrad        do ll=1,3
6763 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6764 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6765 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6766 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6767 cgrad        enddo
6768 cgrad      enddo
6769 c      write (iout,*) "ehbcorr",ekont*ees
6770       ehbcorr=ekont*ees
6771       return
6772       end
6773 #ifdef MOMENT
6774 C---------------------------------------------------------------------------
6775       subroutine dipole(i,j,jj)
6776       implicit real*8 (a-h,o-z)
6777       include 'DIMENSIONS'
6778       include 'COMMON.IOUNITS'
6779       include 'COMMON.CHAIN'
6780       include 'COMMON.FFIELD'
6781       include 'COMMON.DERIV'
6782       include 'COMMON.INTERACT'
6783       include 'COMMON.CONTACTS'
6784       include 'COMMON.TORSION'
6785       include 'COMMON.VAR'
6786       include 'COMMON.GEO'
6787       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6788      &  auxmat(2,2)
6789       iti1 = itortyp(itype(i+1))
6790       if (j.lt.nres-1) then
6791         itj1 = itortyp(itype(j+1))
6792       else
6793         itj1=ntortyp+1
6794       endif
6795       do iii=1,2
6796         dipi(iii,1)=Ub2(iii,i)
6797         dipderi(iii)=Ub2der(iii,i)
6798         dipi(iii,2)=b1(iii,iti1)
6799         dipj(iii,1)=Ub2(iii,j)
6800         dipderj(iii)=Ub2der(iii,j)
6801         dipj(iii,2)=b1(iii,itj1)
6802       enddo
6803       kkk=0
6804       do iii=1,2
6805         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6806         do jjj=1,2
6807           kkk=kkk+1
6808           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6809         enddo
6810       enddo
6811       do kkk=1,5
6812         do lll=1,3
6813           mmm=0
6814           do iii=1,2
6815             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6816      &        auxvec(1))
6817             do jjj=1,2
6818               mmm=mmm+1
6819               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6820             enddo
6821           enddo
6822         enddo
6823       enddo
6824       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6825       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6826       do iii=1,2
6827         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6828       enddo
6829       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6830       do iii=1,2
6831         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6832       enddo
6833       return
6834       end
6835 #endif
6836 C---------------------------------------------------------------------------
6837       subroutine calc_eello(i,j,k,l,jj,kk)
6838 C
6839 C This subroutine computes matrices and vectors needed to calculate
6840 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6841 C
6842       implicit real*8 (a-h,o-z)
6843       include 'DIMENSIONS'
6844       include 'COMMON.IOUNITS'
6845       include 'COMMON.CHAIN'
6846       include 'COMMON.DERIV'
6847       include 'COMMON.INTERACT'
6848       include 'COMMON.CONTACTS'
6849       include 'COMMON.TORSION'
6850       include 'COMMON.VAR'
6851       include 'COMMON.GEO'
6852       include 'COMMON.FFIELD'
6853       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6854      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6855       logical lprn
6856       common /kutas/ lprn
6857 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6858 cd     & ' jj=',jj,' kk=',kk
6859 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6860 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6861 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6862       do iii=1,2
6863         do jjj=1,2
6864           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6865           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6866         enddo
6867       enddo
6868       call transpose2(aa1(1,1),aa1t(1,1))
6869       call transpose2(aa2(1,1),aa2t(1,1))
6870       do kkk=1,5
6871         do lll=1,3
6872           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6873      &      aa1tder(1,1,lll,kkk))
6874           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6875      &      aa2tder(1,1,lll,kkk))
6876         enddo
6877       enddo
6878       if (l.eq.j+1) then
6879 C parallel orientation of the two CA-CA-CA frames.
6880         if (i.gt.1) then
6881           iti=itortyp(itype(i))
6882         else
6883           iti=ntortyp+1
6884         endif
6885         itk1=itortyp(itype(k+1))
6886         itj=itortyp(itype(j))
6887         if (l.lt.nres-1) then
6888           itl1=itortyp(itype(l+1))
6889         else
6890           itl1=ntortyp+1
6891         endif
6892 C A1 kernel(j+1) A2T
6893 cd        do iii=1,2
6894 cd          write (iout,'(3f10.5,5x,3f10.5)')
6895 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6896 cd        enddo
6897         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6898      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6899      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6900 C Following matrices are needed only for 6-th order cumulants
6901         IF (wcorr6.gt.0.0d0) THEN
6902         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6903      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6904      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6905         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6906      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6907      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6908      &   ADtEAderx(1,1,1,1,1,1))
6909         lprn=.false.
6910         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6911      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6912      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6913      &   ADtEA1derx(1,1,1,1,1,1))
6914         ENDIF
6915 C End 6-th order cumulants
6916 cd        lprn=.false.
6917 cd        if (lprn) then
6918 cd        write (2,*) 'In calc_eello6'
6919 cd        do iii=1,2
6920 cd          write (2,*) 'iii=',iii
6921 cd          do kkk=1,5
6922 cd            write (2,*) 'kkk=',kkk
6923 cd            do jjj=1,2
6924 cd              write (2,'(3(2f10.5),5x)')
6925 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6926 cd            enddo
6927 cd          enddo
6928 cd        enddo
6929 cd        endif
6930         call transpose2(EUgder(1,1,k),auxmat(1,1))
6931         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6932         call transpose2(EUg(1,1,k),auxmat(1,1))
6933         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6934         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6935         do iii=1,2
6936           do kkk=1,5
6937             do lll=1,3
6938               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6939      &          EAEAderx(1,1,lll,kkk,iii,1))
6940             enddo
6941           enddo
6942         enddo
6943 C A1T kernel(i+1) A2
6944         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6945      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6946      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6947 C Following matrices are needed only for 6-th order cumulants
6948         IF (wcorr6.gt.0.0d0) THEN
6949         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6950      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6951      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6952         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6953      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6954      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6955      &   ADtEAderx(1,1,1,1,1,2))
6956         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6957      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6958      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6959      &   ADtEA1derx(1,1,1,1,1,2))
6960         ENDIF
6961 C End 6-th order cumulants
6962         call transpose2(EUgder(1,1,l),auxmat(1,1))
6963         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6964         call transpose2(EUg(1,1,l),auxmat(1,1))
6965         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6966         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6967         do iii=1,2
6968           do kkk=1,5
6969             do lll=1,3
6970               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6971      &          EAEAderx(1,1,lll,kkk,iii,2))
6972             enddo
6973           enddo
6974         enddo
6975 C AEAb1 and AEAb2
6976 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6977 C They are needed only when the fifth- or the sixth-order cumulants are
6978 C indluded.
6979         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6980         call transpose2(AEA(1,1,1),auxmat(1,1))
6981         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6982         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6983         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6984         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6985         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6986         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6987         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6988         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6989         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6990         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6991         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6992         call transpose2(AEA(1,1,2),auxmat(1,1))
6993         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6994         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6995         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6996         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6997         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6998         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6999         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7000         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7001         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7002         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7003         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7004 C Calculate the Cartesian derivatives of the vectors.
7005         do iii=1,2
7006           do kkk=1,5
7007             do lll=1,3
7008               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7009               call matvec2(auxmat(1,1),b1(1,iti),
7010      &          AEAb1derx(1,lll,kkk,iii,1,1))
7011               call matvec2(auxmat(1,1),Ub2(1,i),
7012      &          AEAb2derx(1,lll,kkk,iii,1,1))
7013               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7014      &          AEAb1derx(1,lll,kkk,iii,2,1))
7015               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7016      &          AEAb2derx(1,lll,kkk,iii,2,1))
7017               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7018               call matvec2(auxmat(1,1),b1(1,itj),
7019      &          AEAb1derx(1,lll,kkk,iii,1,2))
7020               call matvec2(auxmat(1,1),Ub2(1,j),
7021      &          AEAb2derx(1,lll,kkk,iii,1,2))
7022               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7023      &          AEAb1derx(1,lll,kkk,iii,2,2))
7024               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7025      &          AEAb2derx(1,lll,kkk,iii,2,2))
7026             enddo
7027           enddo
7028         enddo
7029         ENDIF
7030 C End vectors
7031       else
7032 C Antiparallel orientation of the two CA-CA-CA frames.
7033         if (i.gt.1) then
7034           iti=itortyp(itype(i))
7035         else
7036           iti=ntortyp+1
7037         endif
7038         itk1=itortyp(itype(k+1))
7039         itl=itortyp(itype(l))
7040         itj=itortyp(itype(j))
7041         if (j.lt.nres-1) then
7042           itj1=itortyp(itype(j+1))
7043         else
7044           itj1=ntortyp+1
7045         endif
7046 C A2 kernel(j-1)T A1T
7047         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7048      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7049      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7050 C Following matrices are needed only for 6-th order cumulants
7051         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7052      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7054      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7055      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7056         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7057      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7058      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7059      &   ADtEAderx(1,1,1,1,1,1))
7060         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7061      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7062      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7063      &   ADtEA1derx(1,1,1,1,1,1))
7064         ENDIF
7065 C End 6-th order cumulants
7066         call transpose2(EUgder(1,1,k),auxmat(1,1))
7067         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7068         call transpose2(EUg(1,1,k),auxmat(1,1))
7069         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7070         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7071         do iii=1,2
7072           do kkk=1,5
7073             do lll=1,3
7074               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7075      &          EAEAderx(1,1,lll,kkk,iii,1))
7076             enddo
7077           enddo
7078         enddo
7079 C A2T kernel(i+1)T A1
7080         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7081      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7082      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7083 C Following matrices are needed only for 6-th order cumulants
7084         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7085      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7086         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7087      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7088      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7089         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7090      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7091      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7092      &   ADtEAderx(1,1,1,1,1,2))
7093         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7094      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7095      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7096      &   ADtEA1derx(1,1,1,1,1,2))
7097         ENDIF
7098 C End 6-th order cumulants
7099         call transpose2(EUgder(1,1,j),auxmat(1,1))
7100         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7101         call transpose2(EUg(1,1,j),auxmat(1,1))
7102         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7103         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7104         do iii=1,2
7105           do kkk=1,5
7106             do lll=1,3
7107               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7108      &          EAEAderx(1,1,lll,kkk,iii,2))
7109             enddo
7110           enddo
7111         enddo
7112 C AEAb1 and AEAb2
7113 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7114 C They are needed only when the fifth- or the sixth-order cumulants are
7115 C indluded.
7116         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7117      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7118         call transpose2(AEA(1,1,1),auxmat(1,1))
7119         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7120         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7121         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7122         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7123         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7124         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7125         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7126         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7127         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7128         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7129         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7130         call transpose2(AEA(1,1,2),auxmat(1,1))
7131         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7132         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7133         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7134         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7135         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7136         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7137         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7138         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7139         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7140         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7141         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7142 C Calculate the Cartesian derivatives of the vectors.
7143         do iii=1,2
7144           do kkk=1,5
7145             do lll=1,3
7146               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7147               call matvec2(auxmat(1,1),b1(1,iti),
7148      &          AEAb1derx(1,lll,kkk,iii,1,1))
7149               call matvec2(auxmat(1,1),Ub2(1,i),
7150      &          AEAb2derx(1,lll,kkk,iii,1,1))
7151               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7152      &          AEAb1derx(1,lll,kkk,iii,2,1))
7153               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7154      &          AEAb2derx(1,lll,kkk,iii,2,1))
7155               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7156               call matvec2(auxmat(1,1),b1(1,itl),
7157      &          AEAb1derx(1,lll,kkk,iii,1,2))
7158               call matvec2(auxmat(1,1),Ub2(1,l),
7159      &          AEAb2derx(1,lll,kkk,iii,1,2))
7160               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7161      &          AEAb1derx(1,lll,kkk,iii,2,2))
7162               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7163      &          AEAb2derx(1,lll,kkk,iii,2,2))
7164             enddo
7165           enddo
7166         enddo
7167         ENDIF
7168 C End vectors
7169       endif
7170       return
7171       end
7172 C---------------------------------------------------------------------------
7173       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7174      &  KK,KKderg,AKA,AKAderg,AKAderx)
7175       implicit none
7176       integer nderg
7177       logical transp
7178       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7179      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7180      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7181       integer iii,kkk,lll
7182       integer jjj,mmm
7183       logical lprn
7184       common /kutas/ lprn
7185       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7186       do iii=1,nderg
7187         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7188      &    AKAderg(1,1,iii))
7189       enddo
7190 cd      if (lprn) write (2,*) 'In kernel'
7191       do kkk=1,5
7192 cd        if (lprn) write (2,*) 'kkk=',kkk
7193         do lll=1,3
7194           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7195      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7196 cd          if (lprn) then
7197 cd            write (2,*) 'lll=',lll
7198 cd            write (2,*) 'iii=1'
7199 cd            do jjj=1,2
7200 cd              write (2,'(3(2f10.5),5x)')
7201 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7202 cd            enddo
7203 cd          endif
7204           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7205      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7206 cd          if (lprn) then
7207 cd            write (2,*) 'lll=',lll
7208 cd            write (2,*) 'iii=2'
7209 cd            do jjj=1,2
7210 cd              write (2,'(3(2f10.5),5x)')
7211 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7212 cd            enddo
7213 cd          endif
7214         enddo
7215       enddo
7216       return
7217       end
7218 C---------------------------------------------------------------------------
7219       double precision function eello4(i,j,k,l,jj,kk)
7220       implicit real*8 (a-h,o-z)
7221       include 'DIMENSIONS'
7222       include 'COMMON.IOUNITS'
7223       include 'COMMON.CHAIN'
7224       include 'COMMON.DERIV'
7225       include 'COMMON.INTERACT'
7226       include 'COMMON.CONTACTS'
7227       include 'COMMON.TORSION'
7228       include 'COMMON.VAR'
7229       include 'COMMON.GEO'
7230       double precision pizda(2,2),ggg1(3),ggg2(3)
7231 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7232 cd        eello4=0.0d0
7233 cd        return
7234 cd      endif
7235 cd      print *,'eello4:',i,j,k,l,jj,kk
7236 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7237 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7238 cold      eij=facont_hb(jj,i)
7239 cold      ekl=facont_hb(kk,k)
7240 cold      ekont=eij*ekl
7241       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7242 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7243       gcorr_loc(k-1)=gcorr_loc(k-1)
7244      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7245       if (l.eq.j+1) then
7246         gcorr_loc(l-1)=gcorr_loc(l-1)
7247      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7248       else
7249         gcorr_loc(j-1)=gcorr_loc(j-1)
7250      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7251       endif
7252       do iii=1,2
7253         do kkk=1,5
7254           do lll=1,3
7255             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7256      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7257 cd            derx(lll,kkk,iii)=0.0d0
7258           enddo
7259         enddo
7260       enddo
7261 cd      gcorr_loc(l-1)=0.0d0
7262 cd      gcorr_loc(j-1)=0.0d0
7263 cd      gcorr_loc(k-1)=0.0d0
7264 cd      eel4=1.0d0
7265 cd      write (iout,*)'Contacts have occurred for peptide groups',
7266 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7267 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7268       if (j.lt.nres-1) then
7269         j1=j+1
7270         j2=j-1
7271       else
7272         j1=j-1
7273         j2=j-2
7274       endif
7275       if (l.lt.nres-1) then
7276         l1=l+1
7277         l2=l-1
7278       else
7279         l1=l-1
7280         l2=l-2
7281       endif
7282       do ll=1,3
7283 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7284 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7285         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7286         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7287 cgrad        ghalf=0.5d0*ggg1(ll)
7288         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7289         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7290         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7291         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7292         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7293         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7294 cgrad        ghalf=0.5d0*ggg2(ll)
7295         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7296         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7297         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7298         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7299         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7300         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7301       enddo
7302 cgrad      do m=i+1,j-1
7303 cgrad        do ll=1,3
7304 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7305 cgrad        enddo
7306 cgrad      enddo
7307 cgrad      do m=k+1,l-1
7308 cgrad        do ll=1,3
7309 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7310 cgrad        enddo
7311 cgrad      enddo
7312 cgrad      do m=i+2,j2
7313 cgrad        do ll=1,3
7314 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7315 cgrad        enddo
7316 cgrad      enddo
7317 cgrad      do m=k+2,l2
7318 cgrad        do ll=1,3
7319 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7320 cgrad        enddo
7321 cgrad      enddo
7322 cd      do iii=1,nres-3
7323 cd        write (2,*) iii,gcorr_loc(iii)
7324 cd      enddo
7325       eello4=ekont*eel4
7326 cd      write (2,*) 'ekont',ekont
7327 cd      write (iout,*) 'eello4',ekont*eel4
7328       return
7329       end
7330 C---------------------------------------------------------------------------
7331       double precision function eello5(i,j,k,l,jj,kk)
7332       implicit real*8 (a-h,o-z)
7333       include 'DIMENSIONS'
7334       include 'COMMON.IOUNITS'
7335       include 'COMMON.CHAIN'
7336       include 'COMMON.DERIV'
7337       include 'COMMON.INTERACT'
7338       include 'COMMON.CONTACTS'
7339       include 'COMMON.TORSION'
7340       include 'COMMON.VAR'
7341       include 'COMMON.GEO'
7342       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7343       double precision ggg1(3),ggg2(3)
7344 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7345 C                                                                              C
7346 C                            Parallel chains                                   C
7347 C                                                                              C
7348 C          o             o                   o             o                   C
7349 C         /l\           / \             \   / \           / \   /              C
7350 C        /   \         /   \             \ /   \         /   \ /               C
7351 C       j| o |l1       | o |              o| o |         | o |o                C
7352 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7353 C      \i/   \         /   \ /             /   \         /   \                 C
7354 C       o    k1             o                                                  C
7355 C         (I)          (II)                (III)          (IV)                 C
7356 C                                                                              C
7357 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7358 C                                                                              C
7359 C                            Antiparallel chains                               C
7360 C                                                                              C
7361 C          o             o                   o             o                   C
7362 C         /j\           / \             \   / \           / \   /              C
7363 C        /   \         /   \             \ /   \         /   \ /               C
7364 C      j1| o |l        | o |              o| o |         | o |o                C
7365 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7366 C      \i/   \         /   \ /             /   \         /   \                 C
7367 C       o     k1            o                                                  C
7368 C         (I)          (II)                (III)          (IV)                 C
7369 C                                                                              C
7370 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7371 C                                                                              C
7372 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7373 C                                                                              C
7374 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7375 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7376 cd        eello5=0.0d0
7377 cd        return
7378 cd      endif
7379 cd      write (iout,*)
7380 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7381 cd     &   ' and',k,l
7382       itk=itortyp(itype(k))
7383       itl=itortyp(itype(l))
7384       itj=itortyp(itype(j))
7385       eello5_1=0.0d0
7386       eello5_2=0.0d0
7387       eello5_3=0.0d0
7388       eello5_4=0.0d0
7389 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7390 cd     &   eel5_3_num,eel5_4_num)
7391       do iii=1,2
7392         do kkk=1,5
7393           do lll=1,3
7394             derx(lll,kkk,iii)=0.0d0
7395           enddo
7396         enddo
7397       enddo
7398 cd      eij=facont_hb(jj,i)
7399 cd      ekl=facont_hb(kk,k)
7400 cd      ekont=eij*ekl
7401 cd      write (iout,*)'Contacts have occurred for peptide groups',
7402 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7403 cd      goto 1111
7404 C Contribution from the graph I.
7405 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7406 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7407       call transpose2(EUg(1,1,k),auxmat(1,1))
7408       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7409       vv(1)=pizda(1,1)-pizda(2,2)
7410       vv(2)=pizda(1,2)+pizda(2,1)
7411       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7412      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7413 C Explicit gradient in virtual-dihedral angles.
7414       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7415      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7416      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7417       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7418       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7419       vv(1)=pizda(1,1)-pizda(2,2)
7420       vv(2)=pizda(1,2)+pizda(2,1)
7421       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7422      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7423      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7424       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7425       vv(1)=pizda(1,1)-pizda(2,2)
7426       vv(2)=pizda(1,2)+pizda(2,1)
7427       if (l.eq.j+1) then
7428         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7429      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7430      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7431       else
7432         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7433      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7434      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7435       endif
7436 C Cartesian gradient
7437       do iii=1,2
7438         do kkk=1,5
7439           do lll=1,3
7440             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7441      &        pizda(1,1))
7442             vv(1)=pizda(1,1)-pizda(2,2)
7443             vv(2)=pizda(1,2)+pizda(2,1)
7444             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7445      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7446      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7447           enddo
7448         enddo
7449       enddo
7450 c      goto 1112
7451 c1111  continue
7452 C Contribution from graph II
7453       call transpose2(EE(1,1,itk),auxmat(1,1))
7454       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7455       vv(1)=pizda(1,1)+pizda(2,2)
7456       vv(2)=pizda(2,1)-pizda(1,2)
7457       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7458      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7459 C Explicit gradient in virtual-dihedral angles.
7460       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7461      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7462       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7463       vv(1)=pizda(1,1)+pizda(2,2)
7464       vv(2)=pizda(2,1)-pizda(1,2)
7465       if (l.eq.j+1) then
7466         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7467      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7468      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7469       else
7470         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7471      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7472      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7473       endif
7474 C Cartesian gradient
7475       do iii=1,2
7476         do kkk=1,5
7477           do lll=1,3
7478             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7479      &        pizda(1,1))
7480             vv(1)=pizda(1,1)+pizda(2,2)
7481             vv(2)=pizda(2,1)-pizda(1,2)
7482             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7483      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7484      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7485           enddo
7486         enddo
7487       enddo
7488 cd      goto 1112
7489 cd1111  continue
7490       if (l.eq.j+1) then
7491 cd        goto 1110
7492 C Parallel orientation
7493 C Contribution from graph III
7494         call transpose2(EUg(1,1,l),auxmat(1,1))
7495         call matmat2(AEA(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         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7499      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7500 C Explicit gradient in virtual-dihedral angles.
7501         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7502      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7503      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7504         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7505         vv(1)=pizda(1,1)-pizda(2,2)
7506         vv(2)=pizda(1,2)+pizda(2,1)
7507         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7508      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7509      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7510         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7511         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7512         vv(1)=pizda(1,1)-pizda(2,2)
7513         vv(2)=pizda(1,2)+pizda(2,1)
7514         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7515      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7516      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7517 C Cartesian gradient
7518         do iii=1,2
7519           do kkk=1,5
7520             do lll=1,3
7521               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7522      &          pizda(1,1))
7523               vv(1)=pizda(1,1)-pizda(2,2)
7524               vv(2)=pizda(1,2)+pizda(2,1)
7525               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7526      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7527      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7528             enddo
7529           enddo
7530         enddo
7531 cd        goto 1112
7532 C Contribution from graph IV
7533 cd1110    continue
7534         call transpose2(EE(1,1,itl),auxmat(1,1))
7535         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7536         vv(1)=pizda(1,1)+pizda(2,2)
7537         vv(2)=pizda(2,1)-pizda(1,2)
7538         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7539      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7540 C Explicit gradient in virtual-dihedral angles.
7541         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7542      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7543         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7544         vv(1)=pizda(1,1)+pizda(2,2)
7545         vv(2)=pizda(2,1)-pizda(1,2)
7546         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7547      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7548      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7549 C Cartesian gradient
7550         do iii=1,2
7551           do kkk=1,5
7552             do lll=1,3
7553               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7554      &          pizda(1,1))
7555               vv(1)=pizda(1,1)+pizda(2,2)
7556               vv(2)=pizda(2,1)-pizda(1,2)
7557               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7558      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7559      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7560             enddo
7561           enddo
7562         enddo
7563       else
7564 C Antiparallel orientation
7565 C Contribution from graph III
7566 c        goto 1110
7567         call transpose2(EUg(1,1,j),auxmat(1,1))
7568         call matmat2(AEA(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         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7572      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7573 C Explicit gradient in virtual-dihedral angles.
7574         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7575      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7576      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7577         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7578         vv(1)=pizda(1,1)-pizda(2,2)
7579         vv(2)=pizda(1,2)+pizda(2,1)
7580         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7581      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7582      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7583         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7584         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7585         vv(1)=pizda(1,1)-pizda(2,2)
7586         vv(2)=pizda(1,2)+pizda(2,1)
7587         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7588      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7589      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7590 C Cartesian gradient
7591         do iii=1,2
7592           do kkk=1,5
7593             do lll=1,3
7594               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7595      &          pizda(1,1))
7596               vv(1)=pizda(1,1)-pizda(2,2)
7597               vv(2)=pizda(1,2)+pizda(2,1)
7598               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7599      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7600      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7601             enddo
7602           enddo
7603         enddo
7604 cd        goto 1112
7605 C Contribution from graph IV
7606 1110    continue
7607         call transpose2(EE(1,1,itj),auxmat(1,1))
7608         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7609         vv(1)=pizda(1,1)+pizda(2,2)
7610         vv(2)=pizda(2,1)-pizda(1,2)
7611         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7612      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7613 C Explicit gradient in virtual-dihedral angles.
7614         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7615      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7616         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7617         vv(1)=pizda(1,1)+pizda(2,2)
7618         vv(2)=pizda(2,1)-pizda(1,2)
7619         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7620      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7621      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7622 C Cartesian gradient
7623         do iii=1,2
7624           do kkk=1,5
7625             do lll=1,3
7626               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7627      &          pizda(1,1))
7628               vv(1)=pizda(1,1)+pizda(2,2)
7629               vv(2)=pizda(2,1)-pizda(1,2)
7630               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7631      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7632      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7633             enddo
7634           enddo
7635         enddo
7636       endif
7637 1112  continue
7638       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7639 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7640 cd        write (2,*) 'ijkl',i,j,k,l
7641 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7642 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7643 cd      endif
7644 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7645 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7646 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7647 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7648       if (j.lt.nres-1) then
7649         j1=j+1
7650         j2=j-1
7651       else
7652         j1=j-1
7653         j2=j-2
7654       endif
7655       if (l.lt.nres-1) then
7656         l1=l+1
7657         l2=l-1
7658       else
7659         l1=l-1
7660         l2=l-2
7661       endif
7662 cd      eij=1.0d0
7663 cd      ekl=1.0d0
7664 cd      ekont=1.0d0
7665 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7666 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7667 C        summed up outside the subrouine as for the other subroutines
7668 C        handling long-range interactions. The old code is commented out
7669 C        with "cgrad" to keep track of changes.
7670       do ll=1,3
7671 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7672 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7673         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7674         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7675 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7676 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7677 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7678 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7679 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7680 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7681 c     &   gradcorr5ij,
7682 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7683 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7684 cgrad        ghalf=0.5d0*ggg1(ll)
7685 cd        ghalf=0.0d0
7686         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7687         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7688         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7689         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7690         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7691         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7692 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7693 cgrad        ghalf=0.5d0*ggg2(ll)
7694 cd        ghalf=0.0d0
7695         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7696         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7697         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7698         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7699         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7700         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7701       enddo
7702 cd      goto 1112
7703 cgrad      do m=i+1,j-1
7704 cgrad        do ll=1,3
7705 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7706 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7707 cgrad        enddo
7708 cgrad      enddo
7709 cgrad      do m=k+1,l-1
7710 cgrad        do ll=1,3
7711 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7712 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7713 cgrad        enddo
7714 cgrad      enddo
7715 c1112  continue
7716 cgrad      do m=i+2,j2
7717 cgrad        do ll=1,3
7718 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7719 cgrad        enddo
7720 cgrad      enddo
7721 cgrad      do m=k+2,l2
7722 cgrad        do ll=1,3
7723 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7724 cgrad        enddo
7725 cgrad      enddo
7726 cd      do iii=1,nres-3
7727 cd        write (2,*) iii,g_corr5_loc(iii)
7728 cd      enddo
7729       eello5=ekont*eel5
7730 cd      write (2,*) 'ekont',ekont
7731 cd      write (iout,*) 'eello5',ekont*eel5
7732       return
7733       end
7734 c--------------------------------------------------------------------------
7735       double precision function eello6(i,j,k,l,jj,kk)
7736       implicit real*8 (a-h,o-z)
7737       include 'DIMENSIONS'
7738       include 'COMMON.IOUNITS'
7739       include 'COMMON.CHAIN'
7740       include 'COMMON.DERIV'
7741       include 'COMMON.INTERACT'
7742       include 'COMMON.CONTACTS'
7743       include 'COMMON.TORSION'
7744       include 'COMMON.VAR'
7745       include 'COMMON.GEO'
7746       include 'COMMON.FFIELD'
7747       double precision ggg1(3),ggg2(3)
7748 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7749 cd        eello6=0.0d0
7750 cd        return
7751 cd      endif
7752 cd      write (iout,*)
7753 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7754 cd     &   ' and',k,l
7755       eello6_1=0.0d0
7756       eello6_2=0.0d0
7757       eello6_3=0.0d0
7758       eello6_4=0.0d0
7759       eello6_5=0.0d0
7760       eello6_6=0.0d0
7761 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7762 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7763       do iii=1,2
7764         do kkk=1,5
7765           do lll=1,3
7766             derx(lll,kkk,iii)=0.0d0
7767           enddo
7768         enddo
7769       enddo
7770 cd      eij=facont_hb(jj,i)
7771 cd      ekl=facont_hb(kk,k)
7772 cd      ekont=eij*ekl
7773 cd      eij=1.0d0
7774 cd      ekl=1.0d0
7775 cd      ekont=1.0d0
7776       if (l.eq.j+1) then
7777         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7778         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7779         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7780         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7781         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7782         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7783       else
7784         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7785         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7786         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7787         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7788         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7789           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7790         else
7791           eello6_5=0.0d0
7792         endif
7793         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7794       endif
7795 C If turn contributions are considered, they will be handled separately.
7796       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7797 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7798 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7799 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7800 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7801 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7802 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7803 cd      goto 1112
7804       if (j.lt.nres-1) then
7805         j1=j+1
7806         j2=j-1
7807       else
7808         j1=j-1
7809         j2=j-2
7810       endif
7811       if (l.lt.nres-1) then
7812         l1=l+1
7813         l2=l-1
7814       else
7815         l1=l-1
7816         l2=l-2
7817       endif
7818       do ll=1,3
7819 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7820 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7821 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7822 cgrad        ghalf=0.5d0*ggg1(ll)
7823 cd        ghalf=0.0d0
7824         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7825         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7826         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7827         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7828         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7829         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7830         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7831         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7832 cgrad        ghalf=0.5d0*ggg2(ll)
7833 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7834 cd        ghalf=0.0d0
7835         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7836         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7837         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7838         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7839         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7840         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7841       enddo
7842 cd      goto 1112
7843 cgrad      do m=i+1,j-1
7844 cgrad        do ll=1,3
7845 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7846 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7847 cgrad        enddo
7848 cgrad      enddo
7849 cgrad      do m=k+1,l-1
7850 cgrad        do ll=1,3
7851 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7852 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7853 cgrad        enddo
7854 cgrad      enddo
7855 cgrad1112  continue
7856 cgrad      do m=i+2,j2
7857 cgrad        do ll=1,3
7858 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7859 cgrad        enddo
7860 cgrad      enddo
7861 cgrad      do m=k+2,l2
7862 cgrad        do ll=1,3
7863 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7864 cgrad        enddo
7865 cgrad      enddo
7866 cd      do iii=1,nres-3
7867 cd        write (2,*) iii,g_corr6_loc(iii)
7868 cd      enddo
7869       eello6=ekont*eel6
7870 cd      write (2,*) 'ekont',ekont
7871 cd      write (iout,*) 'eello6',ekont*eel6
7872       return
7873       end
7874 c--------------------------------------------------------------------------
7875       double precision function eello6_graph1(i,j,k,l,imat,swap)
7876       implicit real*8 (a-h,o-z)
7877       include 'DIMENSIONS'
7878       include 'COMMON.IOUNITS'
7879       include 'COMMON.CHAIN'
7880       include 'COMMON.DERIV'
7881       include 'COMMON.INTERACT'
7882       include 'COMMON.CONTACTS'
7883       include 'COMMON.TORSION'
7884       include 'COMMON.VAR'
7885       include 'COMMON.GEO'
7886       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7887       logical swap
7888       logical lprn
7889       common /kutas/ lprn
7890 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7891 C                                                                              C
7892 C      Parallel       Antiparallel                                             C
7893 C                                                                              C
7894 C          o             o                                                     C
7895 C         /l\           /j\                                                    C
7896 C        /   \         /   \                                                   C
7897 C       /| o |         | o |\                                                  C
7898 C     \ j|/k\|  /   \  |/k\|l /                                                C
7899 C      \ /   \ /     \ /   \ /                                                 C
7900 C       o     o       o     o                                                  C
7901 C       i             i                                                        C
7902 C                                                                              C
7903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7904       itk=itortyp(itype(k))
7905       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7906       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7907       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7908       call transpose2(EUgC(1,1,k),auxmat(1,1))
7909       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7910       vv1(1)=pizda1(1,1)-pizda1(2,2)
7911       vv1(2)=pizda1(1,2)+pizda1(2,1)
7912       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7913       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7914       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7915       s5=scalar2(vv(1),Dtobr2(1,i))
7916 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7917       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7918       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7919      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7920      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7921      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7922      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7923      & +scalar2(vv(1),Dtobr2der(1,i)))
7924       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7925       vv1(1)=pizda1(1,1)-pizda1(2,2)
7926       vv1(2)=pizda1(1,2)+pizda1(2,1)
7927       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7928       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7929       if (l.eq.j+1) then
7930         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7931      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7932      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7933      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7934      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7935       else
7936         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7937      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7938      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7939      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7940      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7941       endif
7942       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7943       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7944       vv1(1)=pizda1(1,1)-pizda1(2,2)
7945       vv1(2)=pizda1(1,2)+pizda1(2,1)
7946       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7947      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7948      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7949      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7950       do iii=1,2
7951         if (swap) then
7952           ind=3-iii
7953         else
7954           ind=iii
7955         endif
7956         do kkk=1,5
7957           do lll=1,3
7958             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7959             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7960             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7961             call transpose2(EUgC(1,1,k),auxmat(1,1))
7962             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7963      &        pizda1(1,1))
7964             vv1(1)=pizda1(1,1)-pizda1(2,2)
7965             vv1(2)=pizda1(1,2)+pizda1(2,1)
7966             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7967             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7968      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7969             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7970      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7971             s5=scalar2(vv(1),Dtobr2(1,i))
7972             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7973           enddo
7974         enddo
7975       enddo
7976       return
7977       end
7978 c----------------------------------------------------------------------------
7979       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7980       implicit real*8 (a-h,o-z)
7981       include 'DIMENSIONS'
7982       include 'COMMON.IOUNITS'
7983       include 'COMMON.CHAIN'
7984       include 'COMMON.DERIV'
7985       include 'COMMON.INTERACT'
7986       include 'COMMON.CONTACTS'
7987       include 'COMMON.TORSION'
7988       include 'COMMON.VAR'
7989       include 'COMMON.GEO'
7990       logical swap
7991       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7992      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7993       logical lprn
7994       common /kutas/ lprn
7995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7996 C                                                                              C
7997 C      Parallel       Antiparallel                                             C
7998 C                                                                              C
7999 C          o             o                                                     C
8000 C     \   /l\           /j\   /                                                C
8001 C      \ /   \         /   \ /                                                 C
8002 C       o| o |         | o |o                                                  C
8003 C     \ j|/k\|      \  |/k\|l                                                  C
8004 C      \ /   \       \ /   \                                                   C
8005 C       o             o                                                        C
8006 C       i             i                                                        C
8007 C                                                                              C
8008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8009 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8010 C AL 7/4/01 s1 would occur in the sixth-order moment,
8011 C           but not in a cluster cumulant
8012 #ifdef MOMENT
8013       s1=dip(1,jj,i)*dip(1,kk,k)
8014 #endif
8015       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8016       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8017       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8018       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8019       call transpose2(EUg(1,1,k),auxmat(1,1))
8020       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8021       vv(1)=pizda(1,1)-pizda(2,2)
8022       vv(2)=pizda(1,2)+pizda(2,1)
8023       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8024 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8025 #ifdef MOMENT
8026       eello6_graph2=-(s1+s2+s3+s4)
8027 #else
8028       eello6_graph2=-(s2+s3+s4)
8029 #endif
8030 c      eello6_graph2=-s3
8031 C Derivatives in gamma(i-1)
8032       if (i.gt.1) then
8033 #ifdef MOMENT
8034         s1=dipderg(1,jj,i)*dip(1,kk,k)
8035 #endif
8036         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8037         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8038         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8039         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8040 #ifdef MOMENT
8041         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8042 #else
8043         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8044 #endif
8045 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8046       endif
8047 C Derivatives in gamma(k-1)
8048 #ifdef MOMENT
8049       s1=dip(1,jj,i)*dipderg(1,kk,k)
8050 #endif
8051       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8052       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8053       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8054       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8055       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8056       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8057       vv(1)=pizda(1,1)-pizda(2,2)
8058       vv(2)=pizda(1,2)+pizda(2,1)
8059       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8060 #ifdef MOMENT
8061       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8062 #else
8063       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8064 #endif
8065 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8066 C Derivatives in gamma(j-1) or gamma(l-1)
8067       if (j.gt.1) then
8068 #ifdef MOMENT
8069         s1=dipderg(3,jj,i)*dip(1,kk,k)
8070 #endif
8071         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8072         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8073         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8074         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8075         vv(1)=pizda(1,1)-pizda(2,2)
8076         vv(2)=pizda(1,2)+pizda(2,1)
8077         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8078 #ifdef MOMENT
8079         if (swap) then
8080           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8081         else
8082           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8083         endif
8084 #endif
8085         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8086 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8087       endif
8088 C Derivatives in gamma(l-1) or gamma(j-1)
8089       if (l.gt.1) then
8090 #ifdef MOMENT
8091         s1=dip(1,jj,i)*dipderg(3,kk,k)
8092 #endif
8093         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8094         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8095         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8096         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8097         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8098         vv(1)=pizda(1,1)-pizda(2,2)
8099         vv(2)=pizda(1,2)+pizda(2,1)
8100         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8101 #ifdef MOMENT
8102         if (swap) then
8103           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8104         else
8105           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8106         endif
8107 #endif
8108         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8109 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8110       endif
8111 C Cartesian derivatives.
8112       if (lprn) then
8113         write (2,*) 'In eello6_graph2'
8114         do iii=1,2
8115           write (2,*) 'iii=',iii
8116           do kkk=1,5
8117             write (2,*) 'kkk=',kkk
8118             do jjj=1,2
8119               write (2,'(3(2f10.5),5x)')
8120      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8121             enddo
8122           enddo
8123         enddo
8124       endif
8125       do iii=1,2
8126         do kkk=1,5
8127           do lll=1,3
8128 #ifdef MOMENT
8129             if (iii.eq.1) then
8130               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8131             else
8132               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8133             endif
8134 #endif
8135             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8136      &        auxvec(1))
8137             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8138             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8139      &        auxvec(1))
8140             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8141             call transpose2(EUg(1,1,k),auxmat(1,1))
8142             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8143      &        pizda(1,1))
8144             vv(1)=pizda(1,1)-pizda(2,2)
8145             vv(2)=pizda(1,2)+pizda(2,1)
8146             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8147 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8148 #ifdef MOMENT
8149             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8150 #else
8151             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8152 #endif
8153             if (swap) then
8154               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8155             else
8156               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8157             endif
8158           enddo
8159         enddo
8160       enddo
8161       return
8162       end
8163 c----------------------------------------------------------------------------
8164       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8165       implicit real*8 (a-h,o-z)
8166       include 'DIMENSIONS'
8167       include 'COMMON.IOUNITS'
8168       include 'COMMON.CHAIN'
8169       include 'COMMON.DERIV'
8170       include 'COMMON.INTERACT'
8171       include 'COMMON.CONTACTS'
8172       include 'COMMON.TORSION'
8173       include 'COMMON.VAR'
8174       include 'COMMON.GEO'
8175       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8176       logical swap
8177 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8178 C                                                                              C
8179 C      Parallel       Antiparallel                                             C
8180 C                                                                              C
8181 C          o             o                                                     C
8182 C         /l\   /   \   /j\                                                    C
8183 C        /   \ /     \ /   \                                                   C
8184 C       /| o |o       o| o |\                                                  C
8185 C       j|/k\|  /      |/k\|l /                                                C
8186 C        /   \ /       /   \ /                                                 C
8187 C       /     o       /     o                                                  C
8188 C       i             i                                                        C
8189 C                                                                              C
8190 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8191 C
8192 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8193 C           energy moment and not to the cluster cumulant.
8194       iti=itortyp(itype(i))
8195       if (j.lt.nres-1) then
8196         itj1=itortyp(itype(j+1))
8197       else
8198         itj1=ntortyp+1
8199       endif
8200       itk=itortyp(itype(k))
8201       itk1=itortyp(itype(k+1))
8202       if (l.lt.nres-1) then
8203         itl1=itortyp(itype(l+1))
8204       else
8205         itl1=ntortyp+1
8206       endif
8207 #ifdef MOMENT
8208       s1=dip(4,jj,i)*dip(4,kk,k)
8209 #endif
8210       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8211       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8212       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8213       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8214       call transpose2(EE(1,1,itk),auxmat(1,1))
8215       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8216       vv(1)=pizda(1,1)+pizda(2,2)
8217       vv(2)=pizda(2,1)-pizda(1,2)
8218       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8219 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8220 cd     & "sum",-(s2+s3+s4)
8221 #ifdef MOMENT
8222       eello6_graph3=-(s1+s2+s3+s4)
8223 #else
8224       eello6_graph3=-(s2+s3+s4)
8225 #endif
8226 c      eello6_graph3=-s4
8227 C Derivatives in gamma(k-1)
8228       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8229       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8230       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8231       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8232 C Derivatives in gamma(l-1)
8233       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8234       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8235       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8236       vv(1)=pizda(1,1)+pizda(2,2)
8237       vv(2)=pizda(2,1)-pizda(1,2)
8238       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8239       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8240 C Cartesian derivatives.
8241       do iii=1,2
8242         do kkk=1,5
8243           do lll=1,3
8244 #ifdef MOMENT
8245             if (iii.eq.1) then
8246               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8247             else
8248               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8249             endif
8250 #endif
8251             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8252      &        auxvec(1))
8253             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8254             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8255      &        auxvec(1))
8256             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8257             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8258      &        pizda(1,1))
8259             vv(1)=pizda(1,1)+pizda(2,2)
8260             vv(2)=pizda(2,1)-pizda(1,2)
8261             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8262 #ifdef MOMENT
8263             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8264 #else
8265             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8266 #endif
8267             if (swap) then
8268               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8269             else
8270               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8271             endif
8272 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8273           enddo
8274         enddo
8275       enddo
8276       return
8277       end
8278 c----------------------------------------------------------------------------
8279       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8280       implicit real*8 (a-h,o-z)
8281       include 'DIMENSIONS'
8282       include 'COMMON.IOUNITS'
8283       include 'COMMON.CHAIN'
8284       include 'COMMON.DERIV'
8285       include 'COMMON.INTERACT'
8286       include 'COMMON.CONTACTS'
8287       include 'COMMON.TORSION'
8288       include 'COMMON.VAR'
8289       include 'COMMON.GEO'
8290       include 'COMMON.FFIELD'
8291       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8292      & auxvec1(2),auxmat1(2,2)
8293       logical swap
8294 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8295 C                                                                              C
8296 C      Parallel       Antiparallel                                             C
8297 C                                                                              C
8298 C          o             o                                                     C
8299 C         /l\   /   \   /j\                                                    C
8300 C        /   \ /     \ /   \                                                   C
8301 C       /| o |o       o| o |\                                                  C
8302 C     \ j|/k\|      \  |/k\|l                                                  C
8303 C      \ /   \       \ /   \                                                   C
8304 C       o     \       o     \                                                  C
8305 C       i             i                                                        C
8306 C                                                                              C
8307 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8308 C
8309 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8310 C           energy moment and not to the cluster cumulant.
8311 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8312       iti=itortyp(itype(i))
8313       itj=itortyp(itype(j))
8314       if (j.lt.nres-1) then
8315         itj1=itortyp(itype(j+1))
8316       else
8317         itj1=ntortyp+1
8318       endif
8319       itk=itortyp(itype(k))
8320       if (k.lt.nres-1) then
8321         itk1=itortyp(itype(k+1))
8322       else
8323         itk1=ntortyp+1
8324       endif
8325       itl=itortyp(itype(l))
8326       if (l.lt.nres-1) then
8327         itl1=itortyp(itype(l+1))
8328       else
8329         itl1=ntortyp+1
8330       endif
8331 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8332 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8333 cd     & ' itl',itl,' itl1',itl1
8334 #ifdef MOMENT
8335       if (imat.eq.1) then
8336         s1=dip(3,jj,i)*dip(3,kk,k)
8337       else
8338         s1=dip(2,jj,j)*dip(2,kk,l)
8339       endif
8340 #endif
8341       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8342       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8343       if (j.eq.l+1) then
8344         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8345         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8346       else
8347         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8348         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8349       endif
8350       call transpose2(EUg(1,1,k),auxmat(1,1))
8351       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8352       vv(1)=pizda(1,1)-pizda(2,2)
8353       vv(2)=pizda(2,1)+pizda(1,2)
8354       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8355 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8356 #ifdef MOMENT
8357       eello6_graph4=-(s1+s2+s3+s4)
8358 #else
8359       eello6_graph4=-(s2+s3+s4)
8360 #endif
8361 C Derivatives in gamma(i-1)
8362       if (i.gt.1) then
8363 #ifdef MOMENT
8364         if (imat.eq.1) then
8365           s1=dipderg(2,jj,i)*dip(3,kk,k)
8366         else
8367           s1=dipderg(4,jj,j)*dip(2,kk,l)
8368         endif
8369 #endif
8370         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8371         if (j.eq.l+1) then
8372           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8373           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8374         else
8375           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8376           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8377         endif
8378         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8379         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8380 cd          write (2,*) 'turn6 derivatives'
8381 #ifdef MOMENT
8382           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8383 #else
8384           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8385 #endif
8386         else
8387 #ifdef MOMENT
8388           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8389 #else
8390           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8391 #endif
8392         endif
8393       endif
8394 C Derivatives in gamma(k-1)
8395 #ifdef MOMENT
8396       if (imat.eq.1) then
8397         s1=dip(3,jj,i)*dipderg(2,kk,k)
8398       else
8399         s1=dip(2,jj,j)*dipderg(4,kk,l)
8400       endif
8401 #endif
8402       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8403       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8404       if (j.eq.l+1) then
8405         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8406         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8407       else
8408         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8409         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8410       endif
8411       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8412       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8413       vv(1)=pizda(1,1)-pizda(2,2)
8414       vv(2)=pizda(2,1)+pizda(1,2)
8415       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8416       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8417 #ifdef MOMENT
8418         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8419 #else
8420         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8421 #endif
8422       else
8423 #ifdef MOMENT
8424         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8425 #else
8426         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8427 #endif
8428       endif
8429 C Derivatives in gamma(j-1) or gamma(l-1)
8430       if (l.eq.j+1 .and. l.gt.1) then
8431         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8432         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8433         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8434         vv(1)=pizda(1,1)-pizda(2,2)
8435         vv(2)=pizda(2,1)+pizda(1,2)
8436         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8437         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8438       else if (j.gt.1) then
8439         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8440         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8441         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8442         vv(1)=pizda(1,1)-pizda(2,2)
8443         vv(2)=pizda(2,1)+pizda(1,2)
8444         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8445         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8446           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8447         else
8448           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8449         endif
8450       endif
8451 C Cartesian derivatives.
8452       do iii=1,2
8453         do kkk=1,5
8454           do lll=1,3
8455 #ifdef MOMENT
8456             if (iii.eq.1) then
8457               if (imat.eq.1) then
8458                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8459               else
8460                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8461               endif
8462             else
8463               if (imat.eq.1) then
8464                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8465               else
8466                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8467               endif
8468             endif
8469 #endif
8470             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8471      &        auxvec(1))
8472             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8473             if (j.eq.l+1) then
8474               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8475      &          b1(1,itj1),auxvec(1))
8476               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8477             else
8478               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8479      &          b1(1,itl1),auxvec(1))
8480               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8481             endif
8482             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8483      &        pizda(1,1))
8484             vv(1)=pizda(1,1)-pizda(2,2)
8485             vv(2)=pizda(2,1)+pizda(1,2)
8486             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8487             if (swap) then
8488               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8489 #ifdef MOMENT
8490                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8491      &             -(s1+s2+s4)
8492 #else
8493                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8494      &             -(s2+s4)
8495 #endif
8496                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8497               else
8498 #ifdef MOMENT
8499                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8500 #else
8501                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8502 #endif
8503                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8504               endif
8505             else
8506 #ifdef MOMENT
8507               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8508 #else
8509               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8510 #endif
8511               if (l.eq.j+1) then
8512                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8513               else
8514                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8515               endif
8516             endif
8517           enddo
8518         enddo
8519       enddo
8520       return
8521       end
8522 c----------------------------------------------------------------------------
8523       double precision function eello_turn6(i,jj,kk)
8524       implicit real*8 (a-h,o-z)
8525       include 'DIMENSIONS'
8526       include 'COMMON.IOUNITS'
8527       include 'COMMON.CHAIN'
8528       include 'COMMON.DERIV'
8529       include 'COMMON.INTERACT'
8530       include 'COMMON.CONTACTS'
8531       include 'COMMON.TORSION'
8532       include 'COMMON.VAR'
8533       include 'COMMON.GEO'
8534       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8535      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8536      &  ggg1(3),ggg2(3)
8537       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8538      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8539 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8540 C           the respective energy moment and not to the cluster cumulant.
8541       s1=0.0d0
8542       s8=0.0d0
8543       s13=0.0d0
8544 c
8545       eello_turn6=0.0d0
8546       j=i+4
8547       k=i+1
8548       l=i+3
8549       iti=itortyp(itype(i))
8550       itk=itortyp(itype(k))
8551       itk1=itortyp(itype(k+1))
8552       itl=itortyp(itype(l))
8553       itj=itortyp(itype(j))
8554 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8555 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8556 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8557 cd        eello6=0.0d0
8558 cd        return
8559 cd      endif
8560 cd      write (iout,*)
8561 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8562 cd     &   ' and',k,l
8563 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8564       do iii=1,2
8565         do kkk=1,5
8566           do lll=1,3
8567             derx_turn(lll,kkk,iii)=0.0d0
8568           enddo
8569         enddo
8570       enddo
8571 cd      eij=1.0d0
8572 cd      ekl=1.0d0
8573 cd      ekont=1.0d0
8574       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8575 cd      eello6_5=0.0d0
8576 cd      write (2,*) 'eello6_5',eello6_5
8577 #ifdef MOMENT
8578       call transpose2(AEA(1,1,1),auxmat(1,1))
8579       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8580       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8581       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8582 #endif
8583       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8584       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8585       s2 = scalar2(b1(1,itk),vtemp1(1))
8586 #ifdef MOMENT
8587       call transpose2(AEA(1,1,2),atemp(1,1))
8588       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8589       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8590       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8591 #endif
8592       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8593       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8594       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8595 #ifdef MOMENT
8596       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8597       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8598       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8599       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8600       ss13 = scalar2(b1(1,itk),vtemp4(1))
8601       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8602 #endif
8603 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8604 c      s1=0.0d0
8605 c      s2=0.0d0
8606 c      s8=0.0d0
8607 c      s12=0.0d0
8608 c      s13=0.0d0
8609       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8610 C Derivatives in gamma(i+2)
8611       s1d =0.0d0
8612       s8d =0.0d0
8613 #ifdef MOMENT
8614       call transpose2(AEA(1,1,1),auxmatd(1,1))
8615       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8616       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8617       call transpose2(AEAderg(1,1,2),atempd(1,1))
8618       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8619       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8620 #endif
8621       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8622       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8623       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8624 c      s1d=0.0d0
8625 c      s2d=0.0d0
8626 c      s8d=0.0d0
8627 c      s12d=0.0d0
8628 c      s13d=0.0d0
8629       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8630 C Derivatives in gamma(i+3)
8631 #ifdef MOMENT
8632       call transpose2(AEA(1,1,1),auxmatd(1,1))
8633       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8634       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8635       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8636 #endif
8637       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8638       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8639       s2d = scalar2(b1(1,itk),vtemp1d(1))
8640 #ifdef MOMENT
8641       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8642       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8643 #endif
8644       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8645 #ifdef MOMENT
8646       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8647       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8648       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8649 #endif
8650 c      s1d=0.0d0
8651 c      s2d=0.0d0
8652 c      s8d=0.0d0
8653 c      s12d=0.0d0
8654 c      s13d=0.0d0
8655 #ifdef MOMENT
8656       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8657      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8658 #else
8659       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8660      &               -0.5d0*ekont*(s2d+s12d)
8661 #endif
8662 C Derivatives in gamma(i+4)
8663       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8664       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8665       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8666 #ifdef MOMENT
8667       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8668       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8669       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8670 #endif
8671 c      s1d=0.0d0
8672 c      s2d=0.0d0
8673 c      s8d=0.0d0
8674 C      s12d=0.0d0
8675 c      s13d=0.0d0
8676 #ifdef MOMENT
8677       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8678 #else
8679       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8680 #endif
8681 C Derivatives in gamma(i+5)
8682 #ifdef MOMENT
8683       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8684       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8685       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8686 #endif
8687       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8688       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8689       s2d = scalar2(b1(1,itk),vtemp1d(1))
8690 #ifdef MOMENT
8691       call transpose2(AEA(1,1,2),atempd(1,1))
8692       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8693       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8694 #endif
8695       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8696       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8697 #ifdef MOMENT
8698       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8699       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8700       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8701 #endif
8702 c      s1d=0.0d0
8703 c      s2d=0.0d0
8704 c      s8d=0.0d0
8705 c      s12d=0.0d0
8706 c      s13d=0.0d0
8707 #ifdef MOMENT
8708       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8709      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8710 #else
8711       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8712      &               -0.5d0*ekont*(s2d+s12d)
8713 #endif
8714 C Cartesian derivatives
8715       do iii=1,2
8716         do kkk=1,5
8717           do lll=1,3
8718 #ifdef MOMENT
8719             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8720             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8721             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8722 #endif
8723             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8724             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8725      &          vtemp1d(1))
8726             s2d = scalar2(b1(1,itk),vtemp1d(1))
8727 #ifdef MOMENT
8728             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8729             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8730             s8d = -(atempd(1,1)+atempd(2,2))*
8731      &           scalar2(cc(1,1,itl),vtemp2(1))
8732 #endif
8733             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8734      &           auxmatd(1,1))
8735             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8736             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8737 c      s1d=0.0d0
8738 c      s2d=0.0d0
8739 c      s8d=0.0d0
8740 c      s12d=0.0d0
8741 c      s13d=0.0d0
8742 #ifdef MOMENT
8743             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8744      &        - 0.5d0*(s1d+s2d)
8745 #else
8746             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8747      &        - 0.5d0*s2d
8748 #endif
8749 #ifdef MOMENT
8750             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8751      &        - 0.5d0*(s8d+s12d)
8752 #else
8753             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8754      &        - 0.5d0*s12d
8755 #endif
8756           enddo
8757         enddo
8758       enddo
8759 #ifdef MOMENT
8760       do kkk=1,5
8761         do lll=1,3
8762           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8763      &      achuj_tempd(1,1))
8764           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8765           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8766           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8767           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8768           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8769      &      vtemp4d(1))
8770           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8771           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8772           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8773         enddo
8774       enddo
8775 #endif
8776 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8777 cd     &  16*eel_turn6_num
8778 cd      goto 1112
8779       if (j.lt.nres-1) then
8780         j1=j+1
8781         j2=j-1
8782       else
8783         j1=j-1
8784         j2=j-2
8785       endif
8786       if (l.lt.nres-1) then
8787         l1=l+1
8788         l2=l-1
8789       else
8790         l1=l-1
8791         l2=l-2
8792       endif
8793       do ll=1,3
8794 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8795 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8796 cgrad        ghalf=0.5d0*ggg1(ll)
8797 cd        ghalf=0.0d0
8798         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8799         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8800         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8801      &    +ekont*derx_turn(ll,2,1)
8802         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8803         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8804      &    +ekont*derx_turn(ll,4,1)
8805         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8806         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8807         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8808 cgrad        ghalf=0.5d0*ggg2(ll)
8809 cd        ghalf=0.0d0
8810         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8811      &    +ekont*derx_turn(ll,2,2)
8812         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8813         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8814      &    +ekont*derx_turn(ll,4,2)
8815         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8816         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8817         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8818       enddo
8819 cd      goto 1112
8820 cgrad      do m=i+1,j-1
8821 cgrad        do ll=1,3
8822 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8823 cgrad        enddo
8824 cgrad      enddo
8825 cgrad      do m=k+1,l-1
8826 cgrad        do ll=1,3
8827 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8828 cgrad        enddo
8829 cgrad      enddo
8830 cgrad1112  continue
8831 cgrad      do m=i+2,j2
8832 cgrad        do ll=1,3
8833 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8834 cgrad        enddo
8835 cgrad      enddo
8836 cgrad      do m=k+2,l2
8837 cgrad        do ll=1,3
8838 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8839 cgrad        enddo
8840 cgrad      enddo
8841 cd      do iii=1,nres-3
8842 cd        write (2,*) iii,g_corr6_loc(iii)
8843 cd      enddo
8844       eello_turn6=ekont*eel_turn6
8845 cd      write (2,*) 'ekont',ekont
8846 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8847       return
8848       end
8849
8850 C-----------------------------------------------------------------------------
8851       double precision function scalar(u,v)
8852 !DIR$ INLINEALWAYS scalar
8853 #ifndef OSF
8854 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8855 #endif
8856       implicit none
8857       double precision u(3),v(3)
8858 cd      double precision sc
8859 cd      integer i
8860 cd      sc=0.0d0
8861 cd      do i=1,3
8862 cd        sc=sc+u(i)*v(i)
8863 cd      enddo
8864 cd      scalar=sc
8865
8866       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8867       return
8868       end
8869 crc-------------------------------------------------
8870       SUBROUTINE MATVEC2(A1,V1,V2)
8871 !DIR$ INLINEALWAYS MATVEC2
8872 #ifndef OSF
8873 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8874 #endif
8875       implicit real*8 (a-h,o-z)
8876       include 'DIMENSIONS'
8877       DIMENSION A1(2,2),V1(2),V2(2)
8878 c      DO 1 I=1,2
8879 c        VI=0.0
8880 c        DO 3 K=1,2
8881 c    3     VI=VI+A1(I,K)*V1(K)
8882 c        Vaux(I)=VI
8883 c    1 CONTINUE
8884
8885       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8886       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8887
8888       v2(1)=vaux1
8889       v2(2)=vaux2
8890       END
8891 C---------------------------------------
8892       SUBROUTINE MATMAT2(A1,A2,A3)
8893 #ifndef OSF
8894 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8895 #endif
8896       implicit real*8 (a-h,o-z)
8897       include 'DIMENSIONS'
8898       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8899 c      DIMENSION AI3(2,2)
8900 c        DO  J=1,2
8901 c          A3IJ=0.0
8902 c          DO K=1,2
8903 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8904 c          enddo
8905 c          A3(I,J)=A3IJ
8906 c       enddo
8907 c      enddo
8908
8909       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8910       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8911       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8912       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8913
8914       A3(1,1)=AI3_11
8915       A3(2,1)=AI3_21
8916       A3(1,2)=AI3_12
8917       A3(2,2)=AI3_22
8918       END
8919
8920 c-------------------------------------------------------------------------
8921       double precision function scalar2(u,v)
8922 !DIR$ INLINEALWAYS scalar2
8923       implicit none
8924       double precision u(2),v(2)
8925       double precision sc
8926       integer i
8927       scalar2=u(1)*v(1)+u(2)*v(2)
8928       return
8929       end
8930
8931 C-----------------------------------------------------------------------------
8932
8933       subroutine transpose2(a,at)
8934 !DIR$ INLINEALWAYS transpose2
8935 #ifndef OSF
8936 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8937 #endif
8938       implicit none
8939       double precision a(2,2),at(2,2)
8940       at(1,1)=a(1,1)
8941       at(1,2)=a(2,1)
8942       at(2,1)=a(1,2)
8943       at(2,2)=a(2,2)
8944       return
8945       end
8946 c--------------------------------------------------------------------------
8947       subroutine transpose(n,a,at)
8948       implicit none
8949       integer n,i,j
8950       double precision a(n,n),at(n,n)
8951       do i=1,n
8952         do j=1,n
8953           at(j,i)=a(i,j)
8954         enddo
8955       enddo
8956       return
8957       end
8958 C---------------------------------------------------------------------------
8959       subroutine prodmat3(a1,a2,kk,transp,prod)
8960 !DIR$ INLINEALWAYS prodmat3
8961 #ifndef OSF
8962 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8963 #endif
8964       implicit none
8965       integer i,j
8966       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8967       logical transp
8968 crc      double precision auxmat(2,2),prod_(2,2)
8969
8970       if (transp) then
8971 crc        call transpose2(kk(1,1),auxmat(1,1))
8972 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8973 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8974
8975            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8976      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8977            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8978      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8979            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8980      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8981            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8982      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8983
8984       else
8985 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8986 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8987
8988            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8989      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8990            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8991      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8992            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8993      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8994            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8995      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8996
8997       endif
8998 c      call transpose2(a2(1,1),a2t(1,1))
8999
9000 crc      print *,transp
9001 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9002 crc      print *,((prod(i,j),i=1,2),j=1,2)
9003
9004       return
9005       end
9006