source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c    Here are the energies showed per procesor if the are more processors
 305 c    per molecule then we sum it up in sum_energy subroutine
 306 c      print *," Processor",myrank," calls SUM_ENERGY"
 307       call sum_energy(energia,.true.)
 308       if (dyn_ss) call dyn_set_nss
 309 c      print *," Processor",myrank," left SUM_ENERGY"
 310 #ifdef TIMING
 311       time_sumene=time_sumene+MPI_Wtime()-time00
 312 #endif
 313       return
 314       end
 315 c-------------------------------------------------------------------------------
 316       subroutine sum_energy(energia,reduce)
 317       implicit real*8 (a-h,o-z)
 318       include 'DIMENSIONS'
 319 #ifndef ISNAN
 320       external proc_proc
 321 #ifdef WINPGI
 322 cMS$ATTRIBUTES C ::  proc_proc
 323 #endif
 324 #endif
 325 #ifdef MPI
 326       include "mpif.h"
 327 #endif
 328       include 'COMMON.SETUP'
 329       include 'COMMON.IOUNITS'
 330       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 331       include 'COMMON.FFIELD'
 332       include 'COMMON.DERIV'
 333       include 'COMMON.INTERACT'
 334       include 'COMMON.SBRIDGE'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.VAR'
 337       include 'COMMON.CONTROL'
 338       include 'COMMON.TIME1'
 339       logical reduce
 340 #ifdef MPI
 341       if (nfgtasks.gt.1 .and. reduce) then
 342 #ifdef DEBUG
 343         write (iout,*) "energies before REDUCE"
 344         call enerprint(energia)
 345         call flush(iout)
 346 #endif
 347         do i=0,n_ene
 348           enebuff(i)=energia(i)
 349         enddo
 350         time00=MPI_Wtime()
 351         call MPI_Barrier(FG_COMM,IERR)
 352         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 353         time00=MPI_Wtime()
 354         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 355      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 356 #ifdef DEBUG
 357         write (iout,*) "energies after REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         time_Reduce=time_Reduce+MPI_Wtime()-time00
 362       endif
 363       if (fg_rank.eq.0) then
 364 #endif
 365       evdw=energia(1)
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 446 #endif
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460       time01=MPI_Wtime()
 461 #endif
 462 #ifdef DEBUG
 463       write (iout,*) "sum_gradient gvdwc, gvdwx"
 464       do i=1,nres
 465         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 466      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 467       enddo
 468       call flush(iout)
 469 #endif
 470 #ifdef MPI
 471 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 472         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 473      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 474 #endif
 475 C
 476 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 477 C            in virtual-bond-vector coordinates
 478 C
 479 #ifdef DEBUG
 480 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 483 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 484 c      enddo
 485 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 488 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 489 c      enddo
 490       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 491       do i=1,nres
 492         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 493      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 494      &   g_corr5_loc(i)
 495       enddo
 496       call flush(iout)
 497 #endif
 498 #ifdef SPLITELE
 499       do i=1,nct
 500         do j=1,3
 501           gradbufc(j,i)=wsc*gvdwc(j,i)+
 502      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 503      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 504      &                wel_loc*gel_loc_long(j,i)+
 505      &                wcorr*gradcorr_long(j,i)+
 506      &                wcorr5*gradcorr5_long(j,i)+
 507      &                wcorr6*gradcorr6_long(j,i)+
 508      &                wturn6*gcorr6_turn_long(j,i)+
 509      &                wstrain*ghpbc(j,i)
 510         enddo
 511       enddo
 512 #else
 513       do i=1,nct
 514         do j=1,3
 515           gradbufc(j,i)=wsc*gvdwc(j,i)+
 516      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 517      &                welec*gelc_long(j,i)+
 518      &                wbond*gradb(j,i)+
 519      &                wel_loc*gel_loc_long(j,i)+
 520      &                wcorr*gradcorr_long(j,i)+
 521      &                wcorr5*gradcorr5_long(j,i)+
 522      &                wcorr6*gradcorr6_long(j,i)+
 523      &                wturn6*gcorr6_turn_long(j,i)+
 524      &                wstrain*ghpbc(j,i)
 525         enddo
 526       enddo
 527 #endif
 528 #ifdef MPI
 529       if (nfgtasks.gt.1) then
 530       time00=MPI_Wtime()
 531 #ifdef DEBUG
 532       write (iout,*) "gradbufc before allreduce"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538       do i=1,nres
 539         do j=1,3
 540           gradbufc_sum(j,i)=gradbufc(j,i)
 541         enddo
 542       enddo
 543 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 544 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 545 c      time_reduce=time_reduce+MPI_Wtime()-time00
 546 #ifdef DEBUG
 547 c      write (iout,*) "gradbufc_sum after allreduce"
 548 c      do i=1,nres
 549 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 550 c      enddo
 551 c      call flush(iout)
 552 #endif
 553 #ifdef TIMING
 554 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 555 #endif
 556       do i=nnt,nres
 557         do k=1,3
 558           gradbufc(k,i)=0.0d0
 559         enddo
 560       enddo
 561 #ifdef DEBUG
 562       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 563       write (iout,*) (i," jgrad_start",jgrad_start(i),
 564      &                  " jgrad_end  ",jgrad_end(i),
 565      &                  i=igrad_start,igrad_end)
 566 #endif
 567 c
 568 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 569 c do not parallelize this part.
 570 c
 571 c      do i=igrad_start,igrad_end
 572 c        do j=jgrad_start(i),jgrad_end(i)
 573 c          do k=1,3
 574 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 575 c          enddo
 576 c        enddo
 577 c      enddo
 578       do j=1,3
 579         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 580       enddo
 581       do i=nres-2,nnt,-1
 582         do j=1,3
 583           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 584         enddo
 585       enddo
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc after summing"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       else
 594 #endif
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       do i=1,nres
 603         do j=1,3
 604           gradbufc_sum(j,i)=gradbufc(j,i)
 605           gradbufc(j,i)=0.0d0
 606         enddo
 607       enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,nnt,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 c      do i=nnt,nres-1
 617 c        do k=1,3
 618 c          gradbufc(k,i)=0.0d0
 619 c        enddo
 620 c        do j=i+1,nres
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gloc after adding corr"
 704       do i=1,4*nres
 705         write (iout,*) i,gloc(i,icg)
 706       enddo
 707 #endif
 708 #ifdef MPI
 709       if (nfgtasks.gt.1) then
 710         do j=1,3
 711           do i=1,nres
 712             gradbufc(j,i)=gradc(j,i,icg)
 713             gradbufx(j,i)=gradx(j,i,icg)
 714           enddo
 715         enddo
 716         do i=1,4*nres
 717           glocbuf(i)=gloc(i,icg)
 718         enddo
 719 c#define DEBUG
 720 #ifdef DEBUG
 721       write (iout,*) "gloc_sc before reduce"
 722       do i=1,nres
 723        do j=1,1
 724         write (iout,*) i,j,gloc_sc(j,i,icg)
 725        enddo
 726       enddo
 727 #endif
 728 c#undef DEBUG
 729         do i=1,nres
 730          do j=1,3
 731           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 732          enddo
 733         enddo
 734         time00=MPI_Wtime()
 735         call MPI_Barrier(FG_COMM,IERR)
 736         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 737         time00=MPI_Wtime()
 738         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 739      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 740         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         time_reduce=time_reduce+MPI_Wtime()-time00
 745         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 746      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 747         time_reduce=time_reduce+MPI_Wtime()-time00
 748 c#define DEBUG
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc after reduce"
 751       do i=1,nres
 752        do j=1,1
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757 c#undef DEBUG
 758 #ifdef DEBUG
 759       write (iout,*) "gloc after reduce"
 760       do i=1,4*nres
 761         write (iout,*) i,gloc(i,icg)
 762       enddo
 763 #endif
 764       endif
 765 #endif
 766       if (gnorm_check) then
 767 c
 768 c Compute the maximum elements of the gradient
 769 c
 770       gvdwc_max=0.0d0
 771       gvdwc_scp_max=0.0d0
 772       gelc_max=0.0d0
 773       gvdwpp_max=0.0d0
 774       gradb_max=0.0d0
 775       ghpbc_max=0.0d0
 776       gradcorr_max=0.0d0
 777       gel_loc_max=0.0d0
 778       gcorr3_turn_max=0.0d0
 779       gcorr4_turn_max=0.0d0
 780       gradcorr5_max=0.0d0
 781       gradcorr6_max=0.0d0
 782       gcorr6_turn_max=0.0d0
 783       gsccorc_max=0.0d0
 784       gscloc_max=0.0d0
 785       gvdwx_max=0.0d0
 786       gradx_scp_max=0.0d0
 787       ghpbx_max=0.0d0
 788       gradxorr_max=0.0d0
 789       gsccorx_max=0.0d0
 790       gsclocx_max=0.0d0
 791       do i=1,nct
 792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 795         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 796      &   gvdwc_scp_max=gvdwc_scp_norm
 797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 810      &    gcorr3_turn(1,i)))
 811         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 812      &    gcorr3_turn_max=gcorr3_turn_norm
 813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 814      &    gcorr4_turn(1,i)))
 815         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 816      &    gcorr4_turn_max=gcorr4_turn_norm
 817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 818         if (gradcorr5_norm.gt.gradcorr5_max)
 819      &    gradcorr5_max=gradcorr5_norm
 820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 823      &    gcorr6_turn(1,i)))
 824         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 825      &    gcorr6_turn_max=gcorr6_turn_norm
 826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 833         if (gradx_scp_norm.gt.gradx_scp_max)
 834      &    gradx_scp_max=gradx_scp_norm
 835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 843       enddo
 844       if (gradout) then
 845 #ifdef AIX
 846         open(istat,file=statname,position="append")
 847 #else
 848         open(istat,file=statname,access="append")
 849 #endif
 850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 851      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 852      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 853      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 854      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 855      &     gsccorx_max,gsclocx_max
 856         close(istat)
 857         if (gvdwc_max.gt.1.0d4) then
 858           write (iout,*) "gvdwc gvdwx gradb gradbx"
 859           do i=nnt,nct
 860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 861      &        gradb(j,i),gradbx(j,i),j=1,3)
 862           enddo
 863           call pdbout(0.0d0,'cipiszcze',iout)
 864           call flush(iout)
 865         endif
 866       endif
 867       endif
 868 #ifdef DEBUG
 869       write (iout,*) "gradc gradx gloc"
 870       do i=1,nres
 871         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 872      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 873       enddo
 874 #endif
 875 #ifdef TIMING
 876       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 877 #endif
 878       return
 879       end
 880 c-------------------------------------------------------------------------------
 881       subroutine rescale_weights(t_bath)
 882       implicit real*8 (a-h,o-z)
 883       include 'DIMENSIONS'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.FFIELD'
 886       include 'COMMON.SBRIDGE'
 887       double precision kfac /2.4d0/
 888       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 889 c      facT=temp0/t_bath
 890 c      facT=2*temp0/(t_bath+temp0)
 891       if (rescale_mode.eq.0) then
 892         facT=1.0d0
 893         facT2=1.0d0
 894         facT3=1.0d0
 895         facT4=1.0d0
 896         facT5=1.0d0
 897       else if (rescale_mode.eq.1) then
 898         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 899         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 900         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 901         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 902         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 903       else if (rescale_mode.eq.2) then
 904         x=t_bath/temp0
 905         x2=x*x
 906         x3=x2*x
 907         x4=x3*x
 908         x5=x4*x
 909         facT=licznik/dlog(dexp(x)+dexp(-x))
 910         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 911         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 912         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 913         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 914       else
 915         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 916         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 917 #ifdef MPI
 918        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 919 #endif
 920        stop 555
 921       endif
 922       welec=weights(3)*fact
 923       wcorr=weights(4)*fact3
 924       wcorr5=weights(5)*fact4
 925       wcorr6=weights(6)*fact5
 926       wel_loc=weights(7)*fact2
 927       wturn3=weights(8)*fact2
 928       wturn4=weights(9)*fact3
 929       wturn6=weights(10)*fact5
 930       wtor=weights(13)*fact
 931       wtor_d=weights(14)*fact2
 932       wsccor=weights(21)*fact
 933
 934       return
 935       end
 936 C------------------------------------------------------------------------
 937       subroutine enerprint(energia)
 938       implicit real*8 (a-h,o-z)
 939       include 'DIMENSIONS'
 940       include 'COMMON.IOUNITS'
 941       include 'COMMON.FFIELD'
 942       include 'COMMON.SBRIDGE'
 943       include 'COMMON.MD'
 944       double precision energia(0:n_ene)
 945       etot=energia(0)
 946       evdw=energia(1)
 947       evdw2=energia(2)
 948 #ifdef SCP14
 949       evdw2=energia(2)+energia(18)
 950 #else
 951       evdw2=energia(2)
 952 #endif
 953       ees=energia(3)
 954 #ifdef SPLITELE
 955       evdw1=energia(16)
 956 #endif
 957       ecorr=energia(4)
 958       ecorr5=energia(5)
 959       ecorr6=energia(6)
 960       eel_loc=energia(7)
 961       eello_turn3=energia(8)
 962       eello_turn4=energia(9)
 963       eello_turn6=energia(10)
 964       ebe=energia(11)
 965       escloc=energia(12)
 966       etors=energia(13)
 967       etors_d=energia(14)
 968       ehpb=energia(15)
 969       edihcnstr=energia(19)
 970       estr=energia(17)
 971       Uconst=energia(20)
 972       esccor=energia(21)
 973 #ifdef SPLITELE
 974       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 975      &  estr,wbond,ebe,wang,
 976      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 977      &  ecorr,wcorr,
 978      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 979      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 980      &  edihcnstr,ebr*nss,
 981      &  Uconst,etot
 982    10 format (/'Virtual-chain energies:'//
 983      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 984      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 985      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 986      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 987      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 988      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 989      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 990      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 991      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 992      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 993      & ' (SS bridges & dist. cnstr.)'/
 994      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 998      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 999      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1000      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1001      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1002      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1003      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1004      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1005      & 'ETOT=  ',1pE16.6,' (total)')
1006 #else
1007       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1008      &  estr,wbond,ebe,wang,
1009      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1010      &  ecorr,wcorr,
1011      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1012      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1013      &  ebr*nss,Uconst,etot
1014    10 format (/'Virtual-chain energies:'//
1015      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1016      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1017      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1018      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1019      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1020      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1021      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1022      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1023      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1024      & ' (SS bridges & dist. cnstr.)'/
1025      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1029      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1030      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1031      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1032      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1033      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1034      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1035      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1036      & 'ETOT=  ',1pE16.6,' (total)')
1037 #endif
1038       return
1039       end
1040 C-----------------------------------------------------------------------
1041       subroutine elj(evdw)
1042 C
1043 C This subroutine calculates the interaction energy of nonbonded side chains
1044 C assuming the LJ potential of interaction.
1045 C
1046       implicit real*8 (a-h,o-z)
1047       include 'DIMENSIONS'
1048       parameter (accur=1.0d-10)
1049       include 'COMMON.GEO'
1050       include 'COMMON.VAR'
1051       include 'COMMON.LOCAL'
1052       include 'COMMON.CHAIN'
1053       include 'COMMON.DERIV'
1054       include 'COMMON.INTERACT'
1055       include 'COMMON.TORSION'
1056       include 'COMMON.SBRIDGE'
1057       include 'COMMON.NAMES'
1058       include 'COMMON.IOUNITS'
1059       include 'COMMON.CONTACTS'
1060       dimension gg(3)
1061 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 C Change 12/1/95
1071         num_conti=0
1072 C
1073 C Calculate SC interaction energy.
1074 C
1075         do iint=1,nint_gr(i)
1076 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1077 cd   &                  'iend=',iend(i,iint)
1078           do j=istart(i,iint),iend(i,iint)
1079             itypj=iabs(itype(j))
1080             if (itypj.eq.ntyp1) cycle
1081             xj=c(1,nres+j)-xi
1082             yj=c(2,nres+j)-yi
1083             zj=c(3,nres+j)-zi
1084 C Change 12/1/95 to calculate four-body interactions
1085             rij=xj*xj+yj*yj+zj*zj
1086             rrij=1.0D0/rij
1087 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1088             eps0ij=eps(itypi,itypj)
1089             fac=rrij**expon2
1090             e1=fac*fac*aa(itypi,itypj)
1091             e2=fac*bb(itypi,itypj)
1092             evdwij=e1+e2
1093 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1096 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1097 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1098 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1099             evdw=evdw+evdwij
1100 C
1101 C Calculate the components of the gradient in DC and X
1102 C
1103             fac=-rrij*(e1+evdwij)
1104             gg(1)=xj*fac
1105             gg(2)=yj*fac
1106             gg(3)=zj*fac
1107             do k=1,3
1108               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1109               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1110               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1111               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1112             enddo
1113 cgrad            do k=i,j-1
1114 cgrad              do l=1,3
1115 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1116 cgrad              enddo
1117 cgrad            enddo
1118 C
1119 C 12/1/95, revised on 5/20/97
1120 C
1121 C Calculate the contact function. The ith column of the array JCONT will
1122 C contain the numbers of atoms that make contacts with the atom I (of numbers
1123 C greater than I). The arrays FACONT and GACONT will contain the values of
1124 C the contact function and its derivative.
1125 C
1126 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1127 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1128 C Uncomment next line, if the correlation interactions are contact function only
1129             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1130               rij=dsqrt(rij)
1131               sigij=sigma(itypi,itypj)
1132               r0ij=rs0(itypi,itypj)
1133 C
1134 C Check whether the SC's are not too far to make a contact.
1135 C
1136               rcut=1.5d0*r0ij
1137               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1138 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1139 C
1140               if (fcont.gt.0.0D0) then
1141 C If the SC-SC distance if close to sigma, apply spline.
1142 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1143 cAdam &             fcont1,fprimcont1)
1144 cAdam           fcont1=1.0d0-fcont1
1145 cAdam           if (fcont1.gt.0.0d0) then
1146 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1147 cAdam             fcont=fcont*fcont1
1148 cAdam           endif
1149 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1150 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1151 cga             do k=1,3
1152 cga               gg(k)=gg(k)*eps0ij
1153 cga             enddo
1154 cga             eps0ij=-evdwij*eps0ij
1155 C Uncomment for AL's type of SC correlation interactions.
1156 cadam           eps0ij=-evdwij
1157                 num_conti=num_conti+1
1158                 jcont(num_conti,i)=j
1159                 facont(num_conti,i)=fcont*eps0ij
1160                 fprimcont=eps0ij*fprimcont/rij
1161                 fcont=expon*fcont
1162 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1163 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1164 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1165 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1166                 gacont(1,num_conti,i)=-fprimcont*xj
1167                 gacont(2,num_conti,i)=-fprimcont*yj
1168                 gacont(3,num_conti,i)=-fprimcont*zj
1169 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1170 cd              write (iout,'(2i3,3f10.5)')
1171 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1172               endif
1173             endif
1174           enddo      ! j
1175         enddo        ! iint
1176 C Change 12/1/95
1177         num_cont(i)=num_conti
1178       enddo          ! i
1179       do i=1,nct
1180         do j=1,3
1181           gvdwc(j,i)=expon*gvdwc(j,i)
1182           gvdwx(j,i)=expon*gvdwx(j,i)
1183         enddo
1184       enddo
1185 C******************************************************************************
1186 C
1187 C                              N O T E !!!
1188 C
1189 C To save time, the factor of EXPON has been extracted from ALL components
1190 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1191 C use!
1192 C
1193 C******************************************************************************
1194       return
1195       end
1196 C-----------------------------------------------------------------------------
1197       subroutine eljk(evdw)
1198 C
1199 C This subroutine calculates the interaction energy of nonbonded side chains
1200 C assuming the LJK potential of interaction.
1201 C
1202       implicit real*8 (a-h,o-z)
1203       include 'DIMENSIONS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.IOUNITS'
1211       include 'COMMON.NAMES'
1212       dimension gg(3)
1213       logical scheck
1214 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1215       evdw=0.0D0
1216       do i=iatsc_s,iatsc_e
1217         itypi=iabs(itype(i))
1218         if (itypi.eq.ntyp1) cycle
1219         itypi1=iabs(itype(i+1))
1220         xi=c(1,nres+i)
1221         yi=c(2,nres+i)
1222         zi=c(3,nres+i)
1223 C
1224 C Calculate SC interaction energy.
1225 C
1226         do iint=1,nint_gr(i)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             fac_augm=rrij**expon
1235             e_augm=augm(itypi,itypj)*fac_augm
1236             r_inv_ij=dsqrt(rrij)
1237             rij=1.0D0/r_inv_ij
1238             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1239             fac=r_shift_inv**expon
1240             e1=fac*fac*aa(itypi,itypj)
1241             e2=fac*bb(itypi,itypj)
1242             evdwij=e_augm+e1+e2
1243 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1247 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1248 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1249 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1250             evdw=evdw+evdwij
1251 C
1252 C Calculate the components of the gradient in DC and X
1253 C
1254             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1255             gg(1)=xj*fac
1256             gg(2)=yj*fac
1257             gg(3)=zj*fac
1258             do k=1,3
1259               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1260               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1261               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1262               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1263             enddo
1264 cgrad            do k=i,j-1
1265 cgrad              do l=1,3
1266 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1267 cgrad              enddo
1268 cgrad            enddo
1269           enddo      ! j
1270         enddo        ! iint
1271       enddo          ! i
1272       do i=1,nct
1273         do j=1,3
1274           gvdwc(j,i)=expon*gvdwc(j,i)
1275           gvdwx(j,i)=expon*gvdwx(j,i)
1276         enddo
1277       enddo
1278       return
1279       end
1280 C-----------------------------------------------------------------------------
1281       subroutine ebp(evdw)
1282 C
1283 C This subroutine calculates the interaction energy of nonbonded side chains
1284 C assuming the Berne-Pechukas potential of interaction.
1285 C
1286       implicit real*8 (a-h,o-z)
1287       include 'DIMENSIONS'
1288       include 'COMMON.GEO'
1289       include 'COMMON.VAR'
1290       include 'COMMON.LOCAL'
1291       include 'COMMON.CHAIN'
1292       include 'COMMON.DERIV'
1293       include 'COMMON.NAMES'
1294       include 'COMMON.INTERACT'
1295       include 'COMMON.IOUNITS'
1296       include 'COMMON.CALC'
1297       common /srutu/ icall
1298 c     double precision rrsave(maxdim)
1299       logical lprn
1300       evdw=0.0D0
1301 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1302       evdw=0.0D0
1303 c     if (icall.eq.0) then
1304 c       lprn=.true.
1305 c     else
1306         lprn=.false.
1307 c     endif
1308       ind=0
1309       do i=iatsc_s,iatsc_e
1310         itypi=iabs(itype(i))
1311         if (itypi.eq.ntyp1) cycle
1312         itypi1=iabs(itype(i+1))
1313         xi=c(1,nres+i)
1314         yi=c(2,nres+i)
1315         zi=c(3,nres+i)
1316         dxi=dc_norm(1,nres+i)
1317         dyi=dc_norm(2,nres+i)
1318         dzi=dc_norm(3,nres+i)
1319 c        dsci_inv=dsc_inv(itypi)
1320         dsci_inv=vbld_inv(i+nres)
1321 C
1322 C Calculate SC interaction energy.
1323 C
1324         do iint=1,nint_gr(i)
1325           do j=istart(i,iint),iend(i,iint)
1326             ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 c            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331             chi1=chi(itypi,itypj)
1332             chi2=chi(itypj,itypi)
1333             chi12=chi1*chi2
1334             chip1=chip(itypi)
1335             chip2=chip(itypj)
1336             chip12=chip1*chip2
1337             alf1=alp(itypi)
1338             alf2=alp(itypj)
1339             alf12=0.5D0*(alf1+alf2)
1340 C For diagnostics only!!!
1341 c           chi1=0.0D0
1342 c           chi2=0.0D0
1343 c           chi12=0.0D0
1344 c           chip1=0.0D0
1345 c           chip2=0.0D0
1346 c           chip12=0.0D0
1347 c           alf1=0.0D0
1348 c           alf2=0.0D0
1349 c           alf12=0.0D0
1350             xj=c(1,nres+j)-xi
1351             yj=c(2,nres+j)-yi
1352             zj=c(3,nres+j)-zi
1353             dxj=dc_norm(1,nres+j)
1354             dyj=dc_norm(2,nres+j)
1355             dzj=dc_norm(3,nres+j)
1356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1357 cd          if (icall.eq.0) then
1358 cd            rrsave(ind)=rrij
1359 cd          else
1360 cd            rrij=rrsave(ind)
1361 cd          endif
1362             rij=dsqrt(rrij)
1363 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1364             call sc_angular
1365 C Calculate whole angle-dependent part of epsilon and contributions
1366 C to its derivatives
1367             fac=(rrij*sigsq)**expon2
1368             e1=fac*fac*aa(itypi,itypj)
1369             e2=fac*bb(itypi,itypj)
1370             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1371             eps2der=evdwij*eps3rt
1372             eps3der=evdwij*eps2rt
1373             evdwij=evdwij*eps2rt*eps3rt
1374             evdw=evdw+evdwij
1375             if (lprn) then
1376             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1379 cd     &        restyp(itypi),i,restyp(itypj),j,
1380 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1381 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1382 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1383 cd     &        evdwij
1384             endif
1385 C Calculate gradient components.
1386             e1=e1*eps1*eps2rt**2*eps3rt**2
1387             fac=-expon*(e1+evdwij)
1388             sigder=fac/sigsq
1389             fac=rrij*fac
1390 C Calculate radial part of the gradient
1391             gg(1)=xj*fac
1392             gg(2)=yj*fac
1393             gg(3)=zj*fac
1394 C Calculate the angular part of the gradient and sum add the contributions
1395 C to the appropriate components of the Cartesian gradient.
1396             call sc_grad
1397           enddo      ! j
1398         enddo        ! iint
1399       enddo          ! i
1400 c     stop
1401       return
1402       end
1403 C-----------------------------------------------------------------------------
1404       subroutine egb(evdw)
1405 C
1406 C This subroutine calculates the interaction energy of nonbonded side chains
1407 C assuming the Gay-Berne potential of interaction.
1408 C
1409       implicit real*8 (a-h,o-z)
1410       include 'DIMENSIONS'
1411       include 'COMMON.GEO'
1412       include 'COMMON.VAR'
1413       include 'COMMON.LOCAL'
1414       include 'COMMON.CHAIN'
1415       include 'COMMON.DERIV'
1416       include 'COMMON.NAMES'
1417       include 'COMMON.INTERACT'
1418       include 'COMMON.IOUNITS'
1419       include 'COMMON.CALC'
1420       include 'COMMON.CONTROL'
1421       include 'COMMON.SBRIDGE'
1422       logical lprn
1423
1424 c      write(iout,*) "Jestem w egb(evdw)"
1425
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         if (itypi.eq.ntyp1) cycle
1436         itypi1=iabs(itype(i+1))
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1446 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1447 C
1448 C Calculate SC interaction energy.
1449 C
1450         do iint=1,nint_gr(i)
1451           do j=istart(i,iint),iend(i,iint)
1452             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1453
1454 c              write(iout,*) "PRZED ZWYKLE", evdwij
1455               call dyn_ssbond_ene(i,j,evdwij)
1456 c              write(iout,*) "PO ZWYKLE", evdwij
1457
1458               evdw=evdw+evdwij
1459               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1460      &                        'evdw',i,j,evdwij,' ss'
1461 C triple bond artifac removal
1462              do k=j+1,iend(i,iint)
1463 C search over all next residues
1464               if (dyn_ss_mask(k)) then
1465 C check if they are cysteins
1466 C              write(iout,*) 'k=',k
1467
1468 c              write(iout,*) "PRZED TRI", evdwij
1469                evdwij_przed_tri=evdwij
1470               call triple_ssbond_ene(i,j,k,evdwij)
1471 c               if(evdwij_przed_tri.ne.evdwij) then
1472 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1473 c               endif
1474
1475 c              write(iout,*) "PO TRI", evdwij
1476 C call the energy function that removes the artifical triple disulfide
1477 C bond the soubroutine is located in ssMD.F
1478               evdw=evdw+evdwij
1479               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1480      &                        'evdw',i,j,evdwij,'tss'
1481               endif!dyn_ss_mask(k)
1482              enddo! k
1483             ELSE
1484             ind=ind+1
1485             itypj=iabs(itype(j))
1486             if (itypj.eq.ntyp1) cycle
1487 c            dscj_inv=dsc_inv(itypj)
1488             dscj_inv=vbld_inv(j+nres)
1489 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1490 c     &       1.0d0/vbld(j+nres)
1491 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1492             sig0ij=sigma(itypi,itypj)
1493             chi1=chi(itypi,itypj)
1494             chi2=chi(itypj,itypi)
1495             chi12=chi1*chi2
1496             chip1=chip(itypi)
1497             chip2=chip(itypj)
1498             chip12=chip1*chip2
1499             alf1=alp(itypi)
1500             alf2=alp(itypj)
1501             alf12=0.5D0*(alf1+alf2)
1502 C For diagnostics only!!!
1503 c           chi1=0.0D0
1504 c           chi2=0.0D0
1505 c           chi12=0.0D0
1506 c           chip1=0.0D0
1507 c           chip2=0.0D0
1508 c           chip12=0.0D0
1509 c           alf1=0.0D0
1510 c           alf2=0.0D0
1511 c           alf12=0.0D0
1512             xj=c(1,nres+j)-xi
1513             yj=c(2,nres+j)-yi
1514             zj=c(3,nres+j)-zi
1515             dxj=dc_norm(1,nres+j)
1516             dyj=dc_norm(2,nres+j)
1517             dzj=dc_norm(3,nres+j)
1518 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1519 c            write (iout,*) "j",j," dc_norm",
1520 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1521             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1522             rij=dsqrt(rrij)
1523 C Calculate angle-dependent terms of energy and contributions to their
1524 C derivatives.
1525             call sc_angular
1526             sigsq=1.0D0/sigsq
1527             sig=sig0ij*dsqrt(sigsq)
1528             rij_shift=1.0D0/rij-sig+sig0ij
1529 c for diagnostics; uncomment
1530 c            rij_shift=1.2*sig0ij
1531 C I hate to put IF's in the loops, but here don't have another choice!!!!
1532             if (rij_shift.le.0.0D0) then
1533               evdw=1.0D20
1534 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1535 cd     &        restyp(itypi),i,restyp(itypj),j,
1536 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1537               return
1538             endif
1539             sigder=-sig*sigsq
1540 c---------------------------------------------------------------
1541             rij_shift=1.0D0/rij_shift
1542             fac=rij_shift**expon
1543             e1=fac*fac*aa(itypi,itypj)
1544             e2=fac*bb(itypi,itypj)
1545             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1546             eps2der=evdwij*eps3rt
1547             eps3der=evdwij*eps2rt
1548 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1549 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1550             evdwij=evdwij*eps2rt*eps3rt
1551             evdw=evdw+evdwij
1552             if (lprn) then
1553             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1554             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1555             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1556      &        restyp(itypi),i,restyp(itypj),j,
1557      &        epsi,sigm,chi1,chi2,chip1,chip2,
1558      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1559      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1560      &        evdwij
1561             endif
1562
1563             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1564      &                        'evdw',i,j,evdwij
1565
1566 C Calculate gradient components.
1567             e1=e1*eps1*eps2rt**2*eps3rt**2
1568             fac=-expon*(e1+evdwij)*rij_shift
1569             sigder=fac*sigder
1570             fac=rij*fac
1571 c            fac=0.0d0
1572 C Calculate the radial part of the gradient
1573             gg(1)=xj*fac
1574             gg(2)=yj*fac
1575             gg(3)=zj*fac
1576 C Calculate angular part of the gradient.
1577             call sc_grad
1578             ENDIF    ! dyn_ss
1579           enddo      ! j
1580         enddo        ! iint
1581       enddo          ! i
1582 c      write (iout,*) "Number of loop steps in EGB:",ind
1583 cccc      energy_dec=.false.
1584       return
1585       end
1586 C-----------------------------------------------------------------------------
1587       subroutine egbv(evdw)
1588 C
1589 C This subroutine calculates the interaction energy of nonbonded side chains
1590 C assuming the Gay-Berne-Vorobjev potential of interaction.
1591 C
1592       implicit real*8 (a-h,o-z)
1593       include 'DIMENSIONS'
1594       include 'COMMON.GEO'
1595       include 'COMMON.VAR'
1596       include 'COMMON.LOCAL'
1597       include 'COMMON.CHAIN'
1598       include 'COMMON.DERIV'
1599       include 'COMMON.NAMES'
1600       include 'COMMON.INTERACT'
1601       include 'COMMON.IOUNITS'
1602       include 'COMMON.CALC'
1603       common /srutu/ icall
1604       logical lprn
1605       evdw=0.0D0
1606 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1607       evdw=0.0D0
1608       lprn=.false.
1609 c     if (icall.eq.0) lprn=.true.
1610       ind=0
1611       do i=iatsc_s,iatsc_e
1612         itypi=iabs(itype(i))
1613         if (itypi.eq.ntyp1) cycle
1614         itypi1=iabs(itype(i+1))
1615         xi=c(1,nres+i)
1616         yi=c(2,nres+i)
1617         zi=c(3,nres+i)
1618         dxi=dc_norm(1,nres+i)
1619         dyi=dc_norm(2,nres+i)
1620         dzi=dc_norm(3,nres+i)
1621 c        dsci_inv=dsc_inv(itypi)
1622         dsci_inv=vbld_inv(i+nres)
1623 C
1624 C Calculate SC interaction energy.
1625 C
1626         do iint=1,nint_gr(i)
1627           do j=istart(i,iint),iend(i,iint)
1628             ind=ind+1
1629             itypj=iabs(itype(j))
1630             if (itypj.eq.ntyp1) cycle
1631 c            dscj_inv=dsc_inv(itypj)
1632             dscj_inv=vbld_inv(j+nres)
1633             sig0ij=sigma(itypi,itypj)
1634             r0ij=r0(itypi,itypj)
1635             chi1=chi(itypi,itypj)
1636             chi2=chi(itypj,itypi)
1637             chi12=chi1*chi2
1638             chip1=chip(itypi)
1639             chip2=chip(itypj)
1640             chip12=chip1*chip2
1641             alf1=alp(itypi)
1642             alf2=alp(itypj)
1643             alf12=0.5D0*(alf1+alf2)
1644 C For diagnostics only!!!
1645 c           chi1=0.0D0
1646 c           chi2=0.0D0
1647 c           chi12=0.0D0
1648 c           chip1=0.0D0
1649 c           chip2=0.0D0
1650 c           chip12=0.0D0
1651 c           alf1=0.0D0
1652 c           alf2=0.0D0
1653 c           alf12=0.0D0
1654             xj=c(1,nres+j)-xi
1655             yj=c(2,nres+j)-yi
1656             zj=c(3,nres+j)-zi
1657             dxj=dc_norm(1,nres+j)
1658             dyj=dc_norm(2,nres+j)
1659             dzj=dc_norm(3,nres+j)
1660             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1661             rij=dsqrt(rrij)
1662 C Calculate angle-dependent terms of energy and contributions to their
1663 C derivatives.
1664             call sc_angular
1665             sigsq=1.0D0/sigsq
1666             sig=sig0ij*dsqrt(sigsq)
1667             rij_shift=1.0D0/rij-sig+r0ij
1668 C I hate to put IF's in the loops, but here don't have another choice!!!!
1669             if (rij_shift.le.0.0D0) then
1670               evdw=1.0D20
1671               return
1672             endif
1673             sigder=-sig*sigsq
1674 c---------------------------------------------------------------
1675             rij_shift=1.0D0/rij_shift
1676             fac=rij_shift**expon
1677             e1=fac*fac*aa(itypi,itypj)
1678             e2=fac*bb(itypi,itypj)
1679             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1680             eps2der=evdwij*eps3rt
1681             eps3der=evdwij*eps2rt
1682             fac_augm=rrij**expon
1683             e_augm=augm(itypi,itypj)*fac_augm
1684             evdwij=evdwij*eps2rt*eps3rt
1685             evdw=evdw+evdwij+e_augm
1686             if (lprn) then
1687             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1688             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1689             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1690      &        restyp(itypi),i,restyp(itypj),j,
1691      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1692      &        chi1,chi2,chip1,chip2,
1693      &        eps1,eps2rt**2,eps3rt**2,
1694      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1695      &        evdwij+e_augm
1696             endif
1697 C Calculate gradient components.
1698             e1=e1*eps1*eps2rt**2*eps3rt**2
1699             fac=-expon*(e1+evdwij)*rij_shift
1700             sigder=fac*sigder
1701             fac=rij*fac-2*expon*rrij*e_augm
1702 C Calculate the radial part of the gradient
1703             gg(1)=xj*fac
1704             gg(2)=yj*fac
1705             gg(3)=zj*fac
1706 C Calculate angular part of the gradient.
1707             call sc_grad
1708           enddo      ! j
1709         enddo        ! iint
1710       enddo          ! i
1711       end
1712 C-----------------------------------------------------------------------------
1713       subroutine sc_angular
1714 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1715 C om12. Called by ebp, egb, and egbv.
1716       implicit none
1717       include 'COMMON.CALC'
1718       include 'COMMON.IOUNITS'
1719       erij(1)=xj*rij
1720       erij(2)=yj*rij
1721       erij(3)=zj*rij
1722       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1723       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1724       om12=dxi*dxj+dyi*dyj+dzi*dzj
1725       chiom12=chi12*om12
1726 C Calculate eps1(om12) and its derivative in om12
1727       faceps1=1.0D0-om12*chiom12
1728       faceps1_inv=1.0D0/faceps1
1729       eps1=dsqrt(faceps1_inv)
1730 C Following variable is eps1*deps1/dom12
1731       eps1_om12=faceps1_inv*chiom12
1732 c diagnostics only
1733 c      faceps1_inv=om12
1734 c      eps1=om12
1735 c      eps1_om12=1.0d0
1736 c      write (iout,*) "om12",om12," eps1",eps1
1737 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1738 C and om12.
1739       om1om2=om1*om2
1740       chiom1=chi1*om1
1741       chiom2=chi2*om2
1742       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1743       sigsq=1.0D0-facsig*faceps1_inv
1744       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1745       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1746       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1747 c diagnostics only
1748 c      sigsq=1.0d0
1749 c      sigsq_om1=0.0d0
1750 c      sigsq_om2=0.0d0
1751 c      sigsq_om12=0.0d0
1752 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1753 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1754 c     &    " eps1",eps1
1755 C Calculate eps2 and its derivatives in om1, om2, and om12.
1756       chipom1=chip1*om1
1757       chipom2=chip2*om2
1758       chipom12=chip12*om12
1759       facp=1.0D0-om12*chipom12
1760       facp_inv=1.0D0/facp
1761       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1762 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1763 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1764 C Following variable is the square root of eps2
1765       eps2rt=1.0D0-facp1*facp_inv
1766 C Following three variables are the derivatives of the square root of eps
1767 C in om1, om2, and om12.
1768       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1769       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1770       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1771 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1772       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1773 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1774 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1775 c     &  " eps2rt_om12",eps2rt_om12
1776 C Calculate whole angle-dependent part of epsilon and contributions
1777 C to its derivatives
1778       return
1779       end
1780 C----------------------------------------------------------------------------
1781       subroutine sc_grad
1782       implicit real*8 (a-h,o-z)
1783       include 'DIMENSIONS'
1784       include 'COMMON.CHAIN'
1785       include 'COMMON.DERIV'
1786       include 'COMMON.CALC'
1787       include 'COMMON.IOUNITS'
1788       double precision dcosom1(3),dcosom2(3)
1789       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1790       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1791       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1792      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1793 c diagnostics only
1794 c      eom1=0.0d0
1795 c      eom2=0.0d0
1796 c      eom12=evdwij*eps1_om12
1797 c end diagnostics
1798 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1799 c     &  " sigder",sigder
1800 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1801 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1802       do k=1,3
1803         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1804         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1805       enddo
1806       do k=1,3
1807         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1808       enddo
1809 c      write (iout,*) "gg",(gg(k),k=1,3)
1810       do k=1,3
1811         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1812      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1813      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1814         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1815      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1816      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1817 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1818 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1819 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1820 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1821       enddo
1822 C
1823 C Calculate the components of the gradient in DC and X
1824 C
1825 cgrad      do k=i,j-1
1826 cgrad        do l=1,3
1827 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1828 cgrad        enddo
1829 cgrad      enddo
1830       do l=1,3
1831         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1832         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1833       enddo
1834       return
1835       end
1836 C-----------------------------------------------------------------------
1837       subroutine e_softsphere(evdw)
1838 C
1839 C This subroutine calculates the interaction energy of nonbonded side chains
1840 C assuming the LJ potential of interaction.
1841 C
1842       implicit real*8 (a-h,o-z)
1843       include 'DIMENSIONS'
1844       parameter (accur=1.0d-10)
1845       include 'COMMON.GEO'
1846       include 'COMMON.VAR'
1847       include 'COMMON.LOCAL'
1848       include 'COMMON.CHAIN'
1849       include 'COMMON.DERIV'
1850       include 'COMMON.INTERACT'
1851       include 'COMMON.TORSION'
1852       include 'COMMON.SBRIDGE'
1853       include 'COMMON.NAMES'
1854       include 'COMMON.IOUNITS'
1855       include 'COMMON.CONTACTS'
1856       dimension gg(3)
1857 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1858       evdw=0.0D0
1859       do i=iatsc_s,iatsc_e
1860         itypi=iabs(itype(i))
1861         if (itypi.eq.ntyp1) cycle
1862         itypi1=iabs(itype(i+1))
1863         xi=c(1,nres+i)
1864         yi=c(2,nres+i)
1865         zi=c(3,nres+i)
1866 C
1867 C Calculate SC interaction energy.
1868 C
1869         do iint=1,nint_gr(i)
1870 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1871 cd   &                  'iend=',iend(i,iint)
1872           do j=istart(i,iint),iend(i,iint)
1873             itypj=iabs(itype(j))
1874             if (itypj.eq.ntyp1) cycle
1875             xj=c(1,nres+j)-xi
1876             yj=c(2,nres+j)-yi
1877             zj=c(3,nres+j)-zi
1878             rij=xj*xj+yj*yj+zj*zj
1879 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1880             r0ij=r0(itypi,itypj)
1881             r0ijsq=r0ij*r0ij
1882 c            print *,i,j,r0ij,dsqrt(rij)
1883             if (rij.lt.r0ijsq) then
1884               evdwij=0.25d0*(rij-r0ijsq)**2
1885               fac=rij-r0ijsq
1886             else
1887               evdwij=0.0d0
1888               fac=0.0d0
1889             endif
1890             evdw=evdw+evdwij
1891 C
1892 C Calculate the components of the gradient in DC and X
1893 C
1894             gg(1)=xj*fac
1895             gg(2)=yj*fac
1896             gg(3)=zj*fac
1897             do k=1,3
1898               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1899               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1900               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1901               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1902             enddo
1903 cgrad            do k=i,j-1
1904 cgrad              do l=1,3
1905 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1906 cgrad              enddo
1907 cgrad            enddo
1908           enddo ! j
1909         enddo ! iint
1910       enddo ! i
1911       return
1912       end
1913 C--------------------------------------------------------------------------
1914       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1915      &              eello_turn4)
1916 C
1917 C Soft-sphere potential of p-p interaction
1918 C
1919       implicit real*8 (a-h,o-z)
1920       include 'DIMENSIONS'
1921       include 'COMMON.CONTROL'
1922       include 'COMMON.IOUNITS'
1923       include 'COMMON.GEO'
1924       include 'COMMON.VAR'
1925       include 'COMMON.LOCAL'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.INTERACT'
1929       include 'COMMON.CONTACTS'
1930       include 'COMMON.TORSION'
1931       include 'COMMON.VECTORS'
1932       include 'COMMON.FFIELD'
1933       dimension ggg(3)
1934 cd      write(iout,*) 'In EELEC_soft_sphere'
1935       ees=0.0D0
1936       evdw1=0.0D0
1937       eel_loc=0.0d0
1938       eello_turn3=0.0d0
1939       eello_turn4=0.0d0
1940       ind=0
1941       do i=iatel_s,iatel_e
1942         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1943         dxi=dc(1,i)
1944         dyi=dc(2,i)
1945         dzi=dc(3,i)
1946         xmedi=c(1,i)+0.5d0*dxi
1947         ymedi=c(2,i)+0.5d0*dyi
1948         zmedi=c(3,i)+0.5d0*dzi
1949         num_conti=0
1950 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1951         do j=ielstart(i),ielend(i)
1952           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1953           ind=ind+1
1954           iteli=itel(i)
1955           itelj=itel(j)
1956           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1957           r0ij=rpp(iteli,itelj)
1958           r0ijsq=r0ij*r0ij
1959           dxj=dc(1,j)
1960           dyj=dc(2,j)
1961           dzj=dc(3,j)
1962           xj=c(1,j)+0.5D0*dxj-xmedi
1963           yj=c(2,j)+0.5D0*dyj-ymedi
1964           zj=c(3,j)+0.5D0*dzj-zmedi
1965           rij=xj*xj+yj*yj+zj*zj
1966           if (rij.lt.r0ijsq) then
1967             evdw1ij=0.25d0*(rij-r0ijsq)**2
1968             fac=rij-r0ijsq
1969           else
1970             evdw1ij=0.0d0
1971             fac=0.0d0
1972           endif
1973           evdw1=evdw1+evdw1ij
1974 C
1975 C Calculate contributions to the Cartesian gradient.
1976 C
1977           ggg(1)=fac*xj
1978           ggg(2)=fac*yj
1979           ggg(3)=fac*zj
1980           do k=1,3
1981             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1982             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1983           enddo
1984 *
1985 * Loop over residues i+1 thru j-1.
1986 *
1987 cgrad          do k=i+1,j-1
1988 cgrad            do l=1,3
1989 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1990 cgrad            enddo
1991 cgrad          enddo
1992         enddo ! j
1993       enddo   ! i
1994 cgrad      do i=nnt,nct-1
1995 cgrad        do k=1,3
1996 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1997 cgrad        enddo
1998 cgrad        do j=i+1,nct-1
1999 cgrad          do k=1,3
2000 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2001 cgrad          enddo
2002 cgrad        enddo
2003 cgrad      enddo
2004       return
2005       end
2006 c------------------------------------------------------------------------------
2007       subroutine vec_and_deriv
2008       implicit real*8 (a-h,o-z)
2009       include 'DIMENSIONS'
2010 #ifdef MPI
2011       include 'mpif.h'
2012 #endif
2013       include 'COMMON.IOUNITS'
2014       include 'COMMON.GEO'
2015       include 'COMMON.VAR'
2016       include 'COMMON.LOCAL'
2017       include 'COMMON.CHAIN'
2018       include 'COMMON.VECTORS'
2019       include 'COMMON.SETUP'
2020       include 'COMMON.TIME1'
2021       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2022 C Compute the local reference systems. For reference system (i), the
2023 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2024 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2025 #ifdef PARVEC
2026       do i=ivec_start,ivec_end
2027 #else
2028       do i=1,nres-1
2029 #endif
2030           if (i.eq.nres-1) then
2031 C Case of the last full residue
2032 C Compute the Z-axis
2033             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2034             costh=dcos(pi-theta(nres))
2035             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2036             do k=1,3
2037               uz(k,i)=fac*uz(k,i)
2038             enddo
2039 C Compute the derivatives of uz
2040             uzder(1,1,1)= 0.0d0
2041             uzder(2,1,1)=-dc_norm(3,i-1)
2042             uzder(3,1,1)= dc_norm(2,i-1)
2043             uzder(1,2,1)= dc_norm(3,i-1)
2044             uzder(2,2,1)= 0.0d0
2045             uzder(3,2,1)=-dc_norm(1,i-1)
2046             uzder(1,3,1)=-dc_norm(2,i-1)
2047             uzder(2,3,1)= dc_norm(1,i-1)
2048             uzder(3,3,1)= 0.0d0
2049             uzder(1,1,2)= 0.0d0
2050             uzder(2,1,2)= dc_norm(3,i)
2051             uzder(3,1,2)=-dc_norm(2,i)
2052             uzder(1,2,2)=-dc_norm(3,i)
2053             uzder(2,2,2)= 0.0d0
2054             uzder(3,2,2)= dc_norm(1,i)
2055             uzder(1,3,2)= dc_norm(2,i)
2056             uzder(2,3,2)=-dc_norm(1,i)
2057             uzder(3,3,2)= 0.0d0
2058 C Compute the Y-axis
2059             facy=fac
2060             do k=1,3
2061               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2062             enddo
2063 C Compute the derivatives of uy
2064             do j=1,3
2065               do k=1,3
2066                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2067      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2068                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2069               enddo
2070               uyder(j,j,1)=uyder(j,j,1)-costh
2071               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2072             enddo
2073             do j=1,2
2074               do k=1,3
2075                 do l=1,3
2076                   uygrad(l,k,j,i)=uyder(l,k,j)
2077                   uzgrad(l,k,j,i)=uzder(l,k,j)
2078                 enddo
2079               enddo
2080             enddo
2081             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2082             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2083             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2084             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2085           else
2086 C Other residues
2087 C Compute the Z-axis
2088             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2089             costh=dcos(pi-theta(i+2))
2090             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2091             do k=1,3
2092               uz(k,i)=fac*uz(k,i)
2093             enddo
2094 C Compute the derivatives of uz
2095             uzder(1,1,1)= 0.0d0
2096             uzder(2,1,1)=-dc_norm(3,i+1)
2097             uzder(3,1,1)= dc_norm(2,i+1)
2098             uzder(1,2,1)= dc_norm(3,i+1)
2099             uzder(2,2,1)= 0.0d0
2100             uzder(3,2,1)=-dc_norm(1,i+1)
2101             uzder(1,3,1)=-dc_norm(2,i+1)
2102             uzder(2,3,1)= dc_norm(1,i+1)
2103             uzder(3,3,1)= 0.0d0
2104             uzder(1,1,2)= 0.0d0
2105             uzder(2,1,2)= dc_norm(3,i)
2106             uzder(3,1,2)=-dc_norm(2,i)
2107             uzder(1,2,2)=-dc_norm(3,i)
2108             uzder(2,2,2)= 0.0d0
2109             uzder(3,2,2)= dc_norm(1,i)
2110             uzder(1,3,2)= dc_norm(2,i)
2111             uzder(2,3,2)=-dc_norm(1,i)
2112             uzder(3,3,2)= 0.0d0
2113 C Compute the Y-axis
2114             facy=fac
2115             do k=1,3
2116               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2117             enddo
2118 C Compute the derivatives of uy
2119             do j=1,3
2120               do k=1,3
2121                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2122      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2123                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2124               enddo
2125               uyder(j,j,1)=uyder(j,j,1)-costh
2126               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2127             enddo
2128             do j=1,2
2129               do k=1,3
2130                 do l=1,3
2131                   uygrad(l,k,j,i)=uyder(l,k,j)
2132                   uzgrad(l,k,j,i)=uzder(l,k,j)
2133                 enddo
2134               enddo
2135             enddo
2136             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2137             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2138             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2139             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2140           endif
2141       enddo
2142       do i=1,nres-1
2143         vbld_inv_temp(1)=vbld_inv(i+1)
2144         if (i.lt.nres-1) then
2145           vbld_inv_temp(2)=vbld_inv(i+2)
2146           else
2147           vbld_inv_temp(2)=vbld_inv(i)
2148           endif
2149         do j=1,2
2150           do k=1,3
2151             do l=1,3
2152               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2153               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2154             enddo
2155           enddo
2156         enddo
2157       enddo
2158 #if defined(PARVEC) && defined(MPI)
2159       if (nfgtasks1.gt.1) then
2160         time00=MPI_Wtime()
2161 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2162 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2163 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2164         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2165      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2166      &   FG_COMM1,IERR)
2167         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2168      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2169      &   FG_COMM1,IERR)
2170         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2171      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2172      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2173         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2174      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2175      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2176         time_gather=time_gather+MPI_Wtime()-time00
2177       endif
2178 c      if (fg_rank.eq.0) then
2179 c        write (iout,*) "Arrays UY and UZ"
2180 c        do i=1,nres-1
2181 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2182 c     &     (uz(k,i),k=1,3)
2183 c        enddo
2184 c      endif
2185 #endif
2186       return
2187       end
2188 C-----------------------------------------------------------------------------
2189       subroutine check_vecgrad
2190       implicit real*8 (a-h,o-z)
2191       include 'DIMENSIONS'
2192       include 'COMMON.IOUNITS'
2193       include 'COMMON.GEO'
2194       include 'COMMON.VAR'
2195       include 'COMMON.LOCAL'
2196       include 'COMMON.CHAIN'
2197       include 'COMMON.VECTORS'
2198       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2199       dimension uyt(3,maxres),uzt(3,maxres)
2200       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2201       double precision delta /1.0d-7/
2202       call vec_and_deriv
2203 cd      do i=1,nres
2204 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2205 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2206 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2207 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2208 cd     &     (dc_norm(if90,i),if90=1,3)
2209 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2210 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2211 cd          write(iout,'(a)')
2212 cd      enddo
2213       do i=1,nres
2214         do j=1,2
2215           do k=1,3
2216             do l=1,3
2217               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2218               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2219             enddo
2220           enddo
2221         enddo
2222       enddo
2223       call vec_and_deriv
2224       do i=1,nres
2225         do j=1,3
2226           uyt(j,i)=uy(j,i)
2227           uzt(j,i)=uz(j,i)
2228         enddo
2229       enddo
2230       do i=1,nres
2231 cd        write (iout,*) 'i=',i
2232         do k=1,3
2233           erij(k)=dc_norm(k,i)
2234         enddo
2235         do j=1,3
2236           do k=1,3
2237             dc_norm(k,i)=erij(k)
2238           enddo
2239           dc_norm(j,i)=dc_norm(j,i)+delta
2240 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2241 c          do k=1,3
2242 c            dc_norm(k,i)=dc_norm(k,i)/fac
2243 c          enddo
2244 c          write (iout,*) (dc_norm(k,i),k=1,3)
2245 c          write (iout,*) (erij(k),k=1,3)
2246           call vec_and_deriv
2247           do k=1,3
2248             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2249             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2250             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2251             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2252           enddo
2253 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2254 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2255 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2256         enddo
2257         do k=1,3
2258           dc_norm(k,i)=erij(k)
2259         enddo
2260 cd        do k=1,3
2261 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2262 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2263 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2264 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2265 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2266 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2267 cd          write (iout,'(a)')
2268 cd        enddo
2269       enddo
2270       return
2271       end
2272 C--------------------------------------------------------------------------
2273       subroutine set_matrices
2274       implicit real*8 (a-h,o-z)
2275       include 'DIMENSIONS'
2276 #ifdef MPI
2277       include "mpif.h"
2278       include "COMMON.SETUP"
2279       integer IERR
2280       integer status(MPI_STATUS_SIZE)
2281 #endif
2282       include 'COMMON.IOUNITS'
2283       include 'COMMON.GEO'
2284       include 'COMMON.VAR'
2285       include 'COMMON.LOCAL'
2286       include 'COMMON.CHAIN'
2287       include 'COMMON.DERIV'
2288       include 'COMMON.INTERACT'
2289       include 'COMMON.CONTACTS'
2290       include 'COMMON.TORSION'
2291       include 'COMMON.VECTORS'
2292       include 'COMMON.FFIELD'
2293       double precision auxvec(2),auxmat(2,2)
2294 C
2295 C Compute the virtual-bond-torsional-angle dependent quantities needed
2296 C to calculate the el-loc multibody terms of various order.
2297 C
2298 #ifdef PARMAT
2299       do i=ivec_start+2,ivec_end+2
2300 #else
2301       do i=3,nres+1
2302 #endif
2303         if (i .lt. nres+1) then
2304           sin1=dsin(phi(i))
2305           cos1=dcos(phi(i))
2306           sintab(i-2)=sin1
2307           costab(i-2)=cos1
2308           obrot(1,i-2)=cos1
2309           obrot(2,i-2)=sin1
2310           sin2=dsin(2*phi(i))
2311           cos2=dcos(2*phi(i))
2312           sintab2(i-2)=sin2
2313           costab2(i-2)=cos2
2314           obrot2(1,i-2)=cos2
2315           obrot2(2,i-2)=sin2
2316           Ug(1,1,i-2)=-cos1
2317           Ug(1,2,i-2)=-sin1
2318           Ug(2,1,i-2)=-sin1
2319           Ug(2,2,i-2)= cos1
2320           Ug2(1,1,i-2)=-cos2
2321           Ug2(1,2,i-2)=-sin2
2322           Ug2(2,1,i-2)=-sin2
2323           Ug2(2,2,i-2)= cos2
2324         else
2325           costab(i-2)=1.0d0
2326           sintab(i-2)=0.0d0
2327           obrot(1,i-2)=1.0d0
2328           obrot(2,i-2)=0.0d0
2329           obrot2(1,i-2)=0.0d0
2330           obrot2(2,i-2)=0.0d0
2331           Ug(1,1,i-2)=1.0d0
2332           Ug(1,2,i-2)=0.0d0
2333           Ug(2,1,i-2)=0.0d0
2334           Ug(2,2,i-2)=1.0d0
2335           Ug2(1,1,i-2)=0.0d0
2336           Ug2(1,2,i-2)=0.0d0
2337           Ug2(2,1,i-2)=0.0d0
2338           Ug2(2,2,i-2)=0.0d0
2339         endif
2340         if (i .gt. 3 .and. i .lt. nres+1) then
2341           obrot_der(1,i-2)=-sin1
2342           obrot_der(2,i-2)= cos1
2343           Ugder(1,1,i-2)= sin1
2344           Ugder(1,2,i-2)=-cos1
2345           Ugder(2,1,i-2)=-cos1
2346           Ugder(2,2,i-2)=-sin1
2347           dwacos2=cos2+cos2
2348           dwasin2=sin2+sin2
2349           obrot2_der(1,i-2)=-dwasin2
2350           obrot2_der(2,i-2)= dwacos2
2351           Ug2der(1,1,i-2)= dwasin2
2352           Ug2der(1,2,i-2)=-dwacos2
2353           Ug2der(2,1,i-2)=-dwacos2
2354           Ug2der(2,2,i-2)=-dwasin2
2355         else
2356           obrot_der(1,i-2)=0.0d0
2357           obrot_der(2,i-2)=0.0d0
2358           Ugder(1,1,i-2)=0.0d0
2359           Ugder(1,2,i-2)=0.0d0
2360           Ugder(2,1,i-2)=0.0d0
2361           Ugder(2,2,i-2)=0.0d0
2362           obrot2_der(1,i-2)=0.0d0
2363           obrot2_der(2,i-2)=0.0d0
2364           Ug2der(1,1,i-2)=0.0d0
2365           Ug2der(1,2,i-2)=0.0d0
2366           Ug2der(2,1,i-2)=0.0d0
2367           Ug2der(2,2,i-2)=0.0d0
2368         endif
2369 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2370         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2371           iti = itortyp(itype(i-2))
2372         else
2373           iti=ntortyp+1
2374         endif
2375 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2376         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2377           iti1 = itortyp(itype(i-1))
2378         else
2379           iti1=ntortyp+1
2380         endif
2381 cd        write (iout,*) '*******i',i,' iti1',iti
2382 cd        write (iout,*) 'b1',b1(:,iti)
2383 cd        write (iout,*) 'b2',b2(:,iti)
2384 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2385 c        if (i .gt. iatel_s+2) then
2386         if (i .gt. nnt+2) then
2387           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2388           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2389           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2390      &    then
2391           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2392           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2393           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2394           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2395           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2396           endif
2397         else
2398           do k=1,2
2399             Ub2(k,i-2)=0.0d0
2400             Ctobr(k,i-2)=0.0d0
2401             Dtobr2(k,i-2)=0.0d0
2402             do l=1,2
2403               EUg(l,k,i-2)=0.0d0
2404               CUg(l,k,i-2)=0.0d0
2405               DUg(l,k,i-2)=0.0d0
2406               DtUg2(l,k,i-2)=0.0d0
2407             enddo
2408           enddo
2409         endif
2410         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2411         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2412         do k=1,2
2413           muder(k,i-2)=Ub2der(k,i-2)
2414         enddo
2415 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2416         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2417           if (itype(i-1).le.ntyp) then
2418             iti1 = itortyp(itype(i-1))
2419           else
2420             iti1=ntortyp+1
2421           endif
2422         else
2423           iti1=ntortyp+1
2424         endif
2425         do k=1,2
2426           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2427         enddo
2428 cd        write (iout,*) 'mu ',mu(:,i-2)
2429 cd        write (iout,*) 'mu1',mu1(:,i-2)
2430 cd        write (iout,*) 'mu2',mu2(:,i-2)
2431         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2432      &  then
2433         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2434         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2435         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2436         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2437         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2438 C Vectors and matrices dependent on a single virtual-bond dihedral.
2439         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2440         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2441         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2442         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2443         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2444         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2445         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2446         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2447         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2448         endif
2449       enddo
2450 C Matrices dependent on two consecutive virtual-bond dihedrals.
2451 C The order of matrices is from left to right.
2452       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2453      &then
2454 c      do i=max0(ivec_start,2),ivec_end
2455       do i=2,nres-1
2456         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2457         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2458         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2459         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2460         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2461         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2462         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2463         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2464       enddo
2465       endif
2466 #if defined(MPI) && defined(PARMAT)
2467 #ifdef DEBUG
2468 c      if (fg_rank.eq.0) then
2469         write (iout,*) "Arrays UG and UGDER before GATHER"
2470         do i=1,nres-1
2471           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2472      &     ((ug(l,k,i),l=1,2),k=1,2),
2473      &     ((ugder(l,k,i),l=1,2),k=1,2)
2474         enddo
2475         write (iout,*) "Arrays UG2 and UG2DER"
2476         do i=1,nres-1
2477           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2478      &     ((ug2(l,k,i),l=1,2),k=1,2),
2479      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2480         enddo
2481         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2482         do i=1,nres-1
2483           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2484      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2485      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2486         enddo
2487         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2488         do i=1,nres-1
2489           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2490      &     costab(i),sintab(i),costab2(i),sintab2(i)
2491         enddo
2492         write (iout,*) "Array MUDER"
2493         do i=1,nres-1
2494           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2495         enddo
2496 c      endif
2497 #endif
2498       if (nfgtasks.gt.1) then
2499         time00=MPI_Wtime()
2500 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2501 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2502 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2503 #ifdef MATGATHER
2504         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2505      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2506      &   FG_COMM1,IERR)
2507         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2523      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2524      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2525         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2526      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2527      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2528         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2529      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2530      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2531         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2532      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2533      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2534         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2535      &  then
2536         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2543      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2544      &   FG_COMM1,IERR)
2545        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2546      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2547      &   FG_COMM1,IERR)
2548         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2549      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2552      &   ivec_count(fg_rank1),
2553      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2571      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2572      &   FG_COMM1,IERR)
2573         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2574      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2575      &   FG_COMM1,IERR)
2576         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2577      &   ivec_count(fg_rank1),
2578      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2582      &   FG_COMM1,IERR)
2583        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2593      &   ivec_count(fg_rank1),
2594      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2597      &   ivec_count(fg_rank1),
2598      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2601      &   ivec_count(fg_rank1),
2602      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2603      &   MPI_MAT2,FG_COMM1,IERR)
2604         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2605      &   ivec_count(fg_rank1),
2606      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2607      &   MPI_MAT2,FG_COMM1,IERR)
2608         endif
2609 #else
2610 c Passes matrix info through the ring
2611       isend=fg_rank1
2612       irecv=fg_rank1-1
2613       if (irecv.lt.0) irecv=nfgtasks1-1
2614       iprev=irecv
2615       inext=fg_rank1+1
2616       if (inext.ge.nfgtasks1) inext=0
2617       do i=1,nfgtasks1-1
2618 c        write (iout,*) "isend",isend," irecv",irecv
2619 c        call flush(iout)
2620         lensend=lentyp(isend)
2621         lenrecv=lentyp(irecv)
2622 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2623 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2624 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2625 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2626 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2627 c        write (iout,*) "Gather ROTAT1"
2628 c        call flush(iout)
2629 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2630 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2631 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2632 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2633 c        write (iout,*) "Gather ROTAT2"
2634 c        call flush(iout)
2635         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2636      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2637      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2638      &   iprev,4400+irecv,FG_COMM,status,IERR)
2639 c        write (iout,*) "Gather ROTAT_OLD"
2640 c        call flush(iout)
2641         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2642      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2643      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2644      &   iprev,5500+irecv,FG_COMM,status,IERR)
2645 c        write (iout,*) "Gather PRECOMP11"
2646 c        call flush(iout)
2647         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2648      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2649      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2650      &   iprev,6600+irecv,FG_COMM,status,IERR)
2651 c        write (iout,*) "Gather PRECOMP12"
2652 c        call flush(iout)
2653         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2654      &  then
2655         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2656      &   MPI_ROTAT2(lensend),inext,7700+isend,
2657      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2658      &   iprev,7700+irecv,FG_COMM,status,IERR)
2659 c        write (iout,*) "Gather PRECOMP21"
2660 c        call flush(iout)
2661         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2662      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2663      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2664      &   iprev,8800+irecv,FG_COMM,status,IERR)
2665 c        write (iout,*) "Gather PRECOMP22"
2666 c        call flush(iout)
2667         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2668      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2669      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2670      &   MPI_PRECOMP23(lenrecv),
2671      &   iprev,9900+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather PRECOMP23"
2673 c        call flush(iout)
2674         endif
2675         isend=irecv
2676         irecv=irecv-1
2677         if (irecv.lt.0) irecv=nfgtasks1-1
2678       enddo
2679 #endif
2680         time_gather=time_gather+MPI_Wtime()-time00
2681       endif
2682 #ifdef DEBUG
2683 c      if (fg_rank.eq.0) then
2684         write (iout,*) "Arrays UG and UGDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2687      &     ((ug(l,k,i),l=1,2),k=1,2),
2688      &     ((ugder(l,k,i),l=1,2),k=1,2)
2689         enddo
2690         write (iout,*) "Arrays UG2 and UG2DER"
2691         do i=1,nres-1
2692           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2693      &     ((ug2(l,k,i),l=1,2),k=1,2),
2694      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2695         enddo
2696         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2697         do i=1,nres-1
2698           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2699      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2700      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2701         enddo
2702         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2703         do i=1,nres-1
2704           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2705      &     costab(i),sintab(i),costab2(i),sintab2(i)
2706         enddo
2707         write (iout,*) "Array MUDER"
2708         do i=1,nres-1
2709           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2710         enddo
2711 c      endif
2712 #endif
2713 #endif
2714 cd      do i=1,nres
2715 cd        iti = itortyp(itype(i))
2716 cd        write (iout,*) i
2717 cd        do j=1,2
2718 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2719 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2720 cd        enddo
2721 cd      enddo
2722       return
2723       end
2724 C--------------------------------------------------------------------------
2725       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2726 C
2727 C This subroutine calculates the average interaction energy and its gradient
2728 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2729 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2730 C The potential depends both on the distance of peptide-group centers and on
2731 C the orientation of the CA-CA virtual bonds.
2732 C
2733       implicit real*8 (a-h,o-z)
2734 #ifdef MPI
2735       include 'mpif.h'
2736 #endif
2737       include 'DIMENSIONS'
2738       include 'COMMON.CONTROL'
2739       include 'COMMON.SETUP'
2740       include 'COMMON.IOUNITS'
2741       include 'COMMON.GEO'
2742       include 'COMMON.VAR'
2743       include 'COMMON.LOCAL'
2744       include 'COMMON.CHAIN'
2745       include 'COMMON.DERIV'
2746       include 'COMMON.INTERACT'
2747       include 'COMMON.CONTACTS'
2748       include 'COMMON.TORSION'
2749       include 'COMMON.VECTORS'
2750       include 'COMMON.FFIELD'
2751       include 'COMMON.TIME1'
2752       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2753      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2754       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2755      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2756       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2757      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2758      &    num_conti,j1,j2
2759 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2760 #ifdef MOMENT
2761       double precision scal_el /1.0d0/
2762 #else
2763       double precision scal_el /0.5d0/
2764 #endif
2765 C 12/13/98
2766 C 13-go grudnia roku pamietnego...
2767       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2768      &                   0.0d0,1.0d0,0.0d0,
2769      &                   0.0d0,0.0d0,1.0d0/
2770 cd      write(iout,*) 'In EELEC'
2771 cd      do i=1,nloctyp
2772 cd        write(iout,*) 'Type',i
2773 cd        write(iout,*) 'B1',B1(:,i)
2774 cd        write(iout,*) 'B2',B2(:,i)
2775 cd        write(iout,*) 'CC',CC(:,:,i)
2776 cd        write(iout,*) 'DD',DD(:,:,i)
2777 cd        write(iout,*) 'EE',EE(:,:,i)
2778 cd      enddo
2779 cd      call check_vecgrad
2780 cd      stop
2781       if (icheckgrad.eq.1) then
2782         do i=1,nres-1
2783           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2784           do k=1,3
2785             dc_norm(k,i)=dc(k,i)*fac
2786           enddo
2787 c          write (iout,*) 'i',i,' fac',fac
2788         enddo
2789       endif
2790       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2791      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2792      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2793 c        call vec_and_deriv
2794 #ifdef TIMING
2795         time01=MPI_Wtime()
2796 #endif
2797         call set_matrices
2798 #ifdef TIMING
2799         time_mat=time_mat+MPI_Wtime()-time01
2800 #endif
2801       endif
2802 cd      do i=1,nres-1
2803 cd        write (iout,*) 'i=',i
2804 cd        do k=1,3
2805 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2806 cd        enddo
2807 cd        do k=1,3
2808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2810 cd        enddo
2811 cd      enddo
2812       t_eelecij=0.0d0
2813       ees=0.0D0
2814       evdw1=0.0D0
2815       eel_loc=0.0d0
2816       eello_turn3=0.0d0
2817       eello_turn4=0.0d0
2818       ind=0
2819       do i=1,nres
2820         num_cont_hb(i)=0
2821       enddo
2822 cd      print '(a)','Enter EELEC'
2823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2824       do i=1,nres
2825         gel_loc_loc(i)=0.0d0
2826         gcorr_loc(i)=0.0d0
2827       enddo
2828 c
2829 c
2830 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2831 C
2832 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2833 C
2834       do i=iturn3_start,iturn3_end
2835         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2836      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2837         dxi=dc(1,i)
2838         dyi=dc(2,i)
2839         dzi=dc(3,i)
2840         dx_normi=dc_norm(1,i)
2841         dy_normi=dc_norm(2,i)
2842         dz_normi=dc_norm(3,i)
2843         xmedi=c(1,i)+0.5d0*dxi
2844         ymedi=c(2,i)+0.5d0*dyi
2845         zmedi=c(3,i)+0.5d0*dzi
2846         num_conti=0
2847         call eelecij(i,i+2,ees,evdw1,eel_loc)
2848         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2849         num_cont_hb(i)=num_conti
2850       enddo
2851       do i=iturn4_start,iturn4_end
2852         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2853      &    .or. itype(i+3).eq.ntyp1
2854      &    .or. itype(i+4).eq.ntyp1) cycle
2855         dxi=dc(1,i)
2856         dyi=dc(2,i)
2857         dzi=dc(3,i)
2858         dx_normi=dc_norm(1,i)
2859         dy_normi=dc_norm(2,i)
2860         dz_normi=dc_norm(3,i)
2861         xmedi=c(1,i)+0.5d0*dxi
2862         ymedi=c(2,i)+0.5d0*dyi
2863         zmedi=c(3,i)+0.5d0*dzi
2864         num_conti=num_cont_hb(i)
2865         call eelecij(i,i+3,ees,evdw1,eel_loc)
2866         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2867      &   call eturn4(i,eello_turn4)
2868         num_cont_hb(i)=num_conti
2869       enddo   ! i
2870 c
2871 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2872 c
2873       do i=iatel_s,iatel_e
2874         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2875         dxi=dc(1,i)
2876         dyi=dc(2,i)
2877         dzi=dc(3,i)
2878         dx_normi=dc_norm(1,i)
2879         dy_normi=dc_norm(2,i)
2880         dz_normi=dc_norm(3,i)
2881         xmedi=c(1,i)+0.5d0*dxi
2882         ymedi=c(2,i)+0.5d0*dyi
2883         zmedi=c(3,i)+0.5d0*dzi
2884 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2885         num_conti=num_cont_hb(i)
2886         do j=ielstart(i),ielend(i)
2887 c          write (iout,*) i,j,itype(i),itype(j)
2888           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2889           call eelecij(i,j,ees,evdw1,eel_loc)
2890         enddo ! j
2891         num_cont_hb(i)=num_conti
2892       enddo   ! i
2893 c      write (iout,*) "Number of loop steps in EELEC:",ind
2894 cd      do i=1,nres
2895 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2896 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2897 cd      enddo
2898 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2899 ccc      eel_loc=eel_loc+eello_turn3
2900 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2901       return
2902       end
2903 C-------------------------------------------------------------------------------
2904       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2905       implicit real*8 (a-h,o-z)
2906       include 'DIMENSIONS'
2907 #ifdef MPI
2908       include "mpif.h"
2909 #endif
2910       include 'COMMON.CONTROL'
2911       include 'COMMON.IOUNITS'
2912       include 'COMMON.GEO'
2913       include 'COMMON.VAR'
2914       include 'COMMON.LOCAL'
2915       include 'COMMON.CHAIN'
2916       include 'COMMON.DERIV'
2917       include 'COMMON.INTERACT'
2918       include 'COMMON.CONTACTS'
2919       include 'COMMON.TORSION'
2920       include 'COMMON.VECTORS'
2921       include 'COMMON.FFIELD'
2922       include 'COMMON.TIME1'
2923       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2924      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2925       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2926      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2927       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2928      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2929      &    num_conti,j1,j2
2930 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2931 #ifdef MOMENT
2932       double precision scal_el /1.0d0/
2933 #else
2934       double precision scal_el /0.5d0/
2935 #endif
2936 C 12/13/98
2937 C 13-go grudnia roku pamietnego...
2938       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2939      &                   0.0d0,1.0d0,0.0d0,
2940      &                   0.0d0,0.0d0,1.0d0/
2941 c          time00=MPI_Wtime()
2942 cd      write (iout,*) "eelecij",i,j
2943 c          ind=ind+1
2944           iteli=itel(i)
2945           itelj=itel(j)
2946           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2947           aaa=app(iteli,itelj)
2948           bbb=bpp(iteli,itelj)
2949           ael6i=ael6(iteli,itelj)
2950           ael3i=ael3(iteli,itelj)
2951           dxj=dc(1,j)
2952           dyj=dc(2,j)
2953           dzj=dc(3,j)
2954           dx_normj=dc_norm(1,j)
2955           dy_normj=dc_norm(2,j)
2956           dz_normj=dc_norm(3,j)
2957           xj=c(1,j)+0.5D0*dxj-xmedi
2958           yj=c(2,j)+0.5D0*dyj-ymedi
2959           zj=c(3,j)+0.5D0*dzj-zmedi
2960           rij=xj*xj+yj*yj+zj*zj
2961           rrmij=1.0D0/rij
2962           rij=dsqrt(rij)
2963           rmij=1.0D0/rij
2964           r3ij=rrmij*rmij
2965           r6ij=r3ij*r3ij
2966           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2967           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2968           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2969           fac=cosa-3.0D0*cosb*cosg
2970           ev1=aaa*r6ij*r6ij
2971 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2972           if (j.eq.i+2) ev1=scal_el*ev1
2973           ev2=bbb*r6ij
2974           fac3=ael6i*r6ij
2975           fac4=ael3i*r3ij
2976           evdwij=ev1+ev2
2977           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2978           el2=fac4*fac
2979           eesij=el1+el2
2980 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2981           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2982           ees=ees+eesij
2983           evdw1=evdw1+evdwij
2984 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2985 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2986 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2987 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2988
2989           if (energy_dec) then
2990               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2991      &'evdw1',i,j,evdwij
2992      &,iteli,itelj,aaa,evdw1
2993               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2994           endif
2995
2996 C
2997 C Calculate contributions to the Cartesian gradient.
2998 C
2999 #ifdef SPLITELE
3000           facvdw=-6*rrmij*(ev1+evdwij)
3001           facel=-3*rrmij*(el1+eesij)
3002           fac1=fac
3003           erij(1)=xj*rmij
3004           erij(2)=yj*rmij
3005           erij(3)=zj*rmij
3006 *
3007 * Radial derivatives. First process both termini of the fragment (i,j)
3008 *
3009           ggg(1)=facel*xj
3010           ggg(2)=facel*yj
3011           ggg(3)=facel*zj
3012 c          do k=1,3
3013 c            ghalf=0.5D0*ggg(k)
3014 c            gelc(k,i)=gelc(k,i)+ghalf
3015 c            gelc(k,j)=gelc(k,j)+ghalf
3016 c          enddo
3017 c 9/28/08 AL Gradient compotents will be summed only at the end
3018           do k=1,3
3019             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3020             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3021           enddo
3022 *
3023 * Loop over residues i+1 thru j-1.
3024 *
3025 cgrad          do k=i+1,j-1
3026 cgrad            do l=1,3
3027 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3028 cgrad            enddo
3029 cgrad          enddo
3030           ggg(1)=facvdw*xj
3031           ggg(2)=facvdw*yj
3032           ggg(3)=facvdw*zj
3033 c          do k=1,3
3034 c            ghalf=0.5D0*ggg(k)
3035 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3036 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3037 c          enddo
3038 c 9/28/08 AL Gradient compotents will be summed only at the end
3039           do k=1,3
3040             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3041             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3042           enddo
3043 *
3044 * Loop over residues i+1 thru j-1.
3045 *
3046 cgrad          do k=i+1,j-1
3047 cgrad            do l=1,3
3048 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3049 cgrad            enddo
3050 cgrad          enddo
3051 #else
3052           facvdw=ev1+evdwij
3053           facel=el1+eesij
3054           fac1=fac
3055           fac=-3*rrmij*(facvdw+facvdw+facel)
3056           erij(1)=xj*rmij
3057           erij(2)=yj*rmij
3058           erij(3)=zj*rmij
3059 *
3060 * Radial derivatives. First process both termini of the fragment (i,j)
3061 *
3062           ggg(1)=fac*xj
3063           ggg(2)=fac*yj
3064           ggg(3)=fac*zj
3065 c          do k=1,3
3066 c            ghalf=0.5D0*ggg(k)
3067 c            gelc(k,i)=gelc(k,i)+ghalf
3068 c            gelc(k,j)=gelc(k,j)+ghalf
3069 c          enddo
3070 c 9/28/08 AL Gradient compotents will be summed only at the end
3071           do k=1,3
3072             gelc_long(k,j)=gelc(k,j)+ggg(k)
3073             gelc_long(k,i)=gelc(k,i)-ggg(k)
3074           enddo
3075 *
3076 * Loop over residues i+1 thru j-1.
3077 *
3078 cgrad          do k=i+1,j-1
3079 cgrad            do l=1,3
3080 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3081 cgrad            enddo
3082 cgrad          enddo
3083 c 9/28/08 AL Gradient compotents will be summed only at the end
3084           ggg(1)=facvdw*xj
3085           ggg(2)=facvdw*yj
3086           ggg(3)=facvdw*zj
3087           do k=1,3
3088             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3089             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3090           enddo
3091 #endif
3092 *
3093 * Angular part
3094 *
3095           ecosa=2.0D0*fac3*fac1+fac4
3096           fac4=-3.0D0*fac4
3097           fac3=-6.0D0*fac3
3098           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3099           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3100           do k=1,3
3101             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3102             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3103           enddo
3104 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3105 cd   &          (dcosg(k),k=1,3)
3106           do k=1,3
3107             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3108           enddo
3109 c          do k=1,3
3110 c            ghalf=0.5D0*ggg(k)
3111 c            gelc(k,i)=gelc(k,i)+ghalf
3112 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3113 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3114 c            gelc(k,j)=gelc(k,j)+ghalf
3115 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3116 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3117 c          enddo
3118 cgrad          do k=i+1,j-1
3119 cgrad            do l=1,3
3120 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3121 cgrad            enddo
3122 cgrad          enddo
3123           do k=1,3
3124             gelc(k,i)=gelc(k,i)
3125      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3126      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3127             gelc(k,j)=gelc(k,j)
3128      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3129      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3130             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3131             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3132           enddo
3133           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3134      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3135      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3136 C
3137 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3138 C   energy of a peptide unit is assumed in the form of a second-order
3139 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3140 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3141 C   are computed for EVERY pair of non-contiguous peptide groups.
3142 C
3143           if (j.lt.nres-1) then
3144             j1=j+1
3145             j2=j-1
3146           else
3147             j1=j-1
3148             j2=j-2
3149           endif
3150           kkk=0
3151           do k=1,2
3152             do l=1,2
3153               kkk=kkk+1
3154               muij(kkk)=mu(k,i)*mu(l,j)
3155             enddo
3156           enddo
3157 cd         write (iout,*) 'EELEC: i',i,' j',j
3158 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3159 cd          write(iout,*) 'muij',muij
3160           ury=scalar(uy(1,i),erij)
3161           urz=scalar(uz(1,i),erij)
3162           vry=scalar(uy(1,j),erij)
3163           vrz=scalar(uz(1,j),erij)
3164           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3165           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3166           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3167           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3168           fac=dsqrt(-ael6i)*r3ij
3169           a22=a22*fac
3170           a23=a23*fac
3171           a32=a32*fac
3172           a33=a33*fac
3173 cd          write (iout,'(4i5,4f10.5)')
3174 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3175 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3176 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3177 cd     &      uy(:,j),uz(:,j)
3178 cd          write (iout,'(4f10.5)')
3179 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3180 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3181 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3182 cd           write (iout,'(9f10.5/)')
3183 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3184 C Derivatives of the elements of A in virtual-bond vectors
3185           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3186           do k=1,3
3187             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3188             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3189             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3190             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3191             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3192             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3193             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3194             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3195             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3196             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3197             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3198             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3199           enddo
3200 C Compute radial contributions to the gradient
3201           facr=-3.0d0*rrmij
3202           a22der=a22*facr
3203           a23der=a23*facr
3204           a32der=a32*facr
3205           a33der=a33*facr
3206           agg(1,1)=a22der*xj
3207           agg(2,1)=a22der*yj
3208           agg(3,1)=a22der*zj
3209           agg(1,2)=a23der*xj
3210           agg(2,2)=a23der*yj
3211           agg(3,2)=a23der*zj
3212           agg(1,3)=a32der*xj
3213           agg(2,3)=a32der*yj
3214           agg(3,3)=a32der*zj
3215           agg(1,4)=a33der*xj
3216           agg(2,4)=a33der*yj
3217           agg(3,4)=a33der*zj
3218 C Add the contributions coming from er
3219           fac3=-3.0d0*fac
3220           do k=1,3
3221             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3222             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3223             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3224             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3225           enddo
3226           do k=1,3
3227 C Derivatives in DC(i)
3228 cgrad            ghalf1=0.5d0*agg(k,1)
3229 cgrad            ghalf2=0.5d0*agg(k,2)
3230 cgrad            ghalf3=0.5d0*agg(k,3)
3231 cgrad            ghalf4=0.5d0*agg(k,4)
3232             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3233      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3234             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3235      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3236             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3237      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3238             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3239      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3240 C Derivatives in DC(i+1)
3241             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3242      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3243             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3244      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3245             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3246      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3247             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3248      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3249 C Derivatives in DC(j)
3250             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3251      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3252             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3253      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3254             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3255      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3256             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3257      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3258 C Derivatives in DC(j+1) or DC(nres-1)
3259             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3260      &      -3.0d0*vryg(k,3)*ury)
3261             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3262      &      -3.0d0*vrzg(k,3)*ury)
3263             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3264      &      -3.0d0*vryg(k,3)*urz)
3265             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3266      &      -3.0d0*vrzg(k,3)*urz)
3267 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3268 cgrad              do l=1,4
3269 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3270 cgrad              enddo
3271 cgrad            endif
3272           enddo
3273           acipa(1,1)=a22
3274           acipa(1,2)=a23
3275           acipa(2,1)=a32
3276           acipa(2,2)=a33
3277           a22=-a22
3278           a23=-a23
3279           do l=1,2
3280             do k=1,3
3281               agg(k,l)=-agg(k,l)
3282               aggi(k,l)=-aggi(k,l)
3283               aggi1(k,l)=-aggi1(k,l)
3284               aggj(k,l)=-aggj(k,l)
3285               aggj1(k,l)=-aggj1(k,l)
3286             enddo
3287           enddo
3288           if (j.lt.nres-1) then
3289             a22=-a22
3290             a32=-a32
3291             do l=1,3,2
3292               do k=1,3
3293                 agg(k,l)=-agg(k,l)
3294                 aggi(k,l)=-aggi(k,l)
3295                 aggi1(k,l)=-aggi1(k,l)
3296                 aggj(k,l)=-aggj(k,l)
3297                 aggj1(k,l)=-aggj1(k,l)
3298               enddo
3299             enddo
3300           else
3301             a22=-a22
3302             a23=-a23
3303             a32=-a32
3304             a33=-a33
3305             do l=1,4
3306               do k=1,3
3307                 agg(k,l)=-agg(k,l)
3308                 aggi(k,l)=-aggi(k,l)
3309                 aggi1(k,l)=-aggi1(k,l)
3310                 aggj(k,l)=-aggj(k,l)
3311                 aggj1(k,l)=-aggj1(k,l)
3312               enddo
3313             enddo
3314           endif
3315           ENDIF ! WCORR
3316           IF (wel_loc.gt.0.0d0) THEN
3317 C Contribution to the local-electrostatic energy coming from the i-j pair
3318           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3319      &     +a33*muij(4)
3320 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3321
3322           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3323      &            'eelloc',i,j,eel_loc_ij
3324 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3325
3326           eel_loc=eel_loc+eel_loc_ij
3327 C Partial derivatives in virtual-bond dihedral angles gamma
3328           if (i.gt.1)
3329      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3330      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3331      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3332           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3333      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3334      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3335 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3336           do l=1,3
3337             ggg(l)=agg(l,1)*muij(1)+
3338      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3339             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3340             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3341 cgrad            ghalf=0.5d0*ggg(l)
3342 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3343 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3344           enddo
3345 cgrad          do k=i+1,j2
3346 cgrad            do l=1,3
3347 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3348 cgrad            enddo
3349 cgrad          enddo
3350 C Remaining derivatives of eello
3351           do l=1,3
3352             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3353      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3354             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3355      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3356             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3357      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3358             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3359      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3360           enddo
3361           ENDIF
3362 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3363 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3364           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3365      &       .and. num_conti.le.maxconts) then
3366 c            write (iout,*) i,j," entered corr"
3367 C
3368 C Calculate the contact function. The ith column of the array JCONT will
3369 C contain the numbers of atoms that make contacts with the atom I (of numbers
3370 C greater than I). The arrays FACONT and GACONT will contain the values of
3371 C the contact function and its derivative.
3372 c           r0ij=1.02D0*rpp(iteli,itelj)
3373 c           r0ij=1.11D0*rpp(iteli,itelj)
3374             r0ij=2.20D0*rpp(iteli,itelj)
3375 c           r0ij=1.55D0*rpp(iteli,itelj)
3376             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3377             if (fcont.gt.0.0D0) then
3378               num_conti=num_conti+1
3379               if (num_conti.gt.maxconts) then
3380                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3381      &                         ' will skip next contacts for this conf.'
3382               else
3383                 jcont_hb(num_conti,i)=j
3384 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3385 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3386                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3387      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3388 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3389 C  terms.
3390                 d_cont(num_conti,i)=rij
3391 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3392 C     --- Electrostatic-interaction matrix ---
3393                 a_chuj(1,1,num_conti,i)=a22
3394                 a_chuj(1,2,num_conti,i)=a23
3395                 a_chuj(2,1,num_conti,i)=a32
3396                 a_chuj(2,2,num_conti,i)=a33
3397 C     --- Gradient of rij
3398                 do kkk=1,3
3399                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3400                 enddo
3401                 kkll=0
3402                 do k=1,2
3403                   do l=1,2
3404                     kkll=kkll+1
3405                     do m=1,3
3406                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3407                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3408                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3409                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3410                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3411                     enddo
3412                   enddo
3413                 enddo
3414                 ENDIF
3415                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3416 C Calculate contact energies
3417                 cosa4=4.0D0*cosa
3418                 wij=cosa-3.0D0*cosb*cosg
3419                 cosbg1=cosb+cosg
3420                 cosbg2=cosb-cosg
3421 c               fac3=dsqrt(-ael6i)/r0ij**3
3422                 fac3=dsqrt(-ael6i)*r3ij
3423 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3424                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3425                 if (ees0tmp.gt.0) then
3426                   ees0pij=dsqrt(ees0tmp)
3427                 else
3428                   ees0pij=0
3429                 endif
3430 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3431                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3432                 if (ees0tmp.gt.0) then
3433                   ees0mij=dsqrt(ees0tmp)
3434                 else
3435                   ees0mij=0
3436                 endif
3437 c               ees0mij=0.0D0
3438                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3439                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3440 C Diagnostics. Comment out or remove after debugging!
3441 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3442 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3443 c               ees0m(num_conti,i)=0.0D0
3444 C End diagnostics.
3445 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3446 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3447 C Angular derivatives of the contact function
3448                 ees0pij1=fac3/ees0pij
3449                 ees0mij1=fac3/ees0mij
3450                 fac3p=-3.0D0*fac3*rrmij
3451                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3452                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3453 c               ees0mij1=0.0D0
3454                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3455                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3456                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3457                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3458                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3459                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3460                 ecosap=ecosa1+ecosa2
3461                 ecosbp=ecosb1+ecosb2
3462                 ecosgp=ecosg1+ecosg2
3463                 ecosam=ecosa1-ecosa2
3464                 ecosbm=ecosb1-ecosb2
3465                 ecosgm=ecosg1-ecosg2
3466 C Diagnostics
3467 c               ecosap=ecosa1
3468 c               ecosbp=ecosb1
3469 c               ecosgp=ecosg1
3470 c               ecosam=0.0D0
3471 c               ecosbm=0.0D0
3472 c               ecosgm=0.0D0
3473 C End diagnostics
3474                 facont_hb(num_conti,i)=fcont
3475                 fprimcont=fprimcont/rij
3476 cd              facont_hb(num_conti,i)=1.0D0
3477 C Following line is for diagnostics.
3478 cd              fprimcont=0.0D0
3479                 do k=1,3
3480                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3481                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3482                 enddo
3483                 do k=1,3
3484                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3485                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3486                 enddo
3487                 gggp(1)=gggp(1)+ees0pijp*xj
3488                 gggp(2)=gggp(2)+ees0pijp*yj
3489                 gggp(3)=gggp(3)+ees0pijp*zj
3490                 gggm(1)=gggm(1)+ees0mijp*xj
3491                 gggm(2)=gggm(2)+ees0mijp*yj
3492                 gggm(3)=gggm(3)+ees0mijp*zj
3493 C Derivatives due to the contact function
3494                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3495                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3496                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3497                 do k=1,3
3498 c
3499 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3500 c          following the change of gradient-summation algorithm.
3501 c
3502 cgrad                  ghalfp=0.5D0*gggp(k)
3503 cgrad                  ghalfm=0.5D0*gggm(k)
3504                   gacontp_hb1(k,num_conti,i)=!ghalfp
3505      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3506      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3507                   gacontp_hb2(k,num_conti,i)=!ghalfp
3508      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3509      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3510                   gacontp_hb3(k,num_conti,i)=gggp(k)
3511                   gacontm_hb1(k,num_conti,i)=!ghalfm
3512      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3513      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3514                   gacontm_hb2(k,num_conti,i)=!ghalfm
3515      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3516      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3517                   gacontm_hb3(k,num_conti,i)=gggm(k)
3518                 enddo
3519 C Diagnostics. Comment out or remove after debugging!
3520 cdiag           do k=1,3
3521 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3522 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3523 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3524 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3525 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3526 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3527 cdiag           enddo
3528               ENDIF ! wcorr
3529               endif  ! num_conti.le.maxconts
3530             endif  ! fcont.gt.0
3531           endif    ! j.gt.i+1
3532           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3533             do k=1,4
3534               do l=1,3
3535                 ghalf=0.5d0*agg(l,k)
3536                 aggi(l,k)=aggi(l,k)+ghalf
3537                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3538                 aggj(l,k)=aggj(l,k)+ghalf
3539               enddo
3540             enddo
3541             if (j.eq.nres-1 .and. i.lt.j-2) then
3542               do k=1,4
3543                 do l=1,3
3544                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3545                 enddo
3546               enddo
3547             endif
3548           endif
3549 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3550       return
3551       end
3552 C-----------------------------------------------------------------------------
3553       subroutine eturn3(i,eello_turn3)
3554 C Third- and fourth-order contributions from turns
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557       include 'COMMON.IOUNITS'
3558       include 'COMMON.GEO'
3559       include 'COMMON.VAR'
3560       include 'COMMON.LOCAL'
3561       include 'COMMON.CHAIN'
3562       include 'COMMON.DERIV'
3563       include 'COMMON.INTERACT'
3564       include 'COMMON.CONTACTS'
3565       include 'COMMON.TORSION'
3566       include 'COMMON.VECTORS'
3567       include 'COMMON.FFIELD'
3568       include 'COMMON.CONTROL'
3569       dimension ggg(3)
3570       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3571      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3572      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3573       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3574      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3575       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3576      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3577      &    num_conti,j1,j2
3578       j=i+2
3579 c      write (iout,*) "eturn3",i,j,j1,j2
3580       a_temp(1,1)=a22
3581       a_temp(1,2)=a23
3582       a_temp(2,1)=a32
3583       a_temp(2,2)=a33
3584 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3585 C
3586 C               Third-order contributions
3587 C
3588 C                 (i+2)o----(i+3)
3589 C                      | |
3590 C                      | |
3591 C                 (i+1)o----i
3592 C
3593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3594 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3595         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3596         call transpose2(auxmat(1,1),auxmat1(1,1))
3597         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3598         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3599         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3600      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3601 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3602 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3603 cd     &    ' eello_turn3_num',4*eello_turn3_num
3604 C Derivatives in gamma(i)
3605         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3606         call transpose2(auxmat2(1,1),auxmat3(1,1))
3607         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3608         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3609 C Derivatives in gamma(i+1)
3610         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3611         call transpose2(auxmat2(1,1),auxmat3(1,1))
3612         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3613         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3614      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3615 C Cartesian derivatives
3616         do l=1,3
3617 c            ghalf1=0.5d0*agg(l,1)
3618 c            ghalf2=0.5d0*agg(l,2)
3619 c            ghalf3=0.5d0*agg(l,3)
3620 c            ghalf4=0.5d0*agg(l,4)
3621           a_temp(1,1)=aggi(l,1)!+ghalf1
3622           a_temp(1,2)=aggi(l,2)!+ghalf2
3623           a_temp(2,1)=aggi(l,3)!+ghalf3
3624           a_temp(2,2)=aggi(l,4)!+ghalf4
3625           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3626           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3627      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3628           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3629           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3630           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3631           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3632           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3633           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3634      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3635           a_temp(1,1)=aggj(l,1)!+ghalf1
3636           a_temp(1,2)=aggj(l,2)!+ghalf2
3637           a_temp(2,1)=aggj(l,3)!+ghalf3
3638           a_temp(2,2)=aggj(l,4)!+ghalf4
3639           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3640           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3641      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3642           a_temp(1,1)=aggj1(l,1)
3643           a_temp(1,2)=aggj1(l,2)
3644           a_temp(2,1)=aggj1(l,3)
3645           a_temp(2,2)=aggj1(l,4)
3646           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3647           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3648      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3649         enddo
3650       return
3651       end
3652 C-------------------------------------------------------------------------------
3653       subroutine eturn4(i,eello_turn4)
3654 C Third- and fourth-order contributions from turns
3655       implicit real*8 (a-h,o-z)
3656       include 'DIMENSIONS'
3657       include 'COMMON.IOUNITS'
3658       include 'COMMON.GEO'
3659       include 'COMMON.VAR'
3660       include 'COMMON.LOCAL'
3661       include 'COMMON.CHAIN'
3662       include 'COMMON.DERIV'
3663       include 'COMMON.INTERACT'
3664       include 'COMMON.CONTACTS'
3665       include 'COMMON.TORSION'
3666       include 'COMMON.VECTORS'
3667       include 'COMMON.FFIELD'
3668       include 'COMMON.CONTROL'
3669       dimension ggg(3)
3670       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3671      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3672      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3673       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3674      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3675       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3676      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3677      &    num_conti,j1,j2
3678       j=i+3
3679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3680 C
3681 C               Fourth-order contributions
3682 C
3683 C                 (i+3)o----(i+4)
3684 C                     /  |
3685 C               (i+2)o   |
3686 C                     \  |
3687 C                 (i+1)o----i
3688 C
3689 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3690 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3691 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3692         a_temp(1,1)=a22
3693         a_temp(1,2)=a23
3694         a_temp(2,1)=a32
3695         a_temp(2,2)=a33
3696         iti1=itortyp(itype(i+1))
3697         iti2=itortyp(itype(i+2))
3698         iti3=itortyp(itype(i+3))
3699 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3700         call transpose2(EUg(1,1,i+1),e1t(1,1))
3701         call transpose2(Eug(1,1,i+2),e2t(1,1))
3702         call transpose2(Eug(1,1,i+3),e3t(1,1))
3703         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3704         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3705         s1=scalar2(b1(1,iti2),auxvec(1))
3706         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3707         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3708         s2=scalar2(b1(1,iti1),auxvec(1))
3709         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3710         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3711         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3712         eello_turn4=eello_turn4-(s1+s2+s3)
3713         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3714      &      'eturn4',i,j,-(s1+s2+s3)
3715 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3716 cd     &    ' eello_turn4_num',8*eello_turn4_num
3717 C Derivatives in gamma(i)
3718         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3719         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3720         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3721         s1=scalar2(b1(1,iti2),auxvec(1))
3722         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3723         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3725 C Derivatives in gamma(i+1)
3726         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3727         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3728         s2=scalar2(b1(1,iti1),auxvec(1))
3729         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3730         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3731         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3732         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3733 C Derivatives in gamma(i+2)
3734         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3735         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3736         s1=scalar2(b1(1,iti2),auxvec(1))
3737         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3738         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3739         s2=scalar2(b1(1,iti1),auxvec(1))
3740         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3741         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3742         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3744 C Cartesian derivatives
3745 C Derivatives of this turn contributions in DC(i+2)
3746         if (j.lt.nres-1) then
3747           do l=1,3
3748             a_temp(1,1)=agg(l,1)
3749             a_temp(1,2)=agg(l,2)
3750             a_temp(2,1)=agg(l,3)
3751             a_temp(2,2)=agg(l,4)
3752             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3753             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3754             s1=scalar2(b1(1,iti2),auxvec(1))
3755             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3756             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3757             s2=scalar2(b1(1,iti1),auxvec(1))
3758             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3759             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3760             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3761             ggg(l)=-(s1+s2+s3)
3762             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3763           enddo
3764         endif
3765 C Remaining derivatives of this turn contribution
3766         do l=1,3
3767           a_temp(1,1)=aggi(l,1)
3768           a_temp(1,2)=aggi(l,2)
3769           a_temp(2,1)=aggi(l,3)
3770           a_temp(2,2)=aggi(l,4)
3771           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3772           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3773           s1=scalar2(b1(1,iti2),auxvec(1))
3774           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3775           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3776           s2=scalar2(b1(1,iti1),auxvec(1))
3777           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3778           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3779           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3780           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3781           a_temp(1,1)=aggi1(l,1)
3782           a_temp(1,2)=aggi1(l,2)
3783           a_temp(2,1)=aggi1(l,3)
3784           a_temp(2,2)=aggi1(l,4)
3785           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3786           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3787           s1=scalar2(b1(1,iti2),auxvec(1))
3788           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3789           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3790           s2=scalar2(b1(1,iti1),auxvec(1))
3791           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3792           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3793           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3794           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3795           a_temp(1,1)=aggj(l,1)
3796           a_temp(1,2)=aggj(l,2)
3797           a_temp(2,1)=aggj(l,3)
3798           a_temp(2,2)=aggj(l,4)
3799           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3800           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3801           s1=scalar2(b1(1,iti2),auxvec(1))
3802           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3803           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3804           s2=scalar2(b1(1,iti1),auxvec(1))
3805           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3806           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3807           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3808           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3809           a_temp(1,1)=aggj1(l,1)
3810           a_temp(1,2)=aggj1(l,2)
3811           a_temp(2,1)=aggj1(l,3)
3812           a_temp(2,2)=aggj1(l,4)
3813           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3814           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3815           s1=scalar2(b1(1,iti2),auxvec(1))
3816           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3817           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3818           s2=scalar2(b1(1,iti1),auxvec(1))
3819           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3820           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3821           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3822 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3823           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3824         enddo
3825       return
3826       end
3827 C-----------------------------------------------------------------------------
3828       subroutine vecpr(u,v,w)
3829       implicit real*8(a-h,o-z)
3830       dimension u(3),v(3),w(3)
3831       w(1)=u(2)*v(3)-u(3)*v(2)
3832       w(2)=-u(1)*v(3)+u(3)*v(1)
3833       w(3)=u(1)*v(2)-u(2)*v(1)
3834       return
3835       end
3836 C-----------------------------------------------------------------------------
3837       subroutine unormderiv(u,ugrad,unorm,ungrad)
3838 C This subroutine computes the derivatives of a normalized vector u, given
3839 C the derivatives computed without normalization conditions, ugrad. Returns
3840 C ungrad.
3841       implicit none
3842       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3843       double precision vec(3)
3844       double precision scalar
3845       integer i,j
3846 c      write (2,*) 'ugrad',ugrad
3847 c      write (2,*) 'u',u
3848       do i=1,3
3849         vec(i)=scalar(ugrad(1,i),u(1))
3850       enddo
3851 c      write (2,*) 'vec',vec
3852       do i=1,3
3853         do j=1,3
3854           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3855         enddo
3856       enddo
3857 c      write (2,*) 'ungrad',ungrad
3858       return
3859       end
3860 C-----------------------------------------------------------------------------
3861       subroutine escp_soft_sphere(evdw2,evdw2_14)
3862 C
3863 C This subroutine calculates the excluded-volume interaction energy between
3864 C peptide-group centers and side chains and its gradient in virtual-bond and
3865 C side-chain vectors.
3866 C
3867       implicit real*8 (a-h,o-z)
3868       include 'DIMENSIONS'
3869       include 'COMMON.GEO'
3870       include 'COMMON.VAR'
3871       include 'COMMON.LOCAL'
3872       include 'COMMON.CHAIN'
3873       include 'COMMON.DERIV'
3874       include 'COMMON.INTERACT'
3875       include 'COMMON.FFIELD'
3876       include 'COMMON.IOUNITS'
3877       include 'COMMON.CONTROL'
3878       dimension ggg(3)
3879       evdw2=0.0D0
3880       evdw2_14=0.0d0
3881       r0_scp=4.5d0
3882 cd    print '(a)','Enter ESCP'
3883 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3884       do i=iatscp_s,iatscp_e
3885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3886         iteli=itel(i)
3887         xi=0.5D0*(c(1,i)+c(1,i+1))
3888         yi=0.5D0*(c(2,i)+c(2,i+1))
3889         zi=0.5D0*(c(3,i)+c(3,i+1))
3890
3891         do iint=1,nscp_gr(i)
3892
3893         do j=iscpstart(i,iint),iscpend(i,iint)
3894           if (itype(j).eq.ntyp1) cycle
3895           itypj=iabs(itype(j))
3896 C Uncomment following three lines for SC-p interactions
3897 c         xj=c(1,nres+j)-xi
3898 c         yj=c(2,nres+j)-yi
3899 c         zj=c(3,nres+j)-zi
3900 C Uncomment following three lines for Ca-p interactions
3901           xj=c(1,j)-xi
3902           yj=c(2,j)-yi
3903           zj=c(3,j)-zi
3904           rij=xj*xj+yj*yj+zj*zj
3905           r0ij=r0_scp
3906           r0ijsq=r0ij*r0ij
3907           if (rij.lt.r0ijsq) then
3908             evdwij=0.25d0*(rij-r0ijsq)**2
3909             fac=rij-r0ijsq
3910           else
3911             evdwij=0.0d0
3912             fac=0.0d0
3913           endif
3914           evdw2=evdw2+evdwij
3915 C
3916 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3917 C
3918           ggg(1)=xj*fac
3919           ggg(2)=yj*fac
3920           ggg(3)=zj*fac
3921 cgrad          if (j.lt.i) then
3922 cd          write (iout,*) 'j<i'
3923 C Uncomment following three lines for SC-p interactions
3924 c           do k=1,3
3925 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3926 c           enddo
3927 cgrad          else
3928 cd          write (iout,*) 'j>i'
3929 cgrad            do k=1,3
3930 cgrad              ggg(k)=-ggg(k)
3931 C Uncomment following line for SC-p interactions
3932 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3933 cgrad            enddo
3934 cgrad          endif
3935 cgrad          do k=1,3
3936 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3937 cgrad          enddo
3938 cgrad          kstart=min0(i+1,j)
3939 cgrad          kend=max0(i-1,j-1)
3940 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3941 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3942 cgrad          do k=kstart,kend
3943 cgrad            do l=1,3
3944 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3945 cgrad            enddo
3946 cgrad          enddo
3947           do k=1,3
3948             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3949             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3950           enddo
3951         enddo
3952
3953         enddo ! iint
3954       enddo ! i
3955       return
3956       end
3957 C-----------------------------------------------------------------------------
3958       subroutine escp(evdw2,evdw2_14)
3959 C
3960 C This subroutine calculates the excluded-volume interaction energy between
3961 C peptide-group centers and side chains and its gradient in virtual-bond and
3962 C side-chain vectors.
3963 C
3964       implicit real*8 (a-h,o-z)
3965       include 'DIMENSIONS'
3966       include 'COMMON.GEO'
3967       include 'COMMON.VAR'
3968       include 'COMMON.LOCAL'
3969       include 'COMMON.CHAIN'
3970       include 'COMMON.DERIV'
3971       include 'COMMON.INTERACT'
3972       include 'COMMON.FFIELD'
3973       include 'COMMON.IOUNITS'
3974       include 'COMMON.CONTROL'
3975       dimension ggg(3)
3976       evdw2=0.0D0
3977       evdw2_14=0.0d0
3978 cd    print '(a)','Enter ESCP'
3979 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3980       do i=iatscp_s,iatscp_e
3981         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3982         iteli=itel(i)
3983         xi=0.5D0*(c(1,i)+c(1,i+1))
3984         yi=0.5D0*(c(2,i)+c(2,i+1))
3985         zi=0.5D0*(c(3,i)+c(3,i+1))
3986
3987         do iint=1,nscp_gr(i)
3988
3989         do j=iscpstart(i,iint),iscpend(i,iint)
3990           itypj=iabs(itype(j))
3991           if (itypj.eq.ntyp1) cycle
3992 C Uncomment following three lines for SC-p interactions
3993 c         xj=c(1,nres+j)-xi
3994 c         yj=c(2,nres+j)-yi
3995 c         zj=c(3,nres+j)-zi
3996 C Uncomment following three lines for Ca-p interactions
3997           xj=c(1,j)-xi
3998           yj=c(2,j)-yi
3999           zj=c(3,j)-zi
4000           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4001           fac=rrij**expon2
4002           e1=fac*fac*aad(itypj,iteli)
4003           e2=fac*bad(itypj,iteli)
4004           if (iabs(j-i) .le. 2) then
4005             e1=scal14*e1
4006             e2=scal14*e2
4007             evdw2_14=evdw2_14+e1+e2
4008           endif
4009           evdwij=e1+e2
4010           evdw2=evdw2+evdwij
4011           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4012      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4013      &       bad(itypj,iteli)
4014 C
4015 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4016 C
4017           fac=-(evdwij+e1)*rrij
4018           ggg(1)=xj*fac
4019           ggg(2)=yj*fac
4020           ggg(3)=zj*fac
4021 cgrad          if (j.lt.i) then
4022 cd          write (iout,*) 'j<i'
4023 C Uncomment following three lines for SC-p interactions
4024 c           do k=1,3
4025 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4026 c           enddo
4027 cgrad          else
4028 cd          write (iout,*) 'j>i'
4029 cgrad            do k=1,3
4030 cgrad              ggg(k)=-ggg(k)
4031 C Uncomment following line for SC-p interactions
4032 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4033 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4034 cgrad            enddo
4035 cgrad          endif
4036 cgrad          do k=1,3
4037 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4038 cgrad          enddo
4039 cgrad          kstart=min0(i+1,j)
4040 cgrad          kend=max0(i-1,j-1)
4041 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4042 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4043 cgrad          do k=kstart,kend
4044 cgrad            do l=1,3
4045 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4046 cgrad            enddo
4047 cgrad          enddo
4048           do k=1,3
4049             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4050             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4051           enddo
4052         enddo
4053
4054         enddo ! iint
4055       enddo ! i
4056       do i=1,nct
4057         do j=1,3
4058           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4059           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4060           gradx_scp(j,i)=expon*gradx_scp(j,i)
4061         enddo
4062       enddo
4063 C******************************************************************************
4064 C
4065 C                              N O T E !!!
4066 C
4067 C To save time the factor EXPON has been extracted from ALL components
4068 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4069 C use!
4070 C
4071 C******************************************************************************
4072       return
4073       end
4074 C--------------------------------------------------------------------------
4075       subroutine edis(ehpb)
4076 C
4077 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4078 C
4079       implicit real*8 (a-h,o-z)
4080       include 'DIMENSIONS'
4081       include 'COMMON.SBRIDGE'
4082       include 'COMMON.CHAIN'
4083       include 'COMMON.DERIV'
4084       include 'COMMON.VAR'
4085       include 'COMMON.INTERACT'
4086       include 'COMMON.IOUNITS'
4087       include 'COMMON.CONTROL'
4088       dimension ggg(3)
4089       ehpb=0.0D0
4090 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4091 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4092       if (link_end.eq.0) return
4093       do i=link_start,link_end
4094 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4095 C CA-CA distance used in regularization of structure.
4096         ii=ihpb(i)
4097         jj=jhpb(i)
4098 C iii and jjj point to the residues for which the distance is assigned.
4099         if (ii.gt.nres) then
4100           iii=ii-nres
4101           jjj=jj-nres
4102         else
4103           iii=ii
4104           jjj=jj
4105         endif
4106 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4107 c     &    dhpb(i),dhpb1(i),forcon(i)
4108 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4109 C    distance and angle dependent SS bond potential.
4110 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4111 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4112         if (.not.dyn_ss .and. i.le.nss) then
4113 C 15/02/13 CC dynamic SSbond - additional check
4114          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4115      & iabs(itype(jjj)).eq.1) then
4116           call ssbond_ene(iii,jjj,eij)
4117           ehpb=ehpb+2*eij
4118          endif
4119 cd          write (iout,*) "eij",eij
4120 cd   &   ' waga=',waga,' fac=',fac
4121         else if (ii.gt.nres .and. jj.gt.nres) then
4122 c Restraints from contact prediction
4123           dd=dist(ii,jj)
4124           if (constr_dist.eq.11) then
4125             ehpb=ehpb+fordepth(i)**4
4126      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4127             fac=fordepth(i)**4
4128      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4129            else
4130           if (dhpb1(i).gt.0.0d0) then
4131             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4132             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4133 c            write (iout,*) "beta nmr",
4134 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4135           else
4136             dd=dist(ii,jj)
4137             rdis=dd-dhpb(i)
4138 C Get the force constant corresponding to this distance.
4139             waga=forcon(i)
4140 C Calculate the contribution to energy.
4141             ehpb=ehpb+waga*rdis*rdis
4142 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4143 C
4144 C Evaluate gradient.
4145 C
4146             fac=waga*rdis/dd
4147           endif
4148           endif
4149           do j=1,3
4150             ggg(j)=fac*(c(j,jj)-c(j,ii))
4151           enddo
4152           do j=1,3
4153             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4154             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4155           enddo
4156           do k=1,3
4157             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4158             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4159           enddo
4160         else
4161 C Calculate the distance between the two points and its difference from the
4162 C target distance.
4163           dd=dist(ii,jj)
4164           if (constr_dist.eq.11) then
4165             ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
4166             fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
4167            else
4168           if (dhpb1(i).gt.0.0d0) then
4169             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4170             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4171 c            write (iout,*) "alph nmr",
4172 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4173           else
4174             rdis=dd-dhpb(i)
4175 C Get the force constant corresponding to this distance.
4176             waga=forcon(i)
4177 C Calculate the contribution to energy.
4178             ehpb=ehpb+waga*rdis*rdis
4179 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4180 C
4181 C Evaluate gradient.
4182 C
4183             fac=waga*rdis/dd
4184           endif
4185           endif
4186             do j=1,3
4187               ggg(j)=fac*(c(j,jj)-c(j,ii))
4188             enddo
4189 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4190 C If this is a SC-SC distance, we need to calculate the contributions to the
4191 C Cartesian gradient in the SC vectors (ghpbx).
4192           if (iii.lt.ii) then
4193           do j=1,3
4194             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4195             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4196           enddo
4197           endif
4198 cgrad        do j=iii,jjj-1
4199 cgrad          do k=1,3
4200 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4201 cgrad          enddo
4202 cgrad        enddo
4203           do k=1,3
4204             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4205             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4206           enddo
4207         endif
4208       enddo
4209       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4210       return
4211       end
4212 C--------------------------------------------------------------------------
4213       subroutine ssbond_ene(i,j,eij)
4214 C
4215 C Calculate the distance and angle dependent SS-bond potential energy
4216 C using a free-energy function derived based on RHF/6-31G** ab initio
4217 C calculations of diethyl disulfide.
4218 C
4219 C A. Liwo and U. Kozlowska, 11/24/03
4220 C
4221       implicit real*8 (a-h,o-z)
4222       include 'DIMENSIONS'
4223       include 'COMMON.SBRIDGE'
4224       include 'COMMON.CHAIN'
4225       include 'COMMON.DERIV'
4226       include 'COMMON.LOCAL'
4227       include 'COMMON.INTERACT'
4228       include 'COMMON.VAR'
4229       include 'COMMON.IOUNITS'
4230       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4231       itypi=iabs(itype(i))
4232       xi=c(1,nres+i)
4233       yi=c(2,nres+i)
4234       zi=c(3,nres+i)
4235       dxi=dc_norm(1,nres+i)
4236       dyi=dc_norm(2,nres+i)
4237       dzi=dc_norm(3,nres+i)
4238 c      dsci_inv=dsc_inv(itypi)
4239       dsci_inv=vbld_inv(nres+i)
4240       itypj=iabs(itype(j))
4241 c      dscj_inv=dsc_inv(itypj)
4242       dscj_inv=vbld_inv(nres+j)
4243       xj=c(1,nres+j)-xi
4244       yj=c(2,nres+j)-yi
4245       zj=c(3,nres+j)-zi
4246       dxj=dc_norm(1,nres+j)
4247       dyj=dc_norm(2,nres+j)
4248       dzj=dc_norm(3,nres+j)
4249       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4250       rij=dsqrt(rrij)
4251       erij(1)=xj*rij
4252       erij(2)=yj*rij
4253       erij(3)=zj*rij
4254       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4255       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4256       om12=dxi*dxj+dyi*dyj+dzi*dzj
4257       do k=1,3
4258         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4259         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4260       enddo
4261       rij=1.0d0/rij
4262       deltad=rij-d0cm
4263       deltat1=1.0d0-om1
4264       deltat2=1.0d0+om2
4265       deltat12=om2-om1+2.0d0
4266       cosphi=om12-om1*om2
4267       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4268      &  +akct*deltad*deltat12
4269      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4270 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4271 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4272 c     &  " deltat12",deltat12," eij",eij
4273       ed=2*akcm*deltad+akct*deltat12
4274       pom1=akct*deltad
4275       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4276       eom1=-2*akth*deltat1-pom1-om2*pom2
4277       eom2= 2*akth*deltat2+pom1-om1*pom2
4278       eom12=pom2
4279       do k=1,3
4280         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4281         ghpbx(k,i)=ghpbx(k,i)-ggk
4282      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4283      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4284         ghpbx(k,j)=ghpbx(k,j)+ggk
4285      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4286      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4287         ghpbc(k,i)=ghpbc(k,i)-ggk
4288         ghpbc(k,j)=ghpbc(k,j)+ggk
4289       enddo
4290 C
4291 C Calculate the components of the gradient in DC and X
4292 C
4293 cgrad      do k=i,j-1
4294 cgrad        do l=1,3
4295 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4296 cgrad        enddo
4297 cgrad      enddo
4298       return
4299       end
4300 C--------------------------------------------------------------------------
4301       subroutine ebond(estr)
4302 c
4303 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4304 c
4305       implicit real*8 (a-h,o-z)
4306       include 'DIMENSIONS'
4307       include 'COMMON.LOCAL'
4308       include 'COMMON.GEO'
4309       include 'COMMON.INTERACT'
4310       include 'COMMON.DERIV'
4311       include 'COMMON.VAR'
4312       include 'COMMON.CHAIN'
4313       include 'COMMON.IOUNITS'
4314       include 'COMMON.NAMES'
4315       include 'COMMON.FFIELD'
4316       include 'COMMON.CONTROL'
4317       include 'COMMON.SETUP'
4318       double precision u(3),ud(3)
4319       estr=0.0d0
4320       estr1=0.0d0
4321       do i=ibondp_start,ibondp_end
4322         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4323           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4324           do j=1,3
4325           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4326      &      *dc(j,i-1)/vbld(i)
4327           enddo
4328           if (energy_dec) write(iout,*)
4329      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4330         else
4331         diff = vbld(i)-vbldp0
4332         if (energy_dec) write (iout,*)
4333      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4334         estr=estr+diff*diff
4335         do j=1,3
4336           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4337         enddo
4338 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4339         endif
4340       enddo
4341       estr=0.5d0*AKP*estr+estr1
4342 c
4343 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4344 c
4345       do i=ibond_start,ibond_end
4346         iti=iabs(itype(i))
4347         if (iti.ne.10 .and. iti.ne.ntyp1) then
4348           nbi=nbondterm(iti)
4349           if (nbi.eq.1) then
4350             diff=vbld(i+nres)-vbldsc0(1,iti)
4351             if (energy_dec) write (iout,*)
4352      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4353      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4354             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4355             do j=1,3
4356               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4357             enddo
4358           else
4359             do j=1,nbi
4360               diff=vbld(i+nres)-vbldsc0(j,iti)
4361               ud(j)=aksc(j,iti)*diff
4362               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4363             enddo
4364             uprod=u(1)
4365             do j=2,nbi
4366               uprod=uprod*u(j)
4367             enddo
4368             usum=0.0d0
4369             usumsqder=0.0d0
4370             do j=1,nbi
4371               uprod1=1.0d0
4372               uprod2=1.0d0
4373               do k=1,nbi
4374                 if (k.ne.j) then
4375                   uprod1=uprod1*u(k)
4376                   uprod2=uprod2*u(k)*u(k)
4377                 endif
4378               enddo
4379               usum=usum+uprod1
4380               usumsqder=usumsqder+ud(j)*uprod2
4381             enddo
4382             estr=estr+uprod/usum
4383             do j=1,3
4384              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4385             enddo
4386           endif
4387         endif
4388       enddo
4389       return
4390       end
4391 #ifdef CRYST_THETA
4392 C--------------------------------------------------------------------------
4393       subroutine ebend(etheta)
4394 C
4395 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4396 C angles gamma and its derivatives in consecutive thetas and gammas.
4397 C
4398       implicit real*8 (a-h,o-z)
4399       include 'DIMENSIONS'
4400       include 'COMMON.LOCAL'
4401       include 'COMMON.GEO'
4402       include 'COMMON.INTERACT'
4403       include 'COMMON.DERIV'
4404       include 'COMMON.VAR'
4405       include 'COMMON.CHAIN'
4406       include 'COMMON.IOUNITS'
4407       include 'COMMON.NAMES'
4408       include 'COMMON.FFIELD'
4409       include 'COMMON.CONTROL'
4410       common /calcthet/ term1,term2,termm,diffak,ratak,
4411      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4412      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4413       double precision y(2),z(2)
4414       delta=0.02d0*pi
4415 c      time11=dexp(-2*time)
4416 c      time12=1.0d0
4417       etheta=0.0D0
4418 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4419       do i=ithet_start,ithet_end
4420         if (itype(i-1).eq.ntyp1) cycle
4421 C Zero the energy function and its derivative at 0 or pi.
4422         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4423         it=itype(i-1)
4424         ichir1=isign(1,itype(i-2))
4425         ichir2=isign(1,itype(i))
4426          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4427          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4428          if (itype(i-1).eq.10) then
4429           itype1=isign(10,itype(i-2))
4430           ichir11=isign(1,itype(i-2))
4431           ichir12=isign(1,itype(i-2))
4432           itype2=isign(10,itype(i))
4433           ichir21=isign(1,itype(i))
4434           ichir22=isign(1,itype(i))
4435          endif
4436
4437         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4438 #ifdef OSF
4439           phii=phi(i)
4440           if (phii.ne.phii) phii=150.0
4441 #else
4442           phii=phi(i)
4443 #endif
4444           y(1)=dcos(phii)
4445           y(2)=dsin(phii)
4446         else
4447           y(1)=0.0D0
4448           y(2)=0.0D0
4449         endif
4450         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4451 #ifdef OSF
4452           phii1=phi(i+1)
4453           if (phii1.ne.phii1) phii1=150.0
4454           phii1=pinorm(phii1)
4455           z(1)=cos(phii1)
4456 #else
4457           phii1=phi(i+1)
4458           z(1)=dcos(phii1)
4459 #endif
4460           z(2)=dsin(phii1)
4461         else
4462           z(1)=0.0D0
4463           z(2)=0.0D0
4464         endif
4465 C Calculate the "mean" value of theta from the part of the distribution
4466 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4467 C In following comments this theta will be referred to as t_c.
4468         thet_pred_mean=0.0d0
4469         do k=1,2
4470             athetk=athet(k,it,ichir1,ichir2)
4471             bthetk=bthet(k,it,ichir1,ichir2)
4472           if (it.eq.10) then
4473              athetk=athet(k,itype1,ichir11,ichir12)
4474              bthetk=bthet(k,itype2,ichir21,ichir22)
4475           endif
4476          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4477         enddo
4478         dthett=thet_pred_mean*ssd
4479         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4480 C Derivatives of the "mean" values in gamma1 and gamma2.
4481         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4482      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4483          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4484      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4485          if (it.eq.10) then
4486       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4487      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4488         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4489      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4490          endif
4491         if (theta(i).gt.pi-delta) then
4492           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4493      &         E_tc0)
4494           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4495           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4496           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4497      &        E_theta)
4498           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4499      &        E_tc)
4500         else if (theta(i).lt.delta) then
4501           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4502           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4503           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4504      &        E_theta)
4505           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4506           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4507      &        E_tc)
4508         else
4509           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4510      &        E_theta,E_tc)
4511         endif
4512         etheta=etheta+ethetai
4513         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4514      &      'ebend',i,ethetai
4515         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4516         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4517         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4518       enddo
4519 C Ufff.... We've done all this!!!
4520       return
4521       end
4522 C---------------------------------------------------------------------------
4523       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4524      &     E_tc)
4525       implicit real*8 (a-h,o-z)
4526       include 'DIMENSIONS'
4527       include 'COMMON.LOCAL'
4528       include 'COMMON.IOUNITS'
4529       common /calcthet/ term1,term2,termm,diffak,ratak,
4530      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4531      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4532 C Calculate the contributions to both Gaussian lobes.
4533 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4534 C The "polynomial part" of the "standard deviation" of this part of
4535 C the distribution.
4536         sig=polthet(3,it)
4537         do j=2,0,-1
4538           sig=sig*thet_pred_mean+polthet(j,it)
4539         enddo
4540 C Derivative of the "interior part" of the "standard deviation of the"
4541 C gamma-dependent Gaussian lobe in t_c.
4542         sigtc=3*polthet(3,it)
4543         do j=2,1,-1
4544           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4545         enddo
4546         sigtc=sig*sigtc
4547 C Set the parameters of both Gaussian lobes of the distribution.
4548 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4549         fac=sig*sig+sigc0(it)
4550         sigcsq=fac+fac
4551         sigc=1.0D0/sigcsq
4552 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4553         sigsqtc=-4.0D0*sigcsq*sigtc
4554 c       print *,i,sig,sigtc,sigsqtc
4555 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4556         sigtc=-sigtc/(fac*fac)
4557 C Following variable is sigma(t_c)**(-2)
4558         sigcsq=sigcsq*sigcsq
4559         sig0i=sig0(it)
4560         sig0inv=1.0D0/sig0i**2
4561         delthec=thetai-thet_pred_mean
4562         delthe0=thetai-theta0i
4563         term1=-0.5D0*sigcsq*delthec*delthec
4564         term2=-0.5D0*sig0inv*delthe0*delthe0
4565 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4566 C NaNs in taking the logarithm. We extract the largest exponent which is added
4567 C to the energy (this being the log of the distribution) at the end of energy
4568 C term evaluation for this virtual-bond angle.
4569         if (term1.gt.term2) then
4570           termm=term1
4571           term2=dexp(term2-termm)
4572           term1=1.0d0
4573         else
4574           termm=term2
4575           term1=dexp(term1-termm)
4576           term2=1.0d0
4577         endif
4578 C The ratio between the gamma-independent and gamma-dependent lobes of
4579 C the distribution is a Gaussian function of thet_pred_mean too.
4580         diffak=gthet(2,it)-thet_pred_mean
4581         ratak=diffak/gthet(3,it)**2
4582         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4583 C Let's differentiate it in thet_pred_mean NOW.
4584         aktc=ak*ratak
4585 C Now put together the distribution terms to make complete distribution.
4586         termexp=term1+ak*term2
4587         termpre=sigc+ak*sig0i
4588 C Contribution of the bending energy from this theta is just the -log of
4589 C the sum of the contributions from the two lobes and the pre-exponential
4590 C factor. Simple enough, isn't it?
4591         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4592 C NOW the derivatives!!!
4593 C 6/6/97 Take into account the deformation.
4594         E_theta=(delthec*sigcsq*term1
4595      &       +ak*delthe0*sig0inv*term2)/termexp
4596         E_tc=((sigtc+aktc*sig0i)/termpre
4597      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4598      &       aktc*term2)/termexp)
4599       return
4600       end
4601 c-----------------------------------------------------------------------------
4602       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4603       implicit real*8 (a-h,o-z)
4604       include 'DIMENSIONS'
4605       include 'COMMON.LOCAL'
4606       include 'COMMON.IOUNITS'
4607       common /calcthet/ term1,term2,termm,diffak,ratak,
4608      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4609      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4610       delthec=thetai-thet_pred_mean
4611       delthe0=thetai-theta0i
4612 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4613       t3 = thetai-thet_pred_mean
4614       t6 = t3**2
4615       t9 = term1
4616       t12 = t3*sigcsq
4617       t14 = t12+t6*sigsqtc
4618       t16 = 1.0d0
4619       t21 = thetai-theta0i
4620       t23 = t21**2
4621       t26 = term2
4622       t27 = t21*t26
4623       t32 = termexp
4624       t40 = t32**2
4625       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4626      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4627      & *(-t12*t9-ak*sig0inv*t27)
4628       return
4629       end
4630 #else
4631 C--------------------------------------------------------------------------
4632       subroutine ebend(etheta)
4633 C
4634 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4635 C angles gamma and its derivatives in consecutive thetas and gammas.
4636 C ab initio-derived potentials from
4637 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4638 C
4639       implicit real*8 (a-h,o-z)
4640       include 'DIMENSIONS'
4641       include 'COMMON.LOCAL'
4642       include 'COMMON.GEO'
4643       include 'COMMON.INTERACT'
4644       include 'COMMON.DERIV'
4645       include 'COMMON.VAR'
4646       include 'COMMON.CHAIN'
4647       include 'COMMON.IOUNITS'
4648       include 'COMMON.NAMES'
4649       include 'COMMON.FFIELD'
4650       include 'COMMON.CONTROL'
4651       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4652      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4653      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4654      & sinph1ph2(maxdouble,maxdouble)
4655       logical lprn /.false./, lprn1 /.false./
4656       etheta=0.0D0
4657       do i=ithet_start,ithet_end
4658         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4659      &(itype(i).eq.ntyp1)) cycle
4660 C        print *,i,theta(i)
4661         if (iabs(itype(i+1)).eq.20) iblock=2
4662         if (iabs(itype(i+1)).ne.20) iblock=1
4663         dethetai=0.0d0
4664         dephii=0.0d0
4665         dephii1=0.0d0
4666         theti2=0.5d0*theta(i)
4667         ityp2=ithetyp((itype(i-1)))
4668         do k=1,nntheterm
4669           coskt(k)=dcos(k*theti2)
4670           sinkt(k)=dsin(k*theti2)
4671         enddo
4672 C        print *,ethetai
4673
4674         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4675 #ifdef OSF
4676           phii=phi(i)
4677           if (phii.ne.phii) phii=150.0
4678 #else
4679           phii=phi(i)
4680 #endif
4681           ityp1=ithetyp((itype(i-2)))
4682 C propagation of chirality for glycine type
4683           do k=1,nsingle
4684             cosph1(k)=dcos(k*phii)
4685             sinph1(k)=dsin(k*phii)
4686           enddo
4687         else
4688           phii=0.0d0
4689           do k=1,nsingle
4690           ityp1=ithetyp((itype(i-2)))
4691             cosph1(k)=0.0d0
4692             sinph1(k)=0.0d0
4693           enddo
4694         endif
4695         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4696 #ifdef OSF
4697           phii1=phi(i+1)
4698           if (phii1.ne.phii1) phii1=150.0
4699           phii1=pinorm(phii1)
4700 #else
4701           phii1=phi(i+1)
4702 #endif
4703           ityp3=ithetyp((itype(i)))
4704           do k=1,nsingle
4705             cosph2(k)=dcos(k*phii1)
4706             sinph2(k)=dsin(k*phii1)
4707           enddo
4708         else
4709           phii1=0.0d0
4710           ityp3=ithetyp((itype(i)))
4711           do k=1,nsingle
4712             cosph2(k)=0.0d0
4713             sinph2(k)=0.0d0
4714           enddo
4715         endif
4716         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4717         do k=1,ndouble
4718           do l=1,k-1
4719             ccl=cosph1(l)*cosph2(k-l)
4720             ssl=sinph1(l)*sinph2(k-l)
4721             scl=sinph1(l)*cosph2(k-l)
4722             csl=cosph1(l)*sinph2(k-l)
4723             cosph1ph2(l,k)=ccl-ssl
4724             cosph1ph2(k,l)=ccl+ssl
4725             sinph1ph2(l,k)=scl+csl
4726             sinph1ph2(k,l)=scl-csl
4727           enddo
4728         enddo
4729         if (lprn) then
4730         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4731      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4732         write (iout,*) "coskt and sinkt"
4733         do k=1,nntheterm
4734           write (iout,*) k,coskt(k),sinkt(k)
4735         enddo
4736         endif
4737         do k=1,ntheterm
4738           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4739           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4740      &      *coskt(k)
4741           if (lprn)
4742      &    write (iout,*) "k",k,"
4743      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4744      &     " ethetai",ethetai
4745         enddo
4746         if (lprn) then
4747         write (iout,*) "cosph and sinph"
4748         do k=1,nsingle
4749           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4750         enddo
4751         write (iout,*) "cosph1ph2 and sinph2ph2"
4752         do k=2,ndouble
4753           do l=1,k-1
4754             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4755      &         sinph1ph2(l,k),sinph1ph2(k,l)
4756           enddo
4757         enddo
4758         write(iout,*) "ethetai",ethetai
4759         endif
4760 C       print *,ethetai
4761         do m=1,ntheterm2
4762           do k=1,nsingle
4763             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4764      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4765      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4766      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4767             ethetai=ethetai+sinkt(m)*aux
4768             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4769             dephii=dephii+k*sinkt(m)*(
4770      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4771      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4772             dephii1=dephii1+k*sinkt(m)*(
4773      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4774      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4775             if (lprn)
4776      &      write (iout,*) "m",m," k",k," bbthet",
4777      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4778      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4779      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4780      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4781 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4782           enddo
4783         enddo
4784 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4785 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4786 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4787 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4788         if (lprn)
4789      &  write(iout,*) "ethetai",ethetai
4790 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4791         do m=1,ntheterm3
4792           do k=2,ndouble
4793             do l=1,k-1
4794               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4795      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4796      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4797      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4798               ethetai=ethetai+sinkt(m)*aux
4799               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4800               dephii=dephii+l*sinkt(m)*(
4801      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4802      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4803      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4804      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4805               dephii1=dephii1+(k-l)*sinkt(m)*(
4806      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4807      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4808      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4809      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4810               if (lprn) then
4811               write (iout,*) "m",m," k",k," l",l," ffthet",
4812      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4813      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4814      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4815      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4816      &            " ethetai",ethetai
4817               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4818      &            cosph1ph2(k,l)*sinkt(m),
4819      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4820               endif
4821             enddo
4822           enddo
4823         enddo
4824 10      continue
4825 c        lprn1=.true.
4826 C        print *,ethetai
4827         if (lprn1)
4828      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4829      &   i,theta(i)*rad2deg,phii*rad2deg,
4830      &   phii1*rad2deg,ethetai
4831 c        lprn1=.false.
4832         etheta=etheta+ethetai
4833         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4834         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4835         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4836       enddo
4837       return
4838       end
4839 #endif
4840 #ifdef CRYST_SC
4841 c-----------------------------------------------------------------------------
4842       subroutine esc(escloc)
4843 C Calculate the local energy of a side chain and its derivatives in the
4844 C corresponding virtual-bond valence angles THETA and the spherical angles
4845 C ALPHA and OMEGA.
4846       implicit real*8 (a-h,o-z)
4847       include 'DIMENSIONS'
4848       include 'COMMON.GEO'
4849       include 'COMMON.LOCAL'
4850       include 'COMMON.VAR'
4851       include 'COMMON.INTERACT'
4852       include 'COMMON.DERIV'
4853       include 'COMMON.CHAIN'
4854       include 'COMMON.IOUNITS'
4855       include 'COMMON.NAMES'
4856       include 'COMMON.FFIELD'
4857       include 'COMMON.CONTROL'
4858       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4859      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4860       common /sccalc/ time11,time12,time112,theti,it,nlobit
4861       delta=0.02d0*pi
4862       escloc=0.0D0
4863 c     write (iout,'(a)') 'ESC'
4864       do i=loc_start,loc_end
4865         it=itype(i)
4866         if (it.eq.ntyp1) cycle
4867         if (it.eq.10) goto 1
4868         nlobit=nlob(iabs(it))
4869 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4870 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4871         theti=theta(i+1)-pipol
4872         x(1)=dtan(theti)
4873         x(2)=alph(i)
4874         x(3)=omeg(i)
4875
4876         if (x(2).gt.pi-delta) then
4877           xtemp(1)=x(1)
4878           xtemp(2)=pi-delta
4879           xtemp(3)=x(3)
4880           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4881           xtemp(2)=pi
4882           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4883           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4884      &        escloci,dersc(2))
4885           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4886      &        ddersc0(1),dersc(1))
4887           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4888      &        ddersc0(3),dersc(3))
4889           xtemp(2)=pi-delta
4890           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4891           xtemp(2)=pi
4892           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4893           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4894      &            dersc0(2),esclocbi,dersc02)
4895           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4896      &            dersc12,dersc01)
4897           call splinthet(x(2),0.5d0*delta,ss,ssd)
4898           dersc0(1)=dersc01
4899           dersc0(2)=dersc02
4900           dersc0(3)=0.0d0
4901           do k=1,3
4902             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4903           enddo
4904           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4905 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4906 c    &             esclocbi,ss,ssd
4907           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4908 c         escloci=esclocbi
4909 c         write (iout,*) escloci
4910         else if (x(2).lt.delta) then
4911           xtemp(1)=x(1)
4912           xtemp(2)=delta
4913           xtemp(3)=x(3)
4914           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4915           xtemp(2)=0.0d0
4916           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4917           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4918      &        escloci,dersc(2))
4919           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4920      &        ddersc0(1),dersc(1))
4921           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4922      &        ddersc0(3),dersc(3))
4923           xtemp(2)=delta
4924           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4925           xtemp(2)=0.0d0
4926           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4927           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4928      &            dersc0(2),esclocbi,dersc02)
4929           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4930      &            dersc12,dersc01)
4931           dersc0(1)=dersc01
4932           dersc0(2)=dersc02
4933           dersc0(3)=0.0d0
4934           call splinthet(x(2),0.5d0*delta,ss,ssd)
4935           do k=1,3
4936             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4937           enddo
4938           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4939 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4940 c    &             esclocbi,ss,ssd
4941           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4942 c         write (iout,*) escloci
4943         else
4944           call enesc(x,escloci,dersc,ddummy,.false.)
4945         endif
4946
4947         escloc=escloc+escloci
4948         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4949      &     'escloc',i,escloci
4950 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4951
4952         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4953      &   wscloc*dersc(1)
4954         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4955         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4956     1   continue
4957       enddo
4958       return
4959       end
4960 C---------------------------------------------------------------------------
4961       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4962       implicit real*8 (a-h,o-z)
4963       include 'DIMENSIONS'
4964       include 'COMMON.GEO'
4965       include 'COMMON.LOCAL'
4966       include 'COMMON.IOUNITS'
4967       common /sccalc/ time11,time12,time112,theti,it,nlobit
4968       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4969       double precision contr(maxlob,-1:1)
4970       logical mixed
4971 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4972         escloc_i=0.0D0
4973         do j=1,3
4974           dersc(j)=0.0D0
4975           if (mixed) ddersc(j)=0.0d0
4976         enddo
4977         x3=x(3)
4978
4979 C Because of periodicity of the dependence of the SC energy in omega we have
4980 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4981 C To avoid underflows, first compute & store the exponents.
4982
4983         do iii=-1,1
4984
4985           x(3)=x3+iii*dwapi
4986
4987           do j=1,nlobit
4988             do k=1,3
4989               z(k)=x(k)-censc(k,j,it)
4990             enddo
4991             do k=1,3
4992               Axk=0.0D0
4993               do l=1,3
4994                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4995               enddo
4996               Ax(k,j,iii)=Axk
4997             enddo
4998             expfac=0.0D0
4999             do k=1,3
5000               expfac=expfac+Ax(k,j,iii)*z(k)
5001             enddo
5002             contr(j,iii)=expfac
5003           enddo ! j
5004
5005         enddo ! iii
5006
5007         x(3)=x3
5008 C As in the case of ebend, we want to avoid underflows in exponentiation and
5009 C subsequent NaNs and INFs in energy calculation.
5010 C Find the largest exponent
5011         emin=contr(1,-1)
5012         do iii=-1,1
5013           do j=1,nlobit
5014             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5015           enddo
5016         enddo
5017         emin=0.5D0*emin
5018 cd      print *,'it=',it,' emin=',emin
5019
5020 C Compute the contribution to SC energy and derivatives
5021         do iii=-1,1
5022
5023           do j=1,nlobit
5024 #ifdef OSF
5025             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5026             if(adexp.ne.adexp) adexp=1.0
5027             expfac=dexp(adexp)
5028 #else
5029             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5030 #endif
5031 cd          print *,'j=',j,' expfac=',expfac
5032             escloc_i=escloc_i+expfac
5033             do k=1,3
5034               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5035             enddo
5036             if (mixed) then
5037               do k=1,3,2
5038                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5039      &            +gaussc(k,2,j,it))*expfac
5040               enddo
5041             endif
5042           enddo
5043
5044         enddo ! iii
5045
5046         dersc(1)=dersc(1)/cos(theti)**2
5047         ddersc(1)=ddersc(1)/cos(theti)**2
5048         ddersc(3)=ddersc(3)
5049
5050         escloci=-(dlog(escloc_i)-emin)
5051         do j=1,3
5052           dersc(j)=dersc(j)/escloc_i
5053         enddo
5054         if (mixed) then
5055           do j=1,3,2
5056             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5057           enddo
5058         endif
5059       return
5060       end
5061 C------------------------------------------------------------------------------
5062       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5063       implicit real*8 (a-h,o-z)
5064       include 'DIMENSIONS'
5065       include 'COMMON.GEO'
5066       include 'COMMON.LOCAL'
5067       include 'COMMON.IOUNITS'
5068       common /sccalc/ time11,time12,time112,theti,it,nlobit
5069       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5070       double precision contr(maxlob)
5071       logical mixed
5072
5073       escloc_i=0.0D0
5074
5075       do j=1,3
5076         dersc(j)=0.0D0
5077       enddo
5078
5079       do j=1,nlobit
5080         do k=1,2
5081           z(k)=x(k)-censc(k,j,it)
5082         enddo
5083         z(3)=dwapi
5084         do k=1,3
5085           Axk=0.0D0
5086           do l=1,3
5087             Axk=Axk+gaussc(l,k,j,it)*z(l)
5088           enddo
5089           Ax(k,j)=Axk
5090         enddo
5091         expfac=0.0D0
5092         do k=1,3
5093           expfac=expfac+Ax(k,j)*z(k)
5094         enddo
5095         contr(j)=expfac
5096       enddo ! j
5097
5098 C As in the case of ebend, we want to avoid underflows in exponentiation and
5099 C subsequent NaNs and INFs in energy calculation.
5100 C Find the largest exponent
5101       emin=contr(1)
5102       do j=1,nlobit
5103         if (emin.gt.contr(j)) emin=contr(j)
5104       enddo
5105       emin=0.5D0*emin
5106
5107 C Compute the contribution to SC energy and derivatives
5108
5109       dersc12=0.0d0
5110       do j=1,nlobit
5111         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5112         escloc_i=escloc_i+expfac
5113         do k=1,2
5114           dersc(k)=dersc(k)+Ax(k,j)*expfac
5115         enddo
5116         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5117      &            +gaussc(1,2,j,it))*expfac
5118         dersc(3)=0.0d0
5119       enddo
5120
5121       dersc(1)=dersc(1)/cos(theti)**2
5122       dersc12=dersc12/cos(theti)**2
5123       escloci=-(dlog(escloc_i)-emin)
5124       do j=1,2
5125         dersc(j)=dersc(j)/escloc_i
5126       enddo
5127       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5128       return
5129       end
5130 #else
5131 c----------------------------------------------------------------------------------
5132       subroutine esc(escloc)
5133 C Calculate the local energy of a side chain and its derivatives in the
5134 C corresponding virtual-bond valence angles THETA and the spherical angles
5135 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5136 C added by Urszula Kozlowska. 07/11/2007
5137 C
5138       implicit real*8 (a-h,o-z)
5139       include 'DIMENSIONS'
5140       include 'COMMON.GEO'
5141       include 'COMMON.LOCAL'
5142       include 'COMMON.VAR'
5143       include 'COMMON.SCROT'
5144       include 'COMMON.INTERACT'
5145       include 'COMMON.DERIV'
5146       include 'COMMON.CHAIN'
5147       include 'COMMON.IOUNITS'
5148       include 'COMMON.NAMES'
5149       include 'COMMON.FFIELD'
5150       include 'COMMON.CONTROL'
5151       include 'COMMON.VECTORS'
5152       double precision x_prime(3),y_prime(3),z_prime(3)
5153      &    , sumene,dsc_i,dp2_i,x(65),
5154      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5155      &    de_dxx,de_dyy,de_dzz,de_dt
5156       double precision s1_t,s1_6_t,s2_t,s2_6_t
5157       double precision
5158      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5159      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5160      & dt_dCi(3),dt_dCi1(3)
5161       common /sccalc/ time11,time12,time112,theti,it,nlobit
5162       delta=0.02d0*pi
5163       escloc=0.0D0
5164       do i=loc_start,loc_end
5165         if (itype(i).eq.ntyp1) cycle
5166         costtab(i+1) =dcos(theta(i+1))
5167         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5168         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5169         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5170         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5171         cosfac=dsqrt(cosfac2)
5172         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5173         sinfac=dsqrt(sinfac2)
5174         it=iabs(itype(i))
5175         if (it.eq.10) goto 1
5176 c
5177 C  Compute the axes of tghe local cartesian coordinates system; store in
5178 c   x_prime, y_prime and z_prime
5179 c
5180         do j=1,3
5181           x_prime(j) = 0.00
5182           y_prime(j) = 0.00
5183           z_prime(j) = 0.00
5184         enddo
5185 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5186 C     &   dc_norm(3,i+nres)
5187         do j = 1,3
5188           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5189           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5190         enddo
5191         do j = 1,3
5192           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5193         enddo
5194 c       write (2,*) "i",i
5195 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5196 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5197 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5198 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5199 c      & " xy",scalar(x_prime(1),y_prime(1)),
5200 c      & " xz",scalar(x_prime(1),z_prime(1)),
5201 c      & " yy",scalar(y_prime(1),y_prime(1)),
5202 c      & " yz",scalar(y_prime(1),z_prime(1)),
5203 c      & " zz",scalar(z_prime(1),z_prime(1))
5204 c
5205 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5206 C to local coordinate system. Store in xx, yy, zz.
5207 c
5208         xx=0.0d0
5209         yy=0.0d0
5210         zz=0.0d0
5211         do j = 1,3
5212           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5213           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5214           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5215         enddo
5216
5217         xxtab(i)=xx
5218         yytab(i)=yy
5219         zztab(i)=zz
5220 C
5221 C Compute the energy of the ith side cbain
5222 C
5223 c        write (2,*) "xx",xx," yy",yy," zz",zz
5224         it=iabs(itype(i))
5225         do j = 1,65
5226           x(j) = sc_parmin(j,it)
5227         enddo
5228 #ifdef CHECK_COORD
5229 Cc diagnostics - remove later
5230         xx1 = dcos(alph(2))
5231         yy1 = dsin(alph(2))*dcos(omeg(2))
5232         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5233         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5234      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5235      &    xx1,yy1,zz1
5236 C,"  --- ", xx_w,yy_w,zz_w
5237 c end diagnostics
5238 #endif
5239         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5240      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5241      &   + x(10)*yy*zz
5242         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5243      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5244      & + x(20)*yy*zz
5245         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5246      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5247      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5248      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5249      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5250      &  +x(40)*xx*yy*zz
5251         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5252      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5253      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5254      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5255      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5256      &  +x(60)*xx*yy*zz
5257         dsc_i   = 0.743d0+x(61)
5258         dp2_i   = 1.9d0+x(62)
5259         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5260      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5261         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5262      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5263         s1=(1+x(63))/(0.1d0 + dscp1)
5264         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5265         s2=(1+x(65))/(0.1d0 + dscp2)
5266         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5267         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5268      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5269 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5270 c     &   sumene4,
5271 c     &   dscp1,dscp2,sumene
5272 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5273         escloc = escloc + sumene
5274 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5275 c     & ,zz,xx,yy
5276 c#define DEBUG
5277 #ifdef DEBUG
5278 C
5279 C This section to check the numerical derivatives of the energy of ith side
5280 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5281 C #define DEBUG in the code to turn it on.
5282 C
5283         write (2,*) "sumene               =",sumene
5284         aincr=1.0d-7
5285         xxsave=xx
5286         xx=xx+aincr
5287         write (2,*) xx,yy,zz
5288         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5289         de_dxx_num=(sumenep-sumene)/aincr
5290         xx=xxsave
5291         write (2,*) "xx+ sumene from enesc=",sumenep
5292         yysave=yy
5293         yy=yy+aincr
5294         write (2,*) xx,yy,zz
5295         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5296         de_dyy_num=(sumenep-sumene)/aincr
5297         yy=yysave
5298         write (2,*) "yy+ sumene from enesc=",sumenep
5299         zzsave=zz
5300         zz=zz+aincr
5301         write (2,*) xx,yy,zz
5302         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5303         de_dzz_num=(sumenep-sumene)/aincr
5304         zz=zzsave
5305         write (2,*) "zz+ sumene from enesc=",sumenep
5306         costsave=cost2tab(i+1)
5307         sintsave=sint2tab(i+1)
5308         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5309         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5310         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5311         de_dt_num=(sumenep-sumene)/aincr
5312         write (2,*) " t+ sumene from enesc=",sumenep
5313         cost2tab(i+1)=costsave
5314         sint2tab(i+1)=sintsave
5315 C End of diagnostics section.
5316 #endif
5317 C
5318 C Compute the gradient of esc
5319 C
5320 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5321         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5322         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5323         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5324         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5325         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5326         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5327         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5328         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5329         pom1=(sumene3*sint2tab(i+1)+sumene1)
5330      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5331         pom2=(sumene4*cost2tab(i+1)+sumene2)
5332      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5333         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5334         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5335      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5336      &  +x(40)*yy*zz
5337         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5338         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5339      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5340      &  +x(60)*yy*zz
5341         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5342      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5343      &        +(pom1+pom2)*pom_dx
5344 #ifdef DEBUG
5345         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5346 #endif
5347 C
5348         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5349         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5350      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5351      &  +x(40)*xx*zz
5352         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5353         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5354      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5355      &  +x(59)*zz**2 +x(60)*xx*zz
5356         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5357      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5358      &        +(pom1-pom2)*pom_dy
5359 #ifdef DEBUG
5360         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5361 #endif
5362 C
5363         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5364      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5365      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5366      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5367      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5368      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5369      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5370      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5371 #ifdef DEBUG
5372         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5373 #endif
5374 C
5375         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5376      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5377      &  +pom1*pom_dt1+pom2*pom_dt2
5378 #ifdef DEBUG
5379         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5380 #endif
5381 c#undef DEBUG
5382 c
5383 C
5384        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5385        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5386        cosfac2xx=cosfac2*xx
5387        sinfac2yy=sinfac2*yy
5388        do k = 1,3
5389          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5390      &      vbld_inv(i+1)
5391          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5392      &      vbld_inv(i)
5393          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5394          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5395 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5396 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5397 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5398 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5399          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5400          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5401          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5402          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5403          dZZ_Ci1(k)=0.0d0
5404          dZZ_Ci(k)=0.0d0
5405          do j=1,3
5406            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5407      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5408            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5409      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5410          enddo
5411
5412          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5413          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5414          dZZ_XYZ(k)=vbld_inv(i+nres)*
5415      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5416 c
5417          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5418          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5419        enddo
5420
5421        do k=1,3
5422          dXX_Ctab(k,i)=dXX_Ci(k)
5423          dXX_C1tab(k,i)=dXX_Ci1(k)
5424          dYY_Ctab(k,i)=dYY_Ci(k)
5425          dYY_C1tab(k,i)=dYY_Ci1(k)
5426          dZZ_Ctab(k,i)=dZZ_Ci(k)
5427          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5428          dXX_XYZtab(k,i)=dXX_XYZ(k)
5429          dYY_XYZtab(k,i)=dYY_XYZ(k)
5430          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5431        enddo
5432
5433        do k = 1,3
5434 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5435 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5436 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5437 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5438 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5439 c     &    dt_dci(k)
5440 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5441 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5442          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5443      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5444          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5445      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5446          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5447      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5448        enddo
5449 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5450 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5451
5452 C to check gradient call subroutine check_grad
5453
5454     1 continue
5455       enddo
5456       return
5457       end
5458 c------------------------------------------------------------------------------
5459       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5460       implicit none
5461       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5462      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5463       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5464      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5465      &   + x(10)*yy*zz
5466       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5467      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5468      & + x(20)*yy*zz
5469       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5470      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5471      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5472      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5473      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5474      &  +x(40)*xx*yy*zz
5475       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5476      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5477      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5478      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5479      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5480      &  +x(60)*xx*yy*zz
5481       dsc_i   = 0.743d0+x(61)
5482       dp2_i   = 1.9d0+x(62)
5483       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5484      &          *(xx*cost2+yy*sint2))
5485       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5486      &          *(xx*cost2-yy*sint2))
5487       s1=(1+x(63))/(0.1d0 + dscp1)
5488       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5489       s2=(1+x(65))/(0.1d0 + dscp2)
5490       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5491       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5492      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5493       enesc=sumene
5494       return
5495       end
5496 #endif
5497 c------------------------------------------------------------------------------
5498       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5499 C
5500 C This procedure calculates two-body contact function g(rij) and its derivative:
5501 C
5502 C           eps0ij                                     !       x < -1
5503 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5504 C            0                                         !       x > 1
5505 C
5506 C where x=(rij-r0ij)/delta
5507 C
5508 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5509 C
5510       implicit none
5511       double precision rij,r0ij,eps0ij,fcont,fprimcont
5512       double precision x,x2,x4,delta
5513 c     delta=0.02D0*r0ij
5514 c      delta=0.2D0*r0ij
5515       x=(rij-r0ij)/delta
5516       if (x.lt.-1.0D0) then
5517         fcont=eps0ij
5518         fprimcont=0.0D0
5519       else if (x.le.1.0D0) then
5520         x2=x*x
5521         x4=x2*x2
5522         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5523         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5524       else
5525         fcont=0.0D0
5526         fprimcont=0.0D0
5527       endif
5528       return
5529       end
5530 c------------------------------------------------------------------------------
5531       subroutine splinthet(theti,delta,ss,ssder)
5532       implicit real*8 (a-h,o-z)
5533       include 'DIMENSIONS'
5534       include 'COMMON.VAR'
5535       include 'COMMON.GEO'
5536       thetup=pi-delta
5537       thetlow=delta
5538       if (theti.gt.pipol) then
5539         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5540       else
5541         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5542         ssder=-ssder
5543       endif
5544       return
5545       end
5546 c------------------------------------------------------------------------------
5547       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5548       implicit none
5549       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5550       double precision ksi,ksi2,ksi3,a1,a2,a3
5551       a1=fprim0*delta/(f1-f0)
5552       a2=3.0d0-2.0d0*a1
5553       a3=a1-2.0d0
5554       ksi=(x-x0)/delta
5555       ksi2=ksi*ksi
5556       ksi3=ksi2*ksi
5557       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5558       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5559       return
5560       end
5561 c------------------------------------------------------------------------------
5562       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5563       implicit none
5564       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5565       double precision ksi,ksi2,ksi3,a1,a2,a3
5566       ksi=(x-x0)/delta
5567       ksi2=ksi*ksi
5568       ksi3=ksi2*ksi
5569       a1=fprim0x*delta
5570       a2=3*(f1x-f0x)-2*fprim0x*delta
5571       a3=fprim0x*delta-2*(f1x-f0x)
5572       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5573       return
5574       end
5575 C-----------------------------------------------------------------------------
5576 #ifdef CRYST_TOR
5577 C-----------------------------------------------------------------------------
5578       subroutine etor(etors,edihcnstr)
5579       implicit real*8 (a-h,o-z)
5580       include 'DIMENSIONS'
5581       include 'COMMON.VAR'
5582       include 'COMMON.GEO'
5583       include 'COMMON.LOCAL'
5584       include 'COMMON.TORSION'
5585       include 'COMMON.INTERACT'
5586       include 'COMMON.DERIV'
5587       include 'COMMON.CHAIN'
5588       include 'COMMON.NAMES'
5589       include 'COMMON.IOUNITS'
5590       include 'COMMON.FFIELD'
5591       include 'COMMON.TORCNSTR'
5592       include 'COMMON.CONTROL'
5593       logical lprn
5594 C Set lprn=.true. for debugging
5595       lprn=.false.
5596 c      lprn=.true.
5597       etors=0.0D0
5598       do i=iphi_start,iphi_end
5599       etors_ii=0.0D0
5600         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5601      &      .or. itype(i).eq.ntyp1) cycle
5602         itori=itortyp(itype(i-2))
5603         itori1=itortyp(itype(i-1))
5604         phii=phi(i)
5605         gloci=0.0D0
5606 C Proline-Proline pair is a special case...
5607         if (itori.eq.3 .and. itori1.eq.3) then
5608           if (phii.gt.-dwapi3) then
5609             cosphi=dcos(3*phii)
5610             fac=1.0D0/(1.0D0-cosphi)
5611             etorsi=v1(1,3,3)*fac
5612             etorsi=etorsi+etorsi
5613             etors=etors+etorsi-v1(1,3,3)
5614             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5615             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5616           endif
5617           do j=1,3
5618             v1ij=v1(j+1,itori,itori1)
5619             v2ij=v2(j+1,itori,itori1)
5620             cosphi=dcos(j*phii)
5621             sinphi=dsin(j*phii)
5622             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5623             if (energy_dec) etors_ii=etors_ii+
5624      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5625             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5626           enddo
5627         else
5628           do j=1,nterm_old
5629             v1ij=v1(j,itori,itori1)
5630             v2ij=v2(j,itori,itori1)
5631             cosphi=dcos(j*phii)
5632             sinphi=dsin(j*phii)
5633             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5634             if (energy_dec) etors_ii=etors_ii+
5635      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5636             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5637           enddo
5638         endif
5639         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5640              'etor',i,etors_ii
5641         if (lprn)
5642      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5643      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5644      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5645         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5646 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5647       enddo
5648 ! 6/20/98 - dihedral angle constraints
5649       edihcnstr=0.0d0
5650       do i=1,ndih_constr
5651         itori=idih_constr(i)
5652         phii=phi(itori)
5653         difi=phii-phi0(i)
5654         if (difi.gt.drange(i)) then
5655           difi=difi-drange(i)
5656           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5657           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5658         else if (difi.lt.-drange(i)) then
5659           difi=difi+drange(i)
5660           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5661           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5662         endif
5663 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5664 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5665       enddo
5666 !      write (iout,*) 'edihcnstr',edihcnstr
5667       return
5668       end
5669 c------------------------------------------------------------------------------
5670       subroutine etor_d(etors_d)
5671       etors_d=0.0d0
5672       return
5673       end
5674 c----------------------------------------------------------------------------
5675 #else
5676       subroutine etor(etors,edihcnstr)
5677       implicit real*8 (a-h,o-z)
5678       include 'DIMENSIONS'
5679       include 'COMMON.VAR'
5680       include 'COMMON.GEO'
5681       include 'COMMON.LOCAL'
5682       include 'COMMON.TORSION'
5683       include 'COMMON.INTERACT'
5684       include 'COMMON.DERIV'
5685       include 'COMMON.CHAIN'
5686       include 'COMMON.NAMES'
5687       include 'COMMON.IOUNITS'
5688       include 'COMMON.FFIELD'
5689       include 'COMMON.TORCNSTR'
5690       include 'COMMON.CONTROL'
5691       logical lprn
5692 C Set lprn=.true. for debugging
5693       lprn=.false.
5694 c     lprn=.true.
5695       etors=0.0D0
5696       do i=iphi_start,iphi_end
5697         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5698      &       .or. itype(i).eq.ntyp1) cycle
5699         etors_ii=0.0D0
5700          if (iabs(itype(i)).eq.20) then
5701          iblock=2
5702          else
5703          iblock=1
5704          endif
5705         itori=itortyp(itype(i-2))
5706         itori1=itortyp(itype(i-1))
5707         phii=phi(i)
5708         gloci=0.0D0
5709 C Regular cosine and sine terms
5710         do j=1,nterm(itori,itori1,iblock)
5711           v1ij=v1(j,itori,itori1,iblock)
5712           v2ij=v2(j,itori,itori1,iblock)
5713           cosphi=dcos(j*phii)
5714           sinphi=dsin(j*phii)
5715           etors=etors+v1ij*cosphi+v2ij*sinphi
5716           if (energy_dec) etors_ii=etors_ii+
5717      &                v1ij*cosphi+v2ij*sinphi
5718           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5719         enddo
5720 C Lorentz terms
5721 C                         v1
5722 C  E = SUM ----------------------------------- - v1
5723 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5724 C
5725         cosphi=dcos(0.5d0*phii)
5726         sinphi=dsin(0.5d0*phii)
5727         do j=1,nlor(itori,itori1,iblock)
5728           vl1ij=vlor1(j,itori,itori1)
5729           vl2ij=vlor2(j,itori,itori1)
5730           vl3ij=vlor3(j,itori,itori1)
5731           pom=vl2ij*cosphi+vl3ij*sinphi
5732           pom1=1.0d0/(pom*pom+1.0d0)
5733           etors=etors+vl1ij*pom1
5734           if (energy_dec) etors_ii=etors_ii+
5735      &                vl1ij*pom1
5736           pom=-pom*pom1*pom1
5737           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5738         enddo
5739 C Subtract the constant term
5740         etors=etors-v0(itori,itori1,iblock)
5741           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5742      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5743         if (lprn)
5744      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5745      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5746      &  (v1(j,itori,itori1,iblock),j=1,6),
5747      &  (v2(j,itori,itori1,iblock),j=1,6)
5748         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5749 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5750       enddo
5751 ! 6/20/98 - dihedral angle constraints
5752       edihcnstr=0.0d0
5753 c      do i=1,ndih_constr
5754       do i=idihconstr_start,idihconstr_end
5755         itori=idih_constr(i)
5756         phii=phi(itori)
5757         difi=pinorm(phii-phi0(i))
5758         if (difi.gt.drange(i)) then
5759           difi=difi-drange(i)
5760           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5761           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5762         else if (difi.lt.-drange(i)) then
5763           difi=difi+drange(i)
5764           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5765           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5766         else
5767           difi=0.0
5768         endif
5769 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5770 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5771 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5772       enddo
5773 cd       write (iout,*) 'edihcnstr',edihcnstr
5774       return
5775       end
5776 c----------------------------------------------------------------------------
5777       subroutine etor_d(etors_d)
5778 C 6/23/01 Compute double torsional energy
5779       implicit real*8 (a-h,o-z)
5780       include 'DIMENSIONS'
5781       include 'COMMON.VAR'
5782       include 'COMMON.GEO'
5783       include 'COMMON.LOCAL'
5784       include 'COMMON.TORSION'
5785       include 'COMMON.INTERACT'
5786       include 'COMMON.DERIV'
5787       include 'COMMON.CHAIN'
5788       include 'COMMON.NAMES'
5789       include 'COMMON.IOUNITS'
5790       include 'COMMON.FFIELD'
5791       include 'COMMON.TORCNSTR'
5792       logical lprn
5793 C Set lprn=.true. for debugging
5794       lprn=.false.
5795 c     lprn=.true.
5796       etors_d=0.0D0
5797 c      write(iout,*) "a tu??"
5798       do i=iphid_start,iphid_end
5799         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5800      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5801         itori=itortyp(itype(i-2))
5802         itori1=itortyp(itype(i-1))
5803         itori2=itortyp(itype(i))
5804         phii=phi(i)
5805         phii1=phi(i+1)
5806         gloci1=0.0D0
5807         gloci2=0.0D0
5808         iblock=1
5809         if (iabs(itype(i+1)).eq.20) iblock=2
5810
5811 C Regular cosine and sine terms
5812         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5813           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5814           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5815           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5816           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5817           cosphi1=dcos(j*phii)
5818           sinphi1=dsin(j*phii)
5819           cosphi2=dcos(j*phii1)
5820           sinphi2=dsin(j*phii1)
5821           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5822      &     v2cij*cosphi2+v2sij*sinphi2
5823           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5824           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5825         enddo
5826         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5827           do l=1,k-1
5828             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5829             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5830             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5831             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5832             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5833             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5834             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5835             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5836             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5837      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5838             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5839      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5840             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5841      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5842           enddo
5843         enddo
5844         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5845         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5846       enddo
5847       return
5848       end
5849 #endif
5850 c------------------------------------------------------------------------------
5851       subroutine eback_sc_corr(esccor)
5852 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5853 c        conformational states; temporarily implemented as differences
5854 c        between UNRES torsional potentials (dependent on three types of
5855 c        residues) and the torsional potentials dependent on all 20 types
5856 c        of residues computed from AM1  energy surfaces of terminally-blocked
5857 c        amino-acid residues.
5858       implicit real*8 (a-h,o-z)
5859       include 'DIMENSIONS'
5860       include 'COMMON.VAR'
5861       include 'COMMON.GEO'
5862       include 'COMMON.LOCAL'
5863       include 'COMMON.TORSION'
5864       include 'COMMON.SCCOR'
5865       include 'COMMON.INTERACT'
5866       include 'COMMON.DERIV'
5867       include 'COMMON.CHAIN'
5868       include 'COMMON.NAMES'
5869       include 'COMMON.IOUNITS'
5870       include 'COMMON.FFIELD'
5871       include 'COMMON.CONTROL'
5872       logical lprn
5873 C Set lprn=.true. for debugging
5874       lprn=.false.
5875 c      lprn=.true.
5876 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5877       esccor=0.0D0
5878       do i=itau_start,itau_end
5879         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5880         esccor_ii=0.0D0
5881         isccori=isccortyp(itype(i-2))
5882         isccori1=isccortyp(itype(i-1))
5883 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5884         phii=phi(i)
5885         do intertyp=1,3 !intertyp
5886 cc Added 09 May 2012 (Adasko)
5887 cc  Intertyp means interaction type of backbone mainchain correlation:
5888 c   1 = SC...Ca...Ca...Ca
5889 c   2 = Ca...Ca...Ca...SC
5890 c   3 = SC...Ca...Ca...SCi
5891         gloci=0.0D0
5892         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5893      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5894      &      (itype(i-1).eq.ntyp1)))
5895      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5896      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5897      &     .or.(itype(i).eq.ntyp1)))
5898      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5899      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5900      &      (itype(i-3).eq.ntyp1)))) cycle
5901         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5902         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5903      & cycle
5904        do j=1,nterm_sccor(isccori,isccori1)
5905           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5906           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5907           cosphi=dcos(j*tauangle(intertyp,i))
5908           sinphi=dsin(j*tauangle(intertyp,i))
5909           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5910           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5911         enddo
5912 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5913         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5914         if (lprn)
5915      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5916      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5917      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5918      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5919         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5920        enddo !intertyp
5921       enddo
5922
5923       return
5924       end
5925 c----------------------------------------------------------------------------
5926       subroutine multibody(ecorr)
5927 C This subroutine calculates multi-body contributions to energy following
5928 C the idea of Skolnick et al. If side chains I and J make a contact and
5929 C at the same time side chains I+1 and J+1 make a contact, an extra
5930 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5931       implicit real*8 (a-h,o-z)
5932       include 'DIMENSIONS'
5933       include 'COMMON.IOUNITS'
5934       include 'COMMON.DERIV'
5935       include 'COMMON.INTERACT'
5936       include 'COMMON.CONTACTS'
5937       double precision gx(3),gx1(3)
5938       logical lprn
5939
5940 C Set lprn=.true. for debugging
5941       lprn=.false.
5942
5943       if (lprn) then
5944         write (iout,'(a)') 'Contact function values:'
5945         do i=nnt,nct-2
5946           write (iout,'(i2,20(1x,i2,f10.5))')
5947      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5948         enddo
5949       endif
5950       ecorr=0.0D0
5951       do i=nnt,nct
5952         do j=1,3
5953           gradcorr(j,i)=0.0D0
5954           gradxorr(j,i)=0.0D0
5955         enddo
5956       enddo
5957       do i=nnt,nct-2
5958
5959         DO ISHIFT = 3,4
5960
5961         i1=i+ishift
5962         num_conti=num_cont(i)
5963         num_conti1=num_cont(i1)
5964         do jj=1,num_conti
5965           j=jcont(jj,i)
5966           do kk=1,num_conti1
5967             j1=jcont(kk,i1)
5968             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5969 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5970 cd   &                   ' ishift=',ishift
5971 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5972 C The system gains extra energy.
5973               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5974             endif   ! j1==j+-ishift
5975           enddo     ! kk
5976         enddo       ! jj
5977
5978         ENDDO ! ISHIFT
5979
5980       enddo         ! i
5981       return
5982       end
5983 c------------------------------------------------------------------------------
5984       double precision function esccorr(i,j,k,l,jj,kk)
5985       implicit real*8 (a-h,o-z)
5986       include 'DIMENSIONS'
5987       include 'COMMON.IOUNITS'
5988       include 'COMMON.DERIV'
5989       include 'COMMON.INTERACT'
5990       include 'COMMON.CONTACTS'
5991       double precision gx(3),gx1(3)
5992       logical lprn
5993       lprn=.false.
5994       eij=facont(jj,i)
5995       ekl=facont(kk,k)
5996 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5997 C Calculate the multi-body contribution to energy.
5998 C Calculate multi-body contributions to the gradient.
5999 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6000 cd   & k,l,(gacont(m,kk,k),m=1,3)
6001       do m=1,3
6002         gx(m) =ekl*gacont(m,jj,i)
6003         gx1(m)=eij*gacont(m,kk,k)
6004         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6005         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6006         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6007         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6008       enddo
6009       do m=i,j-1
6010         do ll=1,3
6011           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6012         enddo
6013       enddo
6014       do m=k,l-1
6015         do ll=1,3
6016           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6017         enddo
6018       enddo
6019       esccorr=-eij*ekl
6020       return
6021       end
6022 c------------------------------------------------------------------------------
6023       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6024 C This subroutine calculates multi-body contributions to hydrogen-bonding
6025       implicit real*8 (a-h,o-z)
6026       include 'DIMENSIONS'
6027       include 'COMMON.IOUNITS'
6028 #ifdef MPI
6029       include "mpif.h"
6030       parameter (max_cont=maxconts)
6031       parameter (max_dim=26)
6032       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6033       double precision zapas(max_dim,maxconts,max_fg_procs),
6034      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6035       common /przechowalnia/ zapas
6036       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6037      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6038 #endif
6039       include 'COMMON.SETUP'
6040       include 'COMMON.FFIELD'
6041       include 'COMMON.DERIV'
6042       include 'COMMON.INTERACT'
6043       include 'COMMON.CONTACTS'
6044       include 'COMMON.CONTROL'
6045       include 'COMMON.LOCAL'
6046       double precision gx(3),gx1(3),time00
6047       logical lprn,ldone
6048
6049 C Set lprn=.true. for debugging
6050       lprn=.false.
6051 #ifdef MPI
6052       n_corr=0
6053       n_corr1=0
6054       if (nfgtasks.le.1) goto 30
6055       if (lprn) then
6056         write (iout,'(a)') 'Contact function values before RECEIVE:'
6057         do i=nnt,nct-2
6058           write (iout,'(2i3,50(1x,i2,f5.2))')
6059      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6060      &    j=1,num_cont_hb(i))
6061         enddo
6062       endif
6063       call flush(iout)
6064       do i=1,ntask_cont_from
6065         ncont_recv(i)=0
6066       enddo
6067       do i=1,ntask_cont_to
6068         ncont_sent(i)=0
6069       enddo
6070 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6071 c     & ntask_cont_to
6072 C Make the list of contacts to send to send to other procesors
6073 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6074 c      call flush(iout)
6075       do i=iturn3_start,iturn3_end
6076 c        write (iout,*) "make contact list turn3",i," num_cont",
6077 c     &    num_cont_hb(i)
6078         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6079       enddo
6080       do i=iturn4_start,iturn4_end
6081 c        write (iout,*) "make contact list turn4",i," num_cont",
6082 c     &   num_cont_hb(i)
6083         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6084       enddo
6085       do ii=1,nat_sent
6086         i=iat_sent(ii)
6087 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6088 c     &    num_cont_hb(i)
6089         do j=1,num_cont_hb(i)
6090         do k=1,4
6091           jjc=jcont_hb(j,i)
6092           iproc=iint_sent_local(k,jjc,ii)
6093 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6094           if (iproc.gt.0) then
6095             ncont_sent(iproc)=ncont_sent(iproc)+1
6096             nn=ncont_sent(iproc)
6097             zapas(1,nn,iproc)=i
6098             zapas(2,nn,iproc)=jjc
6099             zapas(3,nn,iproc)=facont_hb(j,i)
6100             zapas(4,nn,iproc)=ees0p(j,i)
6101             zapas(5,nn,iproc)=ees0m(j,i)
6102             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6103             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6104             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6105             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6106             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6107             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6108             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6109             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6110             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6111             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6112             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6113             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6114             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6115             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6116             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6117             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6118             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6119             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6120             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6121             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6122             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6123           endif
6124         enddo
6125         enddo
6126       enddo
6127       if (lprn) then
6128       write (iout,*)
6129      &  "Numbers of contacts to be sent to other processors",
6130      &  (ncont_sent(i),i=1,ntask_cont_to)
6131       write (iout,*) "Contacts sent"
6132       do ii=1,ntask_cont_to
6133         nn=ncont_sent(ii)
6134         iproc=itask_cont_to(ii)
6135         write (iout,*) nn," contacts to processor",iproc,
6136      &   " of CONT_TO_COMM group"
6137         do i=1,nn
6138           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6139         enddo
6140       enddo
6141       call flush(iout)
6142       endif
6143       CorrelType=477
6144       CorrelID=fg_rank+1
6145       CorrelType1=478
6146       CorrelID1=nfgtasks+fg_rank+1
6147       ireq=0
6148 C Receive the numbers of needed contacts from other processors
6149       do ii=1,ntask_cont_from
6150         iproc=itask_cont_from(ii)
6151         ireq=ireq+1
6152         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6153      &    FG_COMM,req(ireq),IERR)
6154       enddo
6155 c      write (iout,*) "IRECV ended"
6156 c      call flush(iout)
6157 C Send the number of contacts needed by other processors
6158       do ii=1,ntask_cont_to
6159         iproc=itask_cont_to(ii)
6160         ireq=ireq+1
6161         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6162      &    FG_COMM,req(ireq),IERR)
6163       enddo
6164 c      write (iout,*) "ISEND ended"
6165 c      write (iout,*) "number of requests (nn)",ireq
6166       call flush(iout)
6167       if (ireq.gt.0)
6168      &  call MPI_Waitall(ireq,req,status_array,ierr)
6169 c      write (iout,*)
6170 c     &  "Numbers of contacts to be received from other processors",
6171 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6172 c      call flush(iout)
6173 C Receive contacts
6174       ireq=0
6175       do ii=1,ntask_cont_from
6176         iproc=itask_cont_from(ii)
6177         nn=ncont_recv(ii)
6178 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6179 c     &   " of CONT_TO_COMM group"
6180         call flush(iout)
6181         if (nn.gt.0) then
6182           ireq=ireq+1
6183           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6184      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6185 c          write (iout,*) "ireq,req",ireq,req(ireq)
6186         endif
6187       enddo
6188 C Send the contacts to processors that need them
6189       do ii=1,ntask_cont_to
6190         iproc=itask_cont_to(ii)
6191         nn=ncont_sent(ii)
6192 c        write (iout,*) nn," contacts to processor",iproc,
6193 c     &   " of CONT_TO_COMM group"
6194         if (nn.gt.0) then
6195           ireq=ireq+1
6196           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6197      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6198 c          write (iout,*) "ireq,req",ireq,req(ireq)
6199 c          do i=1,nn
6200 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6201 c          enddo
6202         endif
6203       enddo
6204 c      write (iout,*) "number of requests (contacts)",ireq
6205 c      write (iout,*) "req",(req(i),i=1,4)
6206 c      call flush(iout)
6207       if (ireq.gt.0)
6208      & call MPI_Waitall(ireq,req,status_array,ierr)
6209       do iii=1,ntask_cont_from
6210         iproc=itask_cont_from(iii)
6211         nn=ncont_recv(iii)
6212         if (lprn) then
6213         write (iout,*) "Received",nn," contacts from processor",iproc,
6214      &   " of CONT_FROM_COMM group"
6215         call flush(iout)
6216         do i=1,nn
6217           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6218         enddo
6219         call flush(iout)
6220         endif
6221         do i=1,nn
6222           ii=zapas_recv(1,i,iii)
6223 c Flag the received contacts to prevent double-counting
6224           jj=-zapas_recv(2,i,iii)
6225 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6226 c          call flush(iout)
6227           nnn=num_cont_hb(ii)+1
6228           num_cont_hb(ii)=nnn
6229           jcont_hb(nnn,ii)=jj
6230           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6231           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6232           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6233           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6234           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6235           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6236           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6237           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6238           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6239           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6240           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6241           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6242           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6243           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6244           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6245           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6246           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6247           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6248           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6249           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6250           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6251           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6252           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6253           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6254         enddo
6255       enddo
6256       call flush(iout)
6257       if (lprn) then
6258         write (iout,'(a)') 'Contact function values after receive:'
6259         do i=nnt,nct-2
6260           write (iout,'(2i3,50(1x,i3,f5.2))')
6261      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6262      &    j=1,num_cont_hb(i))
6263         enddo
6264         call flush(iout)
6265       endif
6266    30 continue
6267 #endif
6268       if (lprn) then
6269         write (iout,'(a)') 'Contact function values:'
6270         do i=nnt,nct-2
6271           write (iout,'(2i3,50(1x,i3,f5.2))')
6272      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6273      &    j=1,num_cont_hb(i))
6274         enddo
6275       endif
6276       ecorr=0.0D0
6277 C Remove the loop below after debugging !!!
6278       do i=nnt,nct
6279         do j=1,3
6280           gradcorr(j,i)=0.0D0
6281           gradxorr(j,i)=0.0D0
6282         enddo
6283       enddo
6284 C Calculate the local-electrostatic correlation terms
6285       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6286         i1=i+1
6287         num_conti=num_cont_hb(i)
6288         num_conti1=num_cont_hb(i+1)
6289         do jj=1,num_conti
6290           j=jcont_hb(jj,i)
6291           jp=iabs(j)
6292           do kk=1,num_conti1
6293             j1=jcont_hb(kk,i1)
6294             jp1=iabs(j1)
6295 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6296 c     &         ' jj=',jj,' kk=',kk
6297             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6298      &          .or. j.lt.0 .and. j1.gt.0) .and.
6299      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6300 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6301 C The system gains extra energy.
6302               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6303               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6304      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6305               n_corr=n_corr+1
6306             else if (j1.eq.j) then
6307 C Contacts I-J and I-(J+1) occur simultaneously.
6308 C The system loses extra energy.
6309 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6310             endif
6311           enddo ! kk
6312           do kk=1,num_conti
6313             j1=jcont_hb(kk,i)
6314 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6315 c    &         ' jj=',jj,' kk=',kk
6316             if (j1.eq.j+1) then
6317 C Contacts I-J and (I+1)-J occur simultaneously.
6318 C The system loses extra energy.
6319 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6320             endif ! j1==j+1
6321           enddo ! kk
6322         enddo ! jj
6323       enddo ! i
6324       return
6325       end
6326 c------------------------------------------------------------------------------
6327       subroutine add_hb_contact(ii,jj,itask)
6328       implicit real*8 (a-h,o-z)
6329       include "DIMENSIONS"
6330       include "COMMON.IOUNITS"
6331       integer max_cont
6332       integer max_dim
6333       parameter (max_cont=maxconts)
6334       parameter (max_dim=26)
6335       include "COMMON.CONTACTS"
6336       double precision zapas(max_dim,maxconts,max_fg_procs),
6337      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6338       common /przechowalnia/ zapas
6339       integer i,j,ii,jj,iproc,itask(4),nn
6340 c      write (iout,*) "itask",itask
6341       do i=1,2
6342         iproc=itask(i)
6343         if (iproc.gt.0) then
6344           do j=1,num_cont_hb(ii)
6345             jjc=jcont_hb(j,ii)
6346 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6347             if (jjc.eq.jj) then
6348               ncont_sent(iproc)=ncont_sent(iproc)+1
6349               nn=ncont_sent(iproc)
6350               zapas(1,nn,iproc)=ii
6351               zapas(2,nn,iproc)=jjc
6352               zapas(3,nn,iproc)=facont_hb(j,ii)
6353               zapas(4,nn,iproc)=ees0p(j,ii)
6354               zapas(5,nn,iproc)=ees0m(j,ii)
6355               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6356               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6357               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6358               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6359               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6360               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6361               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6362               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6363               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6364               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6365               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6366               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6367               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6368               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6369               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6370               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6371               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6372               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6373               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6374               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6375               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6376               exit
6377             endif
6378           enddo
6379         endif
6380       enddo
6381       return
6382       end
6383 c------------------------------------------------------------------------------
6384       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6385      &  n_corr1)
6386 C This subroutine calculates multi-body contributions to hydrogen-bonding
6387       implicit real*8 (a-h,o-z)
6388       include 'DIMENSIONS'
6389       include 'COMMON.IOUNITS'
6390 #ifdef MPI
6391       include "mpif.h"
6392       parameter (max_cont=maxconts)
6393       parameter (max_dim=70)
6394       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6395       double precision zapas(max_dim,maxconts,max_fg_procs),
6396      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6397       common /przechowalnia/ zapas
6398       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6399      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6400 #endif
6401       include 'COMMON.SETUP'
6402       include 'COMMON.FFIELD'
6403       include 'COMMON.DERIV'
6404       include 'COMMON.LOCAL'
6405       include 'COMMON.INTERACT'
6406       include 'COMMON.CONTACTS'
6407       include 'COMMON.CHAIN'
6408       include 'COMMON.CONTROL'
6409       double precision gx(3),gx1(3)
6410       integer num_cont_hb_old(maxres)
6411       logical lprn,ldone
6412       double precision eello4,eello5,eelo6,eello_turn6
6413       external eello4,eello5,eello6,eello_turn6
6414 C Set lprn=.true. for debugging
6415       lprn=.false.
6416       eturn6=0.0d0
6417 #ifdef MPI
6418       do i=1,nres
6419         num_cont_hb_old(i)=num_cont_hb(i)
6420       enddo
6421       n_corr=0
6422       n_corr1=0
6423       if (nfgtasks.le.1) goto 30
6424       if (lprn) then
6425         write (iout,'(a)') 'Contact function values before RECEIVE:'
6426         do i=nnt,nct-2
6427           write (iout,'(2i3,50(1x,i2,f5.2))')
6428      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6429      &    j=1,num_cont_hb(i))
6430         enddo
6431       endif
6432       call flush(iout)
6433       do i=1,ntask_cont_from
6434         ncont_recv(i)=0
6435       enddo
6436       do i=1,ntask_cont_to
6437         ncont_sent(i)=0
6438       enddo
6439 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6440 c     & ntask_cont_to
6441 C Make the list of contacts to send to send to other procesors
6442       do i=iturn3_start,iturn3_end
6443 c        write (iout,*) "make contact list turn3",i," num_cont",
6444 c     &    num_cont_hb(i)
6445         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6446       enddo
6447       do i=iturn4_start,iturn4_end
6448 c        write (iout,*) "make contact list turn4",i," num_cont",
6449 c     &   num_cont_hb(i)
6450         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6451       enddo
6452       do ii=1,nat_sent
6453         i=iat_sent(ii)
6454 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6455 c     &    num_cont_hb(i)
6456         do j=1,num_cont_hb(i)
6457         do k=1,4
6458           jjc=jcont_hb(j,i)
6459           iproc=iint_sent_local(k,jjc,ii)
6460 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6461           if (iproc.ne.0) then
6462             ncont_sent(iproc)=ncont_sent(iproc)+1
6463             nn=ncont_sent(iproc)
6464             zapas(1,nn,iproc)=i
6465             zapas(2,nn,iproc)=jjc
6466             zapas(3,nn,iproc)=d_cont(j,i)
6467             ind=3
6468             do kk=1,3
6469               ind=ind+1
6470               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6471             enddo
6472             do kk=1,2
6473               do ll=1,2
6474                 ind=ind+1
6475                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6476               enddo
6477             enddo
6478             do jj=1,5
6479               do kk=1,3
6480                 do ll=1,2
6481                   do mm=1,2
6482                     ind=ind+1
6483                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6484                   enddo
6485                 enddo
6486               enddo
6487             enddo
6488           endif
6489         enddo
6490         enddo
6491       enddo
6492       if (lprn) then
6493       write (iout,*)
6494      &  "Numbers of contacts to be sent to other processors",
6495      &  (ncont_sent(i),i=1,ntask_cont_to)
6496       write (iout,*) "Contacts sent"
6497       do ii=1,ntask_cont_to
6498         nn=ncont_sent(ii)
6499         iproc=itask_cont_to(ii)
6500         write (iout,*) nn," contacts to processor",iproc,
6501      &   " of CONT_TO_COMM group"
6502         do i=1,nn
6503           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6504         enddo
6505       enddo
6506       call flush(iout)
6507       endif
6508       CorrelType=477
6509       CorrelID=fg_rank+1
6510       CorrelType1=478
6511       CorrelID1=nfgtasks+fg_rank+1
6512       ireq=0
6513 C Receive the numbers of needed contacts from other processors
6514       do ii=1,ntask_cont_from
6515         iproc=itask_cont_from(ii)
6516         ireq=ireq+1
6517         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6518      &    FG_COMM,req(ireq),IERR)
6519       enddo
6520 c      write (iout,*) "IRECV ended"
6521 c      call flush(iout)
6522 C Send the number of contacts needed by other processors
6523       do ii=1,ntask_cont_to
6524         iproc=itask_cont_to(ii)
6525         ireq=ireq+1
6526         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6527      &    FG_COMM,req(ireq),IERR)
6528       enddo
6529 c      write (iout,*) "ISEND ended"
6530 c      write (iout,*) "number of requests (nn)",ireq
6531       call flush(iout)
6532       if (ireq.gt.0)
6533      &  call MPI_Waitall(ireq,req,status_array,ierr)
6534 c      write (iout,*)
6535 c     &  "Numbers of contacts to be received from other processors",
6536 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6537 c      call flush(iout)
6538 C Receive contacts
6539       ireq=0
6540       do ii=1,ntask_cont_from
6541         iproc=itask_cont_from(ii)
6542         nn=ncont_recv(ii)
6543 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6544 c     &   " of CONT_TO_COMM group"
6545         call flush(iout)
6546         if (nn.gt.0) then
6547           ireq=ireq+1
6548           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6549      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6550 c          write (iout,*) "ireq,req",ireq,req(ireq)
6551         endif
6552       enddo
6553 C Send the contacts to processors that need them
6554       do ii=1,ntask_cont_to
6555         iproc=itask_cont_to(ii)
6556         nn=ncont_sent(ii)
6557 c        write (iout,*) nn," contacts to processor",iproc,
6558 c     &   " of CONT_TO_COMM group"
6559         if (nn.gt.0) then
6560           ireq=ireq+1
6561           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6562      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6563 c          write (iout,*) "ireq,req",ireq,req(ireq)
6564 c          do i=1,nn
6565 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6566 c          enddo
6567         endif
6568       enddo
6569 c      write (iout,*) "number of requests (contacts)",ireq
6570 c      write (iout,*) "req",(req(i),i=1,4)
6571 c      call flush(iout)
6572       if (ireq.gt.0)
6573      & call MPI_Waitall(ireq,req,status_array,ierr)
6574       do iii=1,ntask_cont_from
6575         iproc=itask_cont_from(iii)
6576         nn=ncont_recv(iii)
6577         if (lprn) then
6578         write (iout,*) "Received",nn," contacts from processor",iproc,
6579      &   " of CONT_FROM_COMM group"
6580         call flush(iout)
6581         do i=1,nn
6582           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6583         enddo
6584         call flush(iout)
6585         endif
6586         do i=1,nn
6587           ii=zapas_recv(1,i,iii)
6588 c Flag the received contacts to prevent double-counting
6589           jj=-zapas_recv(2,i,iii)
6590 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6591 c          call flush(iout)
6592           nnn=num_cont_hb(ii)+1
6593           num_cont_hb(ii)=nnn
6594           jcont_hb(nnn,ii)=jj
6595           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6596           ind=3
6597           do kk=1,3
6598             ind=ind+1
6599             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6600           enddo
6601           do kk=1,2
6602             do ll=1,2
6603               ind=ind+1
6604               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6605             enddo
6606           enddo
6607           do jj=1,5
6608             do kk=1,3
6609               do ll=1,2
6610                 do mm=1,2
6611                   ind=ind+1
6612                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6613                 enddo
6614               enddo
6615             enddo
6616           enddo
6617         enddo
6618       enddo
6619       call flush(iout)
6620       if (lprn) then
6621         write (iout,'(a)') 'Contact function values after receive:'
6622         do i=nnt,nct-2
6623           write (iout,'(2i3,50(1x,i3,5f6.3))')
6624      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6625      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6626         enddo
6627         call flush(iout)
6628       endif
6629    30 continue
6630 #endif
6631       if (lprn) then
6632         write (iout,'(a)') 'Contact function values:'
6633         do i=nnt,nct-2
6634           write (iout,'(2i3,50(1x,i2,5f6.3))')
6635      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6636      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6637         enddo
6638       endif
6639       ecorr=0.0D0
6640       ecorr5=0.0d0
6641       ecorr6=0.0d0
6642 C Remove the loop below after debugging !!!
6643       do i=nnt,nct
6644         do j=1,3
6645           gradcorr(j,i)=0.0D0
6646           gradxorr(j,i)=0.0D0
6647         enddo
6648       enddo
6649 C Calculate the dipole-dipole interaction energies
6650       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6651       do i=iatel_s,iatel_e+1
6652         num_conti=num_cont_hb(i)
6653         do jj=1,num_conti
6654           j=jcont_hb(jj,i)
6655 #ifdef MOMENT
6656           call dipole(i,j,jj)
6657 #endif
6658         enddo
6659       enddo
6660       endif
6661 C Calculate the local-electrostatic correlation terms
6662 c                write (iout,*) "gradcorr5 in eello5 before loop"
6663 c                do iii=1,nres
6664 c                  write (iout,'(i5,3f10.5)')
6665 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6666 c                enddo
6667       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6668 c        write (iout,*) "corr loop i",i
6669         i1=i+1
6670         num_conti=num_cont_hb(i)
6671         num_conti1=num_cont_hb(i+1)
6672         do jj=1,num_conti
6673           j=jcont_hb(jj,i)
6674           jp=iabs(j)
6675           do kk=1,num_conti1
6676             j1=jcont_hb(kk,i1)
6677             jp1=iabs(j1)
6678 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6679 c     &         ' jj=',jj,' kk=',kk
6680 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6681             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6682      &          .or. j.lt.0 .and. j1.gt.0) .and.
6683      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6684 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6685 C The system gains extra energy.
6686               n_corr=n_corr+1
6687               sqd1=dsqrt(d_cont(jj,i))
6688               sqd2=dsqrt(d_cont(kk,i1))
6689               sred_geom = sqd1*sqd2
6690               IF (sred_geom.lt.cutoff_corr) THEN
6691                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6692      &            ekont,fprimcont)
6693 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6694 cd     &         ' jj=',jj,' kk=',kk
6695                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6696                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6697                 do l=1,3
6698                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6699                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6700                 enddo
6701                 n_corr1=n_corr1+1
6702 cd               write (iout,*) 'sred_geom=',sred_geom,
6703 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6704 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6705 cd               write (iout,*) "g_contij",g_contij
6706 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6707 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6708                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6709                 if (wcorr4.gt.0.0d0)
6710      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6711                   if (energy_dec.and.wcorr4.gt.0.0d0)
6712      1                 write (iout,'(a6,4i5,0pf7.3)')
6713      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6714 c                write (iout,*) "gradcorr5 before eello5"
6715 c                do iii=1,nres
6716 c                  write (iout,'(i5,3f10.5)')
6717 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6718 c                enddo
6719                 if (wcorr5.gt.0.0d0)
6720      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6721 c                write (iout,*) "gradcorr5 after eello5"
6722 c                do iii=1,nres
6723 c                  write (iout,'(i5,3f10.5)')
6724 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6725 c                enddo
6726                   if (energy_dec.and.wcorr5.gt.0.0d0)
6727      1                 write (iout,'(a6,4i5,0pf7.3)')
6728      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6729 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6730 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6731                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6732      &               .or. wturn6.eq.0.0d0))then
6733 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6734                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6735                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6736      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6737 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6738 cd     &            'ecorr6=',ecorr6
6739 cd                write (iout,'(4e15.5)') sred_geom,
6740 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6741 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6742 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6743                 else if (wturn6.gt.0.0d0
6744      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6745 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6746                   eturn6=eturn6+eello_turn6(i,jj,kk)
6747                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6748      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6749 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6750                 endif
6751               ENDIF
6752 1111          continue
6753             endif
6754           enddo ! kk
6755         enddo ! jj
6756       enddo ! i
6757       do i=1,nres
6758         num_cont_hb(i)=num_cont_hb_old(i)
6759       enddo
6760 c                write (iout,*) "gradcorr5 in eello5"
6761 c                do iii=1,nres
6762 c                  write (iout,'(i5,3f10.5)')
6763 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6764 c                enddo
6765       return
6766       end
6767 c------------------------------------------------------------------------------
6768       subroutine add_hb_contact_eello(ii,jj,itask)
6769       implicit real*8 (a-h,o-z)
6770       include "DIMENSIONS"
6771       include "COMMON.IOUNITS"
6772       integer max_cont
6773       integer max_dim
6774       parameter (max_cont=maxconts)
6775       parameter (max_dim=70)
6776       include "COMMON.CONTACTS"
6777       double precision zapas(max_dim,maxconts,max_fg_procs),
6778      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6779       common /przechowalnia/ zapas
6780       integer i,j,ii,jj,iproc,itask(4),nn
6781 c      write (iout,*) "itask",itask
6782       do i=1,2
6783         iproc=itask(i)
6784         if (iproc.gt.0) then
6785           do j=1,num_cont_hb(ii)
6786             jjc=jcont_hb(j,ii)
6787 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6788             if (jjc.eq.jj) then
6789               ncont_sent(iproc)=ncont_sent(iproc)+1
6790               nn=ncont_sent(iproc)
6791               zapas(1,nn,iproc)=ii
6792               zapas(2,nn,iproc)=jjc
6793               zapas(3,nn,iproc)=d_cont(j,ii)
6794               ind=3
6795               do kk=1,3
6796                 ind=ind+1
6797                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6798               enddo
6799               do kk=1,2
6800                 do ll=1,2
6801                   ind=ind+1
6802                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6803                 enddo
6804               enddo
6805               do jj=1,5
6806                 do kk=1,3
6807                   do ll=1,2
6808                     do mm=1,2
6809                       ind=ind+1
6810                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6811                     enddo
6812                   enddo
6813                 enddo
6814               enddo
6815               exit
6816             endif
6817           enddo
6818         endif
6819       enddo
6820       return
6821       end
6822 c------------------------------------------------------------------------------
6823       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6824       implicit real*8 (a-h,o-z)
6825       include 'DIMENSIONS'
6826       include 'COMMON.IOUNITS'
6827       include 'COMMON.DERIV'
6828       include 'COMMON.INTERACT'
6829       include 'COMMON.CONTACTS'
6830       double precision gx(3),gx1(3)
6831       logical lprn
6832       lprn=.false.
6833       eij=facont_hb(jj,i)
6834       ekl=facont_hb(kk,k)
6835       ees0pij=ees0p(jj,i)
6836       ees0pkl=ees0p(kk,k)
6837       ees0mij=ees0m(jj,i)
6838       ees0mkl=ees0m(kk,k)
6839       ekont=eij*ekl
6840       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6841 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6842 C Following 4 lines for diagnostics.
6843 cd    ees0pkl=0.0D0
6844 cd    ees0pij=1.0D0
6845 cd    ees0mkl=0.0D0
6846 cd    ees0mij=1.0D0
6847 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6848 c     & 'Contacts ',i,j,
6849 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6850 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6851 c     & 'gradcorr_long'
6852 C Calculate the multi-body contribution to energy.
6853 c      ecorr=ecorr+ekont*ees
6854 C Calculate multi-body contributions to the gradient.
6855       coeffpees0pij=coeffp*ees0pij
6856       coeffmees0mij=coeffm*ees0mij
6857       coeffpees0pkl=coeffp*ees0pkl
6858       coeffmees0mkl=coeffm*ees0mkl
6859       do ll=1,3
6860 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6861         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6862      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6863      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6864         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6865      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6866      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6867 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6868         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6869      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6870      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6871         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6872      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6873      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6874         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6875      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6876      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6877         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6878         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6879         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6880      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6881      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6882         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6883         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6884 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6885       enddo
6886 c      write (iout,*)
6887 cgrad      do m=i+1,j-1
6888 cgrad        do ll=1,3
6889 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6890 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6891 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6892 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6893 cgrad        enddo
6894 cgrad      enddo
6895 cgrad      do m=k+1,l-1
6896 cgrad        do ll=1,3
6897 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6898 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6899 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6900 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6901 cgrad        enddo
6902 cgrad      enddo
6903 c      write (iout,*) "ehbcorr",ekont*ees
6904       ehbcorr=ekont*ees
6905       return
6906       end
6907 #ifdef MOMENT
6908 C---------------------------------------------------------------------------
6909       subroutine dipole(i,j,jj)
6910       implicit real*8 (a-h,o-z)
6911       include 'DIMENSIONS'
6912       include 'COMMON.IOUNITS'
6913       include 'COMMON.CHAIN'
6914       include 'COMMON.FFIELD'
6915       include 'COMMON.DERIV'
6916       include 'COMMON.INTERACT'
6917       include 'COMMON.CONTACTS'
6918       include 'COMMON.TORSION'
6919       include 'COMMON.VAR'
6920       include 'COMMON.GEO'
6921       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6922      &  auxmat(2,2)
6923       iti1 = itortyp(itype(i+1))
6924       if (j.lt.nres-1) then
6925         itj1 = itortyp(itype(j+1))
6926       else
6927         itj1=ntortyp+1
6928       endif
6929       do iii=1,2
6930         dipi(iii,1)=Ub2(iii,i)
6931         dipderi(iii)=Ub2der(iii,i)
6932         dipi(iii,2)=b1(iii,iti1)
6933         dipj(iii,1)=Ub2(iii,j)
6934         dipderj(iii)=Ub2der(iii,j)
6935         dipj(iii,2)=b1(iii,itj1)
6936       enddo
6937       kkk=0
6938       do iii=1,2
6939         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6940         do jjj=1,2
6941           kkk=kkk+1
6942           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6943         enddo
6944       enddo
6945       do kkk=1,5
6946         do lll=1,3
6947           mmm=0
6948           do iii=1,2
6949             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6950      &        auxvec(1))
6951             do jjj=1,2
6952               mmm=mmm+1
6953               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6954             enddo
6955           enddo
6956         enddo
6957       enddo
6958       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6959       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6960       do iii=1,2
6961         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6962       enddo
6963       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6964       do iii=1,2
6965         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6966       enddo
6967       return
6968       end
6969 #endif
6970 C---------------------------------------------------------------------------
6971       subroutine calc_eello(i,j,k,l,jj,kk)
6972 C
6973 C This subroutine computes matrices and vectors needed to calculate
6974 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6975 C
6976       implicit real*8 (a-h,o-z)
6977       include 'DIMENSIONS'
6978       include 'COMMON.IOUNITS'
6979       include 'COMMON.CHAIN'
6980       include 'COMMON.DERIV'
6981       include 'COMMON.INTERACT'
6982       include 'COMMON.CONTACTS'
6983       include 'COMMON.TORSION'
6984       include 'COMMON.VAR'
6985       include 'COMMON.GEO'
6986       include 'COMMON.FFIELD'
6987       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6988      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6989       logical lprn
6990       common /kutas/ lprn
6991 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6992 cd     & ' jj=',jj,' kk=',kk
6993 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6994 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6995 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6996       do iii=1,2
6997         do jjj=1,2
6998           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6999           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7000         enddo
7001       enddo
7002       call transpose2(aa1(1,1),aa1t(1,1))
7003       call transpose2(aa2(1,1),aa2t(1,1))
7004       do kkk=1,5
7005         do lll=1,3
7006           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7007      &      aa1tder(1,1,lll,kkk))
7008           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7009      &      aa2tder(1,1,lll,kkk))
7010         enddo
7011       enddo
7012       if (l.eq.j+1) then
7013 C parallel orientation of the two CA-CA-CA frames.
7014         if (i.gt.1) then
7015           iti=itortyp(itype(i))
7016         else
7017           iti=ntortyp+1
7018         endif
7019         itk1=itortyp(itype(k+1))
7020         itj=itortyp(itype(j))
7021         if (l.lt.nres-1) then
7022           itl1=itortyp(itype(l+1))
7023         else
7024           itl1=ntortyp+1
7025         endif
7026 C A1 kernel(j+1) A2T
7027 cd        do iii=1,2
7028 cd          write (iout,'(3f10.5,5x,3f10.5)')
7029 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7030 cd        enddo
7031         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7032      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7033      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7034 C Following matrices are needed only for 6-th order cumulants
7035         IF (wcorr6.gt.0.0d0) THEN
7036         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7037      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7038      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7039         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7040      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7041      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7042      &   ADtEAderx(1,1,1,1,1,1))
7043         lprn=.false.
7044         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7045      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7046      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7047      &   ADtEA1derx(1,1,1,1,1,1))
7048         ENDIF
7049 C End 6-th order cumulants
7050 cd        lprn=.false.
7051 cd        if (lprn) then
7052 cd        write (2,*) 'In calc_eello6'
7053 cd        do iii=1,2
7054 cd          write (2,*) 'iii=',iii
7055 cd          do kkk=1,5
7056 cd            write (2,*) 'kkk=',kkk
7057 cd            do jjj=1,2
7058 cd              write (2,'(3(2f10.5),5x)')
7059 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7060 cd            enddo
7061 cd          enddo
7062 cd        enddo
7063 cd        endif
7064         call transpose2(EUgder(1,1,k),auxmat(1,1))
7065         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7066         call transpose2(EUg(1,1,k),auxmat(1,1))
7067         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7068         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7069         do iii=1,2
7070           do kkk=1,5
7071             do lll=1,3
7072               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7073      &          EAEAderx(1,1,lll,kkk,iii,1))
7074             enddo
7075           enddo
7076         enddo
7077 C A1T kernel(i+1) A2
7078         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7079      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7080      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7081 C Following matrices are needed only for 6-th order cumulants
7082         IF (wcorr6.gt.0.0d0) THEN
7083         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7084      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7085      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7086         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7087      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7088      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7089      &   ADtEAderx(1,1,1,1,1,2))
7090         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7091      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7092      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7093      &   ADtEA1derx(1,1,1,1,1,2))
7094         ENDIF
7095 C End 6-th order cumulants
7096         call transpose2(EUgder(1,1,l),auxmat(1,1))
7097         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7098         call transpose2(EUg(1,1,l),auxmat(1,1))
7099         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7100         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7101         do iii=1,2
7102           do kkk=1,5
7103             do lll=1,3
7104               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7105      &          EAEAderx(1,1,lll,kkk,iii,2))
7106             enddo
7107           enddo
7108         enddo
7109 C AEAb1 and AEAb2
7110 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7111 C They are needed only when the fifth- or the sixth-order cumulants are
7112 C indluded.
7113         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7114         call transpose2(AEA(1,1,1),auxmat(1,1))
7115         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7116         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7117         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7118         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7119         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7120         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7121         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7122         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7123         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7124         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7125         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7126         call transpose2(AEA(1,1,2),auxmat(1,1))
7127         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7128         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7129         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7130         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7131         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7132         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7133         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7134         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7135         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7136         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7137         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7138 C Calculate the Cartesian derivatives of the vectors.
7139         do iii=1,2
7140           do kkk=1,5
7141             do lll=1,3
7142               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7143               call matvec2(auxmat(1,1),b1(1,iti),
7144      &          AEAb1derx(1,lll,kkk,iii,1,1))
7145               call matvec2(auxmat(1,1),Ub2(1,i),
7146      &          AEAb2derx(1,lll,kkk,iii,1,1))
7147               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7148      &          AEAb1derx(1,lll,kkk,iii,2,1))
7149               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7150      &          AEAb2derx(1,lll,kkk,iii,2,1))
7151               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7152               call matvec2(auxmat(1,1),b1(1,itj),
7153      &          AEAb1derx(1,lll,kkk,iii,1,2))
7154               call matvec2(auxmat(1,1),Ub2(1,j),
7155      &          AEAb2derx(1,lll,kkk,iii,1,2))
7156               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7157      &          AEAb1derx(1,lll,kkk,iii,2,2))
7158               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7159      &          AEAb2derx(1,lll,kkk,iii,2,2))
7160             enddo
7161           enddo
7162         enddo
7163         ENDIF
7164 C End vectors
7165       else
7166 C Antiparallel orientation of the two CA-CA-CA frames.
7167         if (i.gt.1) then
7168           iti=itortyp(itype(i))
7169         else
7170           iti=ntortyp+1
7171         endif
7172         itk1=itortyp(itype(k+1))
7173         itl=itortyp(itype(l))
7174         itj=itortyp(itype(j))
7175         if (j.lt.nres-1) then
7176           itj1=itortyp(itype(j+1))
7177         else
7178           itj1=ntortyp+1
7179         endif
7180 C A2 kernel(j-1)T A1T
7181         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7182      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7183      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7184 C Following matrices are needed only for 6-th order cumulants
7185         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7186      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7187         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7188      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7189      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7190         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7191      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7192      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7193      &   ADtEAderx(1,1,1,1,1,1))
7194         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7195      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7196      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7197      &   ADtEA1derx(1,1,1,1,1,1))
7198         ENDIF
7199 C End 6-th order cumulants
7200         call transpose2(EUgder(1,1,k),auxmat(1,1))
7201         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7202         call transpose2(EUg(1,1,k),auxmat(1,1))
7203         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7204         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7205         do iii=1,2
7206           do kkk=1,5
7207             do lll=1,3
7208               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7209      &          EAEAderx(1,1,lll,kkk,iii,1))
7210             enddo
7211           enddo
7212         enddo
7213 C A2T kernel(i+1)T A1
7214         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7215      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7216      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7217 C Following matrices are needed only for 6-th order cumulants
7218         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7219      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7220         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7221      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7222      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7223         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7224      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7225      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7226      &   ADtEAderx(1,1,1,1,1,2))
7227         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7228      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7229      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7230      &   ADtEA1derx(1,1,1,1,1,2))
7231         ENDIF
7232 C End 6-th order cumulants
7233         call transpose2(EUgder(1,1,j),auxmat(1,1))
7234         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7235         call transpose2(EUg(1,1,j),auxmat(1,1))
7236         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7237         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7238         do iii=1,2
7239           do kkk=1,5
7240             do lll=1,3
7241               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7242      &          EAEAderx(1,1,lll,kkk,iii,2))
7243             enddo
7244           enddo
7245         enddo
7246 C AEAb1 and AEAb2
7247 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7248 C They are needed only when the fifth- or the sixth-order cumulants are
7249 C indluded.
7250         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7251      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7252         call transpose2(AEA(1,1,1),auxmat(1,1))
7253         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7254         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7255         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7256         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7257         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7258         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7259         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7260         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7261         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7262         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7263         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7264         call transpose2(AEA(1,1,2),auxmat(1,1))
7265         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7266         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7267         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7268         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7269         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7270         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7271         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7272         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7273         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7274         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7275         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7276 C Calculate the Cartesian derivatives of the vectors.
7277         do iii=1,2
7278           do kkk=1,5
7279             do lll=1,3
7280               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7281               call matvec2(auxmat(1,1),b1(1,iti),
7282      &          AEAb1derx(1,lll,kkk,iii,1,1))
7283               call matvec2(auxmat(1,1),Ub2(1,i),
7284      &          AEAb2derx(1,lll,kkk,iii,1,1))
7285               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7286      &          AEAb1derx(1,lll,kkk,iii,2,1))
7287               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7288      &          AEAb2derx(1,lll,kkk,iii,2,1))
7289               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7290               call matvec2(auxmat(1,1),b1(1,itl),
7291      &          AEAb1derx(1,lll,kkk,iii,1,2))
7292               call matvec2(auxmat(1,1),Ub2(1,l),
7293      &          AEAb2derx(1,lll,kkk,iii,1,2))
7294               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7295      &          AEAb1derx(1,lll,kkk,iii,2,2))
7296               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7297      &          AEAb2derx(1,lll,kkk,iii,2,2))
7298             enddo
7299           enddo
7300         enddo
7301         ENDIF
7302 C End vectors
7303       endif
7304       return
7305       end
7306 C---------------------------------------------------------------------------
7307       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7308      &  KK,KKderg,AKA,AKAderg,AKAderx)
7309       implicit none
7310       integer nderg
7311       logical transp
7312       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7313      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7314      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7315       integer iii,kkk,lll
7316       integer jjj,mmm
7317       logical lprn
7318       common /kutas/ lprn
7319       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7320       do iii=1,nderg
7321         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7322      &    AKAderg(1,1,iii))
7323       enddo
7324 cd      if (lprn) write (2,*) 'In kernel'
7325       do kkk=1,5
7326 cd        if (lprn) write (2,*) 'kkk=',kkk
7327         do lll=1,3
7328           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7329      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7330 cd          if (lprn) then
7331 cd            write (2,*) 'lll=',lll
7332 cd            write (2,*) 'iii=1'
7333 cd            do jjj=1,2
7334 cd              write (2,'(3(2f10.5),5x)')
7335 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7336 cd            enddo
7337 cd          endif
7338           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7339      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7340 cd          if (lprn) then
7341 cd            write (2,*) 'lll=',lll
7342 cd            write (2,*) 'iii=2'
7343 cd            do jjj=1,2
7344 cd              write (2,'(3(2f10.5),5x)')
7345 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7346 cd            enddo
7347 cd          endif
7348         enddo
7349       enddo
7350       return
7351       end
7352 C---------------------------------------------------------------------------
7353       double precision function eello4(i,j,k,l,jj,kk)
7354       implicit real*8 (a-h,o-z)
7355       include 'DIMENSIONS'
7356       include 'COMMON.IOUNITS'
7357       include 'COMMON.CHAIN'
7358       include 'COMMON.DERIV'
7359       include 'COMMON.INTERACT'
7360       include 'COMMON.CONTACTS'
7361       include 'COMMON.TORSION'
7362       include 'COMMON.VAR'
7363       include 'COMMON.GEO'
7364       double precision pizda(2,2),ggg1(3),ggg2(3)
7365 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7366 cd        eello4=0.0d0
7367 cd        return
7368 cd      endif
7369 cd      print *,'eello4:',i,j,k,l,jj,kk
7370 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7371 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7372 cold      eij=facont_hb(jj,i)
7373 cold      ekl=facont_hb(kk,k)
7374 cold      ekont=eij*ekl
7375       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7376 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7377       gcorr_loc(k-1)=gcorr_loc(k-1)
7378      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7379       if (l.eq.j+1) then
7380         gcorr_loc(l-1)=gcorr_loc(l-1)
7381      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7382       else
7383         gcorr_loc(j-1)=gcorr_loc(j-1)
7384      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7385       endif
7386       do iii=1,2
7387         do kkk=1,5
7388           do lll=1,3
7389             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7390      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7391 cd            derx(lll,kkk,iii)=0.0d0
7392           enddo
7393         enddo
7394       enddo
7395 cd      gcorr_loc(l-1)=0.0d0
7396 cd      gcorr_loc(j-1)=0.0d0
7397 cd      gcorr_loc(k-1)=0.0d0
7398 cd      eel4=1.0d0
7399 cd      write (iout,*)'Contacts have occurred for peptide groups',
7400 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7401 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7402       if (j.lt.nres-1) then
7403         j1=j+1
7404         j2=j-1
7405       else
7406         j1=j-1
7407         j2=j-2
7408       endif
7409       if (l.lt.nres-1) then
7410         l1=l+1
7411         l2=l-1
7412       else
7413         l1=l-1
7414         l2=l-2
7415       endif
7416       do ll=1,3
7417 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7418 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7419         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7420         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7421 cgrad        ghalf=0.5d0*ggg1(ll)
7422         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7423         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7424         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7425         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7426         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7427         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7428 cgrad        ghalf=0.5d0*ggg2(ll)
7429         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7430         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7431         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7432         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7433         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7434         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7435       enddo
7436 cgrad      do m=i+1,j-1
7437 cgrad        do ll=1,3
7438 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7439 cgrad        enddo
7440 cgrad      enddo
7441 cgrad      do m=k+1,l-1
7442 cgrad        do ll=1,3
7443 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7444 cgrad        enddo
7445 cgrad      enddo
7446 cgrad      do m=i+2,j2
7447 cgrad        do ll=1,3
7448 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7449 cgrad        enddo
7450 cgrad      enddo
7451 cgrad      do m=k+2,l2
7452 cgrad        do ll=1,3
7453 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7454 cgrad        enddo
7455 cgrad      enddo
7456 cd      do iii=1,nres-3
7457 cd        write (2,*) iii,gcorr_loc(iii)
7458 cd      enddo
7459       eello4=ekont*eel4
7460 cd      write (2,*) 'ekont',ekont
7461 cd      write (iout,*) 'eello4',ekont*eel4
7462       return
7463       end
7464 C---------------------------------------------------------------------------
7465       double precision function eello5(i,j,k,l,jj,kk)
7466       implicit real*8 (a-h,o-z)
7467       include 'DIMENSIONS'
7468       include 'COMMON.IOUNITS'
7469       include 'COMMON.CHAIN'
7470       include 'COMMON.DERIV'
7471       include 'COMMON.INTERACT'
7472       include 'COMMON.CONTACTS'
7473       include 'COMMON.TORSION'
7474       include 'COMMON.VAR'
7475       include 'COMMON.GEO'
7476       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7477       double precision ggg1(3),ggg2(3)
7478 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7479 C                                                                              C
7480 C                            Parallel chains                                   C
7481 C                                                                              C
7482 C          o             o                   o             o                   C
7483 C         /l\           / \             \   / \           / \   /              C
7484 C        /   \         /   \             \ /   \         /   \ /               C
7485 C       j| o |l1       | o |              o| o |         | o |o                C
7486 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7487 C      \i/   \         /   \ /             /   \         /   \                 C
7488 C       o    k1             o                                                  C
7489 C         (I)          (II)                (III)          (IV)                 C
7490 C                                                                              C
7491 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7492 C                                                                              C
7493 C                            Antiparallel chains                               C
7494 C                                                                              C
7495 C          o             o                   o             o                   C
7496 C         /j\           / \             \   / \           / \   /              C
7497 C        /   \         /   \             \ /   \         /   \ /               C
7498 C      j1| o |l        | o |              o| o |         | o |o                C
7499 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7500 C      \i/   \         /   \ /             /   \         /   \                 C
7501 C       o     k1            o                                                  C
7502 C         (I)          (II)                (III)          (IV)                 C
7503 C                                                                              C
7504 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7505 C                                                                              C
7506 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7507 C                                                                              C
7508 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7509 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7510 cd        eello5=0.0d0
7511 cd        return
7512 cd      endif
7513 cd      write (iout,*)
7514 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7515 cd     &   ' and',k,l
7516       itk=itortyp(itype(k))
7517       itl=itortyp(itype(l))
7518       itj=itortyp(itype(j))
7519       eello5_1=0.0d0
7520       eello5_2=0.0d0
7521       eello5_3=0.0d0
7522       eello5_4=0.0d0
7523 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7524 cd     &   eel5_3_num,eel5_4_num)
7525       do iii=1,2
7526         do kkk=1,5
7527           do lll=1,3
7528             derx(lll,kkk,iii)=0.0d0
7529           enddo
7530         enddo
7531       enddo
7532 cd      eij=facont_hb(jj,i)
7533 cd      ekl=facont_hb(kk,k)
7534 cd      ekont=eij*ekl
7535 cd      write (iout,*)'Contacts have occurred for peptide groups',
7536 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7537 cd      goto 1111
7538 C Contribution from the graph I.
7539 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7540 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7541       call transpose2(EUg(1,1,k),auxmat(1,1))
7542       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7543       vv(1)=pizda(1,1)-pizda(2,2)
7544       vv(2)=pizda(1,2)+pizda(2,1)
7545       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7546      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7547 C Explicit gradient in virtual-dihedral angles.
7548       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7549      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7550      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7551       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7552       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7553       vv(1)=pizda(1,1)-pizda(2,2)
7554       vv(2)=pizda(1,2)+pizda(2,1)
7555       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7556      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7557      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7558       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7559       vv(1)=pizda(1,1)-pizda(2,2)
7560       vv(2)=pizda(1,2)+pizda(2,1)
7561       if (l.eq.j+1) then
7562         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7563      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7564      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7565       else
7566         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7567      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7568      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7569       endif
7570 C Cartesian gradient
7571       do iii=1,2
7572         do kkk=1,5
7573           do lll=1,3
7574             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7575      &        pizda(1,1))
7576             vv(1)=pizda(1,1)-pizda(2,2)
7577             vv(2)=pizda(1,2)+pizda(2,1)
7578             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7579      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7580      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7581           enddo
7582         enddo
7583       enddo
7584 c      goto 1112
7585 c1111  continue
7586 C Contribution from graph II
7587       call transpose2(EE(1,1,itk),auxmat(1,1))
7588       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7589       vv(1)=pizda(1,1)+pizda(2,2)
7590       vv(2)=pizda(2,1)-pizda(1,2)
7591       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7592      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7593 C Explicit gradient in virtual-dihedral angles.
7594       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7595      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7596       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7597       vv(1)=pizda(1,1)+pizda(2,2)
7598       vv(2)=pizda(2,1)-pizda(1,2)
7599       if (l.eq.j+1) then
7600         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7601      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7602      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7603       else
7604         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7605      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7606      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7607       endif
7608 C Cartesian gradient
7609       do iii=1,2
7610         do kkk=1,5
7611           do lll=1,3
7612             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7613      &        pizda(1,1))
7614             vv(1)=pizda(1,1)+pizda(2,2)
7615             vv(2)=pizda(2,1)-pizda(1,2)
7616             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7617      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7618      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7619           enddo
7620         enddo
7621       enddo
7622 cd      goto 1112
7623 cd1111  continue
7624       if (l.eq.j+1) then
7625 cd        goto 1110
7626 C Parallel orientation
7627 C Contribution from graph III
7628         call transpose2(EUg(1,1,l),auxmat(1,1))
7629         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7630         vv(1)=pizda(1,1)-pizda(2,2)
7631         vv(2)=pizda(1,2)+pizda(2,1)
7632         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7633      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7634 C Explicit gradient in virtual-dihedral angles.
7635         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7636      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7637      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7638         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7639         vv(1)=pizda(1,1)-pizda(2,2)
7640         vv(2)=pizda(1,2)+pizda(2,1)
7641         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7642      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7644         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7645         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7646         vv(1)=pizda(1,1)-pizda(2,2)
7647         vv(2)=pizda(1,2)+pizda(2,1)
7648         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7649      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7651 C Cartesian gradient
7652         do iii=1,2
7653           do kkk=1,5
7654             do lll=1,3
7655               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7656      &          pizda(1,1))
7657               vv(1)=pizda(1,1)-pizda(2,2)
7658               vv(2)=pizda(1,2)+pizda(2,1)
7659               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7660      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7661      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7662             enddo
7663           enddo
7664         enddo
7665 cd        goto 1112
7666 C Contribution from graph IV
7667 cd1110    continue
7668         call transpose2(EE(1,1,itl),auxmat(1,1))
7669         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7670         vv(1)=pizda(1,1)+pizda(2,2)
7671         vv(2)=pizda(2,1)-pizda(1,2)
7672         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7673      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7674 C Explicit gradient in virtual-dihedral angles.
7675         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7676      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7677         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7678         vv(1)=pizda(1,1)+pizda(2,2)
7679         vv(2)=pizda(2,1)-pizda(1,2)
7680         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7681      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7682      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7683 C Cartesian gradient
7684         do iii=1,2
7685           do kkk=1,5
7686             do lll=1,3
7687               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7688      &          pizda(1,1))
7689               vv(1)=pizda(1,1)+pizda(2,2)
7690               vv(2)=pizda(2,1)-pizda(1,2)
7691               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7692      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7693      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7694             enddo
7695           enddo
7696         enddo
7697       else
7698 C Antiparallel orientation
7699 C Contribution from graph III
7700 c        goto 1110
7701         call transpose2(EUg(1,1,j),auxmat(1,1))
7702         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7703         vv(1)=pizda(1,1)-pizda(2,2)
7704         vv(2)=pizda(1,2)+pizda(2,1)
7705         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7706      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7707 C Explicit gradient in virtual-dihedral angles.
7708         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7709      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7710      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7711         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7712         vv(1)=pizda(1,1)-pizda(2,2)
7713         vv(2)=pizda(1,2)+pizda(2,1)
7714         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7715      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7716      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7717         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7718         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7719         vv(1)=pizda(1,1)-pizda(2,2)
7720         vv(2)=pizda(1,2)+pizda(2,1)
7721         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7722      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7723      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7724 C Cartesian gradient
7725         do iii=1,2
7726           do kkk=1,5
7727             do lll=1,3
7728               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7729      &          pizda(1,1))
7730               vv(1)=pizda(1,1)-pizda(2,2)
7731               vv(2)=pizda(1,2)+pizda(2,1)
7732               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7733      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7734      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7735             enddo
7736           enddo
7737         enddo
7738 cd        goto 1112
7739 C Contribution from graph IV
7740 1110    continue
7741         call transpose2(EE(1,1,itj),auxmat(1,1))
7742         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7743         vv(1)=pizda(1,1)+pizda(2,2)
7744         vv(2)=pizda(2,1)-pizda(1,2)
7745         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7746      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7747 C Explicit gradient in virtual-dihedral angles.
7748         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7749      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7750         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7751         vv(1)=pizda(1,1)+pizda(2,2)
7752         vv(2)=pizda(2,1)-pizda(1,2)
7753         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7754      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7755      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7756 C Cartesian gradient
7757         do iii=1,2
7758           do kkk=1,5
7759             do lll=1,3
7760               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7761      &          pizda(1,1))
7762               vv(1)=pizda(1,1)+pizda(2,2)
7763               vv(2)=pizda(2,1)-pizda(1,2)
7764               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7765      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7766      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7767             enddo
7768           enddo
7769         enddo
7770       endif
7771 1112  continue
7772       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7773 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7774 cd        write (2,*) 'ijkl',i,j,k,l
7775 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7776 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7777 cd      endif
7778 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7779 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7780 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7781 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7782       if (j.lt.nres-1) then
7783         j1=j+1
7784         j2=j-1
7785       else
7786         j1=j-1
7787         j2=j-2
7788       endif
7789       if (l.lt.nres-1) then
7790         l1=l+1
7791         l2=l-1
7792       else
7793         l1=l-1
7794         l2=l-2
7795       endif
7796 cd      eij=1.0d0
7797 cd      ekl=1.0d0
7798 cd      ekont=1.0d0
7799 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7800 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7801 C        summed up outside the subrouine as for the other subroutines
7802 C        handling long-range interactions. The old code is commented out
7803 C        with "cgrad" to keep track of changes.
7804       do ll=1,3
7805 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7806 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7807         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7808         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7809 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7810 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7811 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7812 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7813 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7814 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7815 c     &   gradcorr5ij,
7816 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7817 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7818 cgrad        ghalf=0.5d0*ggg1(ll)
7819 cd        ghalf=0.0d0
7820         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7821         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7822         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7823         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7824         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7825         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7826 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7827 cgrad        ghalf=0.5d0*ggg2(ll)
7828 cd        ghalf=0.0d0
7829         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7830         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7831         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7832         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7833         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7834         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7835       enddo
7836 cd      goto 1112
7837 cgrad      do m=i+1,j-1
7838 cgrad        do ll=1,3
7839 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7840 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7841 cgrad        enddo
7842 cgrad      enddo
7843 cgrad      do m=k+1,l-1
7844 cgrad        do ll=1,3
7845 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7846 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7847 cgrad        enddo
7848 cgrad      enddo
7849 c1112  continue
7850 cgrad      do m=i+2,j2
7851 cgrad        do ll=1,3
7852 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7853 cgrad        enddo
7854 cgrad      enddo
7855 cgrad      do m=k+2,l2
7856 cgrad        do ll=1,3
7857 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7858 cgrad        enddo
7859 cgrad      enddo
7860 cd      do iii=1,nres-3
7861 cd        write (2,*) iii,g_corr5_loc(iii)
7862 cd      enddo
7863       eello5=ekont*eel5
7864 cd      write (2,*) 'ekont',ekont
7865 cd      write (iout,*) 'eello5',ekont*eel5
7866       return
7867       end
7868 c--------------------------------------------------------------------------
7869       double precision function eello6(i,j,k,l,jj,kk)
7870       implicit real*8 (a-h,o-z)
7871       include 'DIMENSIONS'
7872       include 'COMMON.IOUNITS'
7873       include 'COMMON.CHAIN'
7874       include 'COMMON.DERIV'
7875       include 'COMMON.INTERACT'
7876       include 'COMMON.CONTACTS'
7877       include 'COMMON.TORSION'
7878       include 'COMMON.VAR'
7879       include 'COMMON.GEO'
7880       include 'COMMON.FFIELD'
7881       double precision ggg1(3),ggg2(3)
7882 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7883 cd        eello6=0.0d0
7884 cd        return
7885 cd      endif
7886 cd      write (iout,*)
7887 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7888 cd     &   ' and',k,l
7889       eello6_1=0.0d0
7890       eello6_2=0.0d0
7891       eello6_3=0.0d0
7892       eello6_4=0.0d0
7893       eello6_5=0.0d0
7894       eello6_6=0.0d0
7895 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7896 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7897       do iii=1,2
7898         do kkk=1,5
7899           do lll=1,3
7900             derx(lll,kkk,iii)=0.0d0
7901           enddo
7902         enddo
7903       enddo
7904 cd      eij=facont_hb(jj,i)
7905 cd      ekl=facont_hb(kk,k)
7906 cd      ekont=eij*ekl
7907 cd      eij=1.0d0
7908 cd      ekl=1.0d0
7909 cd      ekont=1.0d0
7910       if (l.eq.j+1) then
7911         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7912         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7913         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7914         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7915         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7916         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7917       else
7918         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7919         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7920         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7921         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7922         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7923           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7924         else
7925           eello6_5=0.0d0
7926         endif
7927         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7928       endif
7929 C If turn contributions are considered, they will be handled separately.
7930       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7931 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7932 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7933 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7934 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7935 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7936 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7937 cd      goto 1112
7938       if (j.lt.nres-1) then
7939         j1=j+1
7940         j2=j-1
7941       else
7942         j1=j-1
7943         j2=j-2
7944       endif
7945       if (l.lt.nres-1) then
7946         l1=l+1
7947         l2=l-1
7948       else
7949         l1=l-1
7950         l2=l-2
7951       endif
7952       do ll=1,3
7953 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7954 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7955 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7956 cgrad        ghalf=0.5d0*ggg1(ll)
7957 cd        ghalf=0.0d0
7958         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7959         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7960         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7961         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7962         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7963         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7964         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7965         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7966 cgrad        ghalf=0.5d0*ggg2(ll)
7967 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7968 cd        ghalf=0.0d0
7969         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7970         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7971         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7972         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7973         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7974         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7975       enddo
7976 cd      goto 1112
7977 cgrad      do m=i+1,j-1
7978 cgrad        do ll=1,3
7979 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7980 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7981 cgrad        enddo
7982 cgrad      enddo
7983 cgrad      do m=k+1,l-1
7984 cgrad        do ll=1,3
7985 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7986 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7987 cgrad        enddo
7988 cgrad      enddo
7989 cgrad1112  continue
7990 cgrad      do m=i+2,j2
7991 cgrad        do ll=1,3
7992 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7993 cgrad        enddo
7994 cgrad      enddo
7995 cgrad      do m=k+2,l2
7996 cgrad        do ll=1,3
7997 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7998 cgrad        enddo
7999 cgrad      enddo
8000 cd      do iii=1,nres-3
8001 cd        write (2,*) iii,g_corr6_loc(iii)
8002 cd      enddo
8003       eello6=ekont*eel6
8004 cd      write (2,*) 'ekont',ekont
8005 cd      write (iout,*) 'eello6',ekont*eel6
8006       return
8007       end
8008 c--------------------------------------------------------------------------
8009       double precision function eello6_graph1(i,j,k,l,imat,swap)
8010       implicit real*8 (a-h,o-z)
8011       include 'DIMENSIONS'
8012       include 'COMMON.IOUNITS'
8013       include 'COMMON.CHAIN'
8014       include 'COMMON.DERIV'
8015       include 'COMMON.INTERACT'
8016       include 'COMMON.CONTACTS'
8017       include 'COMMON.TORSION'
8018       include 'COMMON.VAR'
8019       include 'COMMON.GEO'
8020       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8021       logical swap
8022       logical lprn
8023       common /kutas/ lprn
8024 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8025 C                                                                              C
8026 C      Parallel       Antiparallel                                             C
8027 C                                                                              C
8028 C          o             o                                                     C
8029 C         /l\           /j\                                                    C
8030 C        /   \         /   \                                                   C
8031 C       /| o |         | o |\                                                  C
8032 C     \ j|/k\|  /   \  |/k\|l /                                                C
8033 C      \ /   \ /     \ /   \ /                                                 C
8034 C       o     o       o     o                                                  C
8035 C       i             i                                                        C
8036 C                                                                              C
8037 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8038       itk=itortyp(itype(k))
8039       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8040       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8041       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8042       call transpose2(EUgC(1,1,k),auxmat(1,1))
8043       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8044       vv1(1)=pizda1(1,1)-pizda1(2,2)
8045       vv1(2)=pizda1(1,2)+pizda1(2,1)
8046       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8047       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8048       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8049       s5=scalar2(vv(1),Dtobr2(1,i))
8050 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8051       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8052       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8053      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8054      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8055      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8056      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8057      & +scalar2(vv(1),Dtobr2der(1,i)))
8058       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8059       vv1(1)=pizda1(1,1)-pizda1(2,2)
8060       vv1(2)=pizda1(1,2)+pizda1(2,1)
8061       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8062       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8063       if (l.eq.j+1) then
8064         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8065      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8066      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8067      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8068      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8069       else
8070         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8071      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8072      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8073      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8074      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8075       endif
8076       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8077       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8078       vv1(1)=pizda1(1,1)-pizda1(2,2)
8079       vv1(2)=pizda1(1,2)+pizda1(2,1)
8080       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8081      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8082      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8083      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8084       do iii=1,2
8085         if (swap) then
8086           ind=3-iii
8087         else
8088           ind=iii
8089         endif
8090         do kkk=1,5
8091           do lll=1,3
8092             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8093             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8094             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8095             call transpose2(EUgC(1,1,k),auxmat(1,1))
8096             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8097      &        pizda1(1,1))
8098             vv1(1)=pizda1(1,1)-pizda1(2,2)
8099             vv1(2)=pizda1(1,2)+pizda1(2,1)
8100             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8101             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8102      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8103             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8104      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8105             s5=scalar2(vv(1),Dtobr2(1,i))
8106             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8107           enddo
8108         enddo
8109       enddo
8110       return
8111       end
8112 c----------------------------------------------------------------------------
8113       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8114       implicit real*8 (a-h,o-z)
8115       include 'DIMENSIONS'
8116       include 'COMMON.IOUNITS'
8117       include 'COMMON.CHAIN'
8118       include 'COMMON.DERIV'
8119       include 'COMMON.INTERACT'
8120       include 'COMMON.CONTACTS'
8121       include 'COMMON.TORSION'
8122       include 'COMMON.VAR'
8123       include 'COMMON.GEO'
8124       logical swap
8125       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8126      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8127       logical lprn
8128       common /kutas/ lprn
8129 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8130 C                                                                              C
8131 C      Parallel       Antiparallel                                             C
8132 C                                                                              C
8133 C          o             o                                                     C
8134 C     \   /l\           /j\   /                                                C
8135 C      \ /   \         /   \ /                                                 C
8136 C       o| o |         | o |o                                                  C
8137 C     \ j|/k\|      \  |/k\|l                                                  C
8138 C      \ /   \       \ /   \                                                   C
8139 C       o             o                                                        C
8140 C       i             i                                                        C
8141 C                                                                              C
8142 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8143 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8144 C AL 7/4/01 s1 would occur in the sixth-order moment,
8145 C           but not in a cluster cumulant
8146 #ifdef MOMENT
8147       s1=dip(1,jj,i)*dip(1,kk,k)
8148 #endif
8149       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8150       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8151       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8152       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8153       call transpose2(EUg(1,1,k),auxmat(1,1))
8154       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8155       vv(1)=pizda(1,1)-pizda(2,2)
8156       vv(2)=pizda(1,2)+pizda(2,1)
8157       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8158 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8159 #ifdef MOMENT
8160       eello6_graph2=-(s1+s2+s3+s4)
8161 #else
8162       eello6_graph2=-(s2+s3+s4)
8163 #endif
8164 c      eello6_graph2=-s3
8165 C Derivatives in gamma(i-1)
8166       if (i.gt.1) then
8167 #ifdef MOMENT
8168         s1=dipderg(1,jj,i)*dip(1,kk,k)
8169 #endif
8170         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8171         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8172         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8173         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8174 #ifdef MOMENT
8175         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8176 #else
8177         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8178 #endif
8179 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8180       endif
8181 C Derivatives in gamma(k-1)
8182 #ifdef MOMENT
8183       s1=dip(1,jj,i)*dipderg(1,kk,k)
8184 #endif
8185       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8186       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8187       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8188       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8189       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8190       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8191       vv(1)=pizda(1,1)-pizda(2,2)
8192       vv(2)=pizda(1,2)+pizda(2,1)
8193       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8194 #ifdef MOMENT
8195       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8196 #else
8197       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8198 #endif
8199 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8200 C Derivatives in gamma(j-1) or gamma(l-1)
8201       if (j.gt.1) then
8202 #ifdef MOMENT
8203         s1=dipderg(3,jj,i)*dip(1,kk,k)
8204 #endif
8205         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8206         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8207         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8208         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8209         vv(1)=pizda(1,1)-pizda(2,2)
8210         vv(2)=pizda(1,2)+pizda(2,1)
8211         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8212 #ifdef MOMENT
8213         if (swap) then
8214           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8215         else
8216           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8217         endif
8218 #endif
8219         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8220 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8221       endif
8222 C Derivatives in gamma(l-1) or gamma(j-1)
8223       if (l.gt.1) then
8224 #ifdef MOMENT
8225         s1=dip(1,jj,i)*dipderg(3,kk,k)
8226 #endif
8227         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8228         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8229         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8230         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8231         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8232         vv(1)=pizda(1,1)-pizda(2,2)
8233         vv(2)=pizda(1,2)+pizda(2,1)
8234         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8235 #ifdef MOMENT
8236         if (swap) then
8237           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8238         else
8239           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8240         endif
8241 #endif
8242         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8243 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8244       endif
8245 C Cartesian derivatives.
8246       if (lprn) then
8247         write (2,*) 'In eello6_graph2'
8248         do iii=1,2
8249           write (2,*) 'iii=',iii
8250           do kkk=1,5
8251             write (2,*) 'kkk=',kkk
8252             do jjj=1,2
8253               write (2,'(3(2f10.5),5x)')
8254      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8255             enddo
8256           enddo
8257         enddo
8258       endif
8259       do iii=1,2
8260         do kkk=1,5
8261           do lll=1,3
8262 #ifdef MOMENT
8263             if (iii.eq.1) then
8264               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8265             else
8266               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8267             endif
8268 #endif
8269             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8270      &        auxvec(1))
8271             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8272             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8273      &        auxvec(1))
8274             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8275             call transpose2(EUg(1,1,k),auxmat(1,1))
8276             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8277      &        pizda(1,1))
8278             vv(1)=pizda(1,1)-pizda(2,2)
8279             vv(2)=pizda(1,2)+pizda(2,1)
8280             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8281 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8282 #ifdef MOMENT
8283             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8284 #else
8285             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8286 #endif
8287             if (swap) then
8288               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8289             else
8290               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8291             endif
8292           enddo
8293         enddo
8294       enddo
8295       return
8296       end
8297 c----------------------------------------------------------------------------
8298       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8299       implicit real*8 (a-h,o-z)
8300       include 'DIMENSIONS'
8301       include 'COMMON.IOUNITS'
8302       include 'COMMON.CHAIN'
8303       include 'COMMON.DERIV'
8304       include 'COMMON.INTERACT'
8305       include 'COMMON.CONTACTS'
8306       include 'COMMON.TORSION'
8307       include 'COMMON.VAR'
8308       include 'COMMON.GEO'
8309       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8310       logical swap
8311 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8312 C                                                                              C
8313 C      Parallel       Antiparallel                                             C
8314 C                                                                              C
8315 C          o             o                                                     C
8316 C         /l\   /   \   /j\                                                    C
8317 C        /   \ /     \ /   \                                                   C
8318 C       /| o |o       o| o |\                                                  C
8319 C       j|/k\|  /      |/k\|l /                                                C
8320 C        /   \ /       /   \ /                                                 C
8321 C       /     o       /     o                                                  C
8322 C       i             i                                                        C
8323 C                                                                              C
8324 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8325 C
8326 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8327 C           energy moment and not to the cluster cumulant.
8328       iti=itortyp(itype(i))
8329       if (j.lt.nres-1) then
8330         itj1=itortyp(itype(j+1))
8331       else
8332         itj1=ntortyp+1
8333       endif
8334       itk=itortyp(itype(k))
8335       itk1=itortyp(itype(k+1))
8336       if (l.lt.nres-1) then
8337         itl1=itortyp(itype(l+1))
8338       else
8339         itl1=ntortyp+1
8340       endif
8341 #ifdef MOMENT
8342       s1=dip(4,jj,i)*dip(4,kk,k)
8343 #endif
8344       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8345       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8346       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8347       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8348       call transpose2(EE(1,1,itk),auxmat(1,1))
8349       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8350       vv(1)=pizda(1,1)+pizda(2,2)
8351       vv(2)=pizda(2,1)-pizda(1,2)
8352       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8353 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8354 cd     & "sum",-(s2+s3+s4)
8355 #ifdef MOMENT
8356       eello6_graph3=-(s1+s2+s3+s4)
8357 #else
8358       eello6_graph3=-(s2+s3+s4)
8359 #endif
8360 c      eello6_graph3=-s4
8361 C Derivatives in gamma(k-1)
8362       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8363       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8364       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8365       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8366 C Derivatives in gamma(l-1)
8367       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8368       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8369       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8370       vv(1)=pizda(1,1)+pizda(2,2)
8371       vv(2)=pizda(2,1)-pizda(1,2)
8372       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8373       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8374 C Cartesian derivatives.
8375       do iii=1,2
8376         do kkk=1,5
8377           do lll=1,3
8378 #ifdef MOMENT
8379             if (iii.eq.1) then
8380               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8381             else
8382               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8383             endif
8384 #endif
8385             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8386      &        auxvec(1))
8387             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8388             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8389      &        auxvec(1))
8390             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8391             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8392      &        pizda(1,1))
8393             vv(1)=pizda(1,1)+pizda(2,2)
8394             vv(2)=pizda(2,1)-pizda(1,2)
8395             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8396 #ifdef MOMENT
8397             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8398 #else
8399             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8400 #endif
8401             if (swap) then
8402               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8403             else
8404               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8405             endif
8406 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8407           enddo
8408         enddo
8409       enddo
8410       return
8411       end
8412 c----------------------------------------------------------------------------
8413       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8414       implicit real*8 (a-h,o-z)
8415       include 'DIMENSIONS'
8416       include 'COMMON.IOUNITS'
8417       include 'COMMON.CHAIN'
8418       include 'COMMON.DERIV'
8419       include 'COMMON.INTERACT'
8420       include 'COMMON.CONTACTS'
8421       include 'COMMON.TORSION'
8422       include 'COMMON.VAR'
8423       include 'COMMON.GEO'
8424       include 'COMMON.FFIELD'
8425       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8426      & auxvec1(2),auxmat1(2,2)
8427       logical swap
8428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8429 C                                                                              C
8430 C      Parallel       Antiparallel                                             C
8431 C                                                                              C
8432 C          o             o                                                     C
8433 C         /l\   /   \   /j\                                                    C
8434 C        /   \ /     \ /   \                                                   C
8435 C       /| o |o       o| o |\                                                  C
8436 C     \ j|/k\|      \  |/k\|l                                                  C
8437 C      \ /   \       \ /   \                                                   C
8438 C       o     \       o     \                                                  C
8439 C       i             i                                                        C
8440 C                                                                              C
8441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8442 C
8443 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8444 C           energy moment and not to the cluster cumulant.
8445 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8446       iti=itortyp(itype(i))
8447       itj=itortyp(itype(j))
8448       if (j.lt.nres-1) then
8449         itj1=itortyp(itype(j+1))
8450       else
8451         itj1=ntortyp+1
8452       endif
8453       itk=itortyp(itype(k))
8454       if (k.lt.nres-1) then
8455         itk1=itortyp(itype(k+1))
8456       else
8457         itk1=ntortyp+1
8458       endif
8459       itl=itortyp(itype(l))
8460       if (l.lt.nres-1) then
8461         itl1=itortyp(itype(l+1))
8462       else
8463         itl1=ntortyp+1
8464       endif
8465 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8466 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8467 cd     & ' itl',itl,' itl1',itl1
8468 #ifdef MOMENT
8469       if (imat.eq.1) then
8470         s1=dip(3,jj,i)*dip(3,kk,k)
8471       else
8472         s1=dip(2,jj,j)*dip(2,kk,l)
8473       endif
8474 #endif
8475       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8476       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8477       if (j.eq.l+1) then
8478         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8479         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8480       else
8481         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8482         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8483       endif
8484       call transpose2(EUg(1,1,k),auxmat(1,1))
8485       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8486       vv(1)=pizda(1,1)-pizda(2,2)
8487       vv(2)=pizda(2,1)+pizda(1,2)
8488       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8489 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8490 #ifdef MOMENT
8491       eello6_graph4=-(s1+s2+s3+s4)
8492 #else
8493       eello6_graph4=-(s2+s3+s4)
8494 #endif
8495 C Derivatives in gamma(i-1)
8496       if (i.gt.1) then
8497 #ifdef MOMENT
8498         if (imat.eq.1) then
8499           s1=dipderg(2,jj,i)*dip(3,kk,k)
8500         else
8501           s1=dipderg(4,jj,j)*dip(2,kk,l)
8502         endif
8503 #endif
8504         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8505         if (j.eq.l+1) then
8506           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8507           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8508         else
8509           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8510           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8511         endif
8512         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8513         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8514 cd          write (2,*) 'turn6 derivatives'
8515 #ifdef MOMENT
8516           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8517 #else
8518           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8519 #endif
8520         else
8521 #ifdef MOMENT
8522           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8523 #else
8524           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8525 #endif
8526         endif
8527       endif
8528 C Derivatives in gamma(k-1)
8529 #ifdef MOMENT
8530       if (imat.eq.1) then
8531         s1=dip(3,jj,i)*dipderg(2,kk,k)
8532       else
8533         s1=dip(2,jj,j)*dipderg(4,kk,l)
8534       endif
8535 #endif
8536       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8537       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8538       if (j.eq.l+1) then
8539         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8540         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8541       else
8542         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8543         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8544       endif
8545       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8546       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8547       vv(1)=pizda(1,1)-pizda(2,2)
8548       vv(2)=pizda(2,1)+pizda(1,2)
8549       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8550       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8551 #ifdef MOMENT
8552         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8553 #else
8554         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8555 #endif
8556       else
8557 #ifdef MOMENT
8558         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8559 #else
8560         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8561 #endif
8562       endif
8563 C Derivatives in gamma(j-1) or gamma(l-1)
8564       if (l.eq.j+1 .and. l.gt.1) then
8565         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8566         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8567         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8568         vv(1)=pizda(1,1)-pizda(2,2)
8569         vv(2)=pizda(2,1)+pizda(1,2)
8570         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8571         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8572       else if (j.gt.1) then
8573         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8574         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8575         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8576         vv(1)=pizda(1,1)-pizda(2,2)
8577         vv(2)=pizda(2,1)+pizda(1,2)
8578         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8579         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8580           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8581         else
8582           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8583         endif
8584       endif
8585 C Cartesian derivatives.
8586       do iii=1,2
8587         do kkk=1,5
8588           do lll=1,3
8589 #ifdef MOMENT
8590             if (iii.eq.1) then
8591               if (imat.eq.1) then
8592                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8593               else
8594                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8595               endif
8596             else
8597               if (imat.eq.1) then
8598                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8599               else
8600                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8601               endif
8602             endif
8603 #endif
8604             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8605      &        auxvec(1))
8606             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8607             if (j.eq.l+1) then
8608               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8609      &          b1(1,itj1),auxvec(1))
8610               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8611             else
8612               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8613      &          b1(1,itl1),auxvec(1))
8614               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8615             endif
8616             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8617      &        pizda(1,1))
8618             vv(1)=pizda(1,1)-pizda(2,2)
8619             vv(2)=pizda(2,1)+pizda(1,2)
8620             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8621             if (swap) then
8622               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8623 #ifdef MOMENT
8624                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8625      &             -(s1+s2+s4)
8626 #else
8627                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8628      &             -(s2+s4)
8629 #endif
8630                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8631               else
8632 #ifdef MOMENT
8633                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8634 #else
8635                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8636 #endif
8637                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8638               endif
8639             else
8640 #ifdef MOMENT
8641               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8642 #else
8643               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8644 #endif
8645               if (l.eq.j+1) then
8646                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8647               else
8648                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8649               endif
8650             endif
8651           enddo
8652         enddo
8653       enddo
8654       return
8655       end
8656 c----------------------------------------------------------------------------
8657       double precision function eello_turn6(i,jj,kk)
8658       implicit real*8 (a-h,o-z)
8659       include 'DIMENSIONS'
8660       include 'COMMON.IOUNITS'
8661       include 'COMMON.CHAIN'
8662       include 'COMMON.DERIV'
8663       include 'COMMON.INTERACT'
8664       include 'COMMON.CONTACTS'
8665       include 'COMMON.TORSION'
8666       include 'COMMON.VAR'
8667       include 'COMMON.GEO'
8668       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8669      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8670      &  ggg1(3),ggg2(3)
8671       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8672      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8673 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8674 C           the respective energy moment and not to the cluster cumulant.
8675       s1=0.0d0
8676       s8=0.0d0
8677       s13=0.0d0
8678 c
8679       eello_turn6=0.0d0
8680       j=i+4
8681       k=i+1
8682       l=i+3
8683       iti=itortyp(itype(i))
8684       itk=itortyp(itype(k))
8685       itk1=itortyp(itype(k+1))
8686       itl=itortyp(itype(l))
8687       itj=itortyp(itype(j))
8688 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8689 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8690 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8691 cd        eello6=0.0d0
8692 cd        return
8693 cd      endif
8694 cd      write (iout,*)
8695 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8696 cd     &   ' and',k,l
8697 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8698       do iii=1,2
8699         do kkk=1,5
8700           do lll=1,3
8701             derx_turn(lll,kkk,iii)=0.0d0
8702           enddo
8703         enddo
8704       enddo
8705 cd      eij=1.0d0
8706 cd      ekl=1.0d0
8707 cd      ekont=1.0d0
8708       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8709 cd      eello6_5=0.0d0
8710 cd      write (2,*) 'eello6_5',eello6_5
8711 #ifdef MOMENT
8712       call transpose2(AEA(1,1,1),auxmat(1,1))
8713       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8714       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8715       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8716 #endif
8717       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8718       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8719       s2 = scalar2(b1(1,itk),vtemp1(1))
8720 #ifdef MOMENT
8721       call transpose2(AEA(1,1,2),atemp(1,1))
8722       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8723       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8724       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8725 #endif
8726       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8727       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8728       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8729 #ifdef MOMENT
8730       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8731       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8732       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8733       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8734       ss13 = scalar2(b1(1,itk),vtemp4(1))
8735       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8736 #endif
8737 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8738 c      s1=0.0d0
8739 c      s2=0.0d0
8740 c      s8=0.0d0
8741 c      s12=0.0d0
8742 c      s13=0.0d0
8743       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8744 C Derivatives in gamma(i+2)
8745       s1d =0.0d0
8746       s8d =0.0d0
8747 #ifdef MOMENT
8748       call transpose2(AEA(1,1,1),auxmatd(1,1))
8749       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8750       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8751       call transpose2(AEAderg(1,1,2),atempd(1,1))
8752       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8753       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8754 #endif
8755       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8756       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8757       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8758 c      s1d=0.0d0
8759 c      s2d=0.0d0
8760 c      s8d=0.0d0
8761 c      s12d=0.0d0
8762 c      s13d=0.0d0
8763       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8764 C Derivatives in gamma(i+3)
8765 #ifdef MOMENT
8766       call transpose2(AEA(1,1,1),auxmatd(1,1))
8767       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8768       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8769       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8770 #endif
8771       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8772       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8773       s2d = scalar2(b1(1,itk),vtemp1d(1))
8774 #ifdef MOMENT
8775       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8776       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8777 #endif
8778       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8779 #ifdef MOMENT
8780       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8781       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8782       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8783 #endif
8784 c      s1d=0.0d0
8785 c      s2d=0.0d0
8786 c      s8d=0.0d0
8787 c      s12d=0.0d0
8788 c      s13d=0.0d0
8789 #ifdef MOMENT
8790       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8791      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8792 #else
8793       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8794      &               -0.5d0*ekont*(s2d+s12d)
8795 #endif
8796 C Derivatives in gamma(i+4)
8797       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8798       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8799       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8800 #ifdef MOMENT
8801       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8802       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8803       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8804 #endif
8805 c      s1d=0.0d0
8806 c      s2d=0.0d0
8807 c      s8d=0.0d0
8808 C      s12d=0.0d0
8809 c      s13d=0.0d0
8810 #ifdef MOMENT
8811       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8812 #else
8813       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8814 #endif
8815 C Derivatives in gamma(i+5)
8816 #ifdef MOMENT
8817       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8818       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8819       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8820 #endif
8821       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8822       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8823       s2d = scalar2(b1(1,itk),vtemp1d(1))
8824 #ifdef MOMENT
8825       call transpose2(AEA(1,1,2),atempd(1,1))
8826       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8827       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8828 #endif
8829       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8830       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8831 #ifdef MOMENT
8832       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8833       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8834       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8835 #endif
8836 c      s1d=0.0d0
8837 c      s2d=0.0d0
8838 c      s8d=0.0d0
8839 c      s12d=0.0d0
8840 c      s13d=0.0d0
8841 #ifdef MOMENT
8842       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8843      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8844 #else
8845       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8846      &               -0.5d0*ekont*(s2d+s12d)
8847 #endif
8848 C Cartesian derivatives
8849       do iii=1,2
8850         do kkk=1,5
8851           do lll=1,3
8852 #ifdef MOMENT
8853             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8854             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8855             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8856 #endif
8857             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8858             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8859      &          vtemp1d(1))
8860             s2d = scalar2(b1(1,itk),vtemp1d(1))
8861 #ifdef MOMENT
8862             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8863             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8864             s8d = -(atempd(1,1)+atempd(2,2))*
8865      &           scalar2(cc(1,1,itl),vtemp2(1))
8866 #endif
8867             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8868      &           auxmatd(1,1))
8869             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8870             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8871 c      s1d=0.0d0
8872 c      s2d=0.0d0
8873 c      s8d=0.0d0
8874 c      s12d=0.0d0
8875 c      s13d=0.0d0
8876 #ifdef MOMENT
8877             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8878      &        - 0.5d0*(s1d+s2d)
8879 #else
8880             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8881      &        - 0.5d0*s2d
8882 #endif
8883 #ifdef MOMENT
8884             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8885      &        - 0.5d0*(s8d+s12d)
8886 #else
8887             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8888      &        - 0.5d0*s12d
8889 #endif
8890           enddo
8891         enddo
8892       enddo
8893 #ifdef MOMENT
8894       do kkk=1,5
8895         do lll=1,3
8896           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8897      &      achuj_tempd(1,1))
8898           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8899           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8900           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8901           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8902           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8903      &      vtemp4d(1))
8904           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8905           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8906           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8907         enddo
8908       enddo
8909 #endif
8910 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8911 cd     &  16*eel_turn6_num
8912 cd      goto 1112
8913       if (j.lt.nres-1) then
8914         j1=j+1
8915         j2=j-1
8916       else
8917         j1=j-1
8918         j2=j-2
8919       endif
8920       if (l.lt.nres-1) then
8921         l1=l+1
8922         l2=l-1
8923       else
8924         l1=l-1
8925         l2=l-2
8926       endif
8927       do ll=1,3
8928 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8929 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8930 cgrad        ghalf=0.5d0*ggg1(ll)
8931 cd        ghalf=0.0d0
8932         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8933         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8934         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8935      &    +ekont*derx_turn(ll,2,1)
8936         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8937         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8938      &    +ekont*derx_turn(ll,4,1)
8939         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8940         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8941         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8942 cgrad        ghalf=0.5d0*ggg2(ll)
8943 cd        ghalf=0.0d0
8944         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8945      &    +ekont*derx_turn(ll,2,2)
8946         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8947         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8948      &    +ekont*derx_turn(ll,4,2)
8949         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8950         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8951         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8952       enddo
8953 cd      goto 1112
8954 cgrad      do m=i+1,j-1
8955 cgrad        do ll=1,3
8956 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8957 cgrad        enddo
8958 cgrad      enddo
8959 cgrad      do m=k+1,l-1
8960 cgrad        do ll=1,3
8961 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8962 cgrad        enddo
8963 cgrad      enddo
8964 cgrad1112  continue
8965 cgrad      do m=i+2,j2
8966 cgrad        do ll=1,3
8967 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8968 cgrad        enddo
8969 cgrad      enddo
8970 cgrad      do m=k+2,l2
8971 cgrad        do ll=1,3
8972 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8973 cgrad        enddo
8974 cgrad      enddo
8975 cd      do iii=1,nres-3
8976 cd        write (2,*) iii,g_corr6_loc(iii)
8977 cd      enddo
8978       eello_turn6=ekont*eel_turn6
8979 cd      write (2,*) 'ekont',ekont
8980 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8981       return
8982       end
8983
8984 C-----------------------------------------------------------------------------
8985       double precision function scalar(u,v)
8986 !DIR$ INLINEALWAYS scalar
8987 #ifndef OSF
8988 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8989 #endif
8990       implicit none
8991       double precision u(3),v(3)
8992 cd      double precision sc
8993 cd      integer i
8994 cd      sc=0.0d0
8995 cd      do i=1,3
8996 cd        sc=sc+u(i)*v(i)
8997 cd      enddo
8998 cd      scalar=sc
8999
9000       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9001       return
9002       end
9003 crc-------------------------------------------------
9004       SUBROUTINE MATVEC2(A1,V1,V2)
9005 !DIR$ INLINEALWAYS MATVEC2
9006 #ifndef OSF
9007 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9008 #endif
9009       implicit real*8 (a-h,o-z)
9010       include 'DIMENSIONS'
9011       DIMENSION A1(2,2),V1(2),V2(2)
9012 c      DO 1 I=1,2
9013 c        VI=0.0
9014 c        DO 3 K=1,2
9015 c    3     VI=VI+A1(I,K)*V1(K)
9016 c        Vaux(I)=VI
9017 c    1 CONTINUE
9018
9019       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9020       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9021
9022       v2(1)=vaux1
9023       v2(2)=vaux2
9024       END
9025 C---------------------------------------
9026       SUBROUTINE MATMAT2(A1,A2,A3)
9027 #ifndef OSF
9028 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9029 #endif
9030       implicit real*8 (a-h,o-z)
9031       include 'DIMENSIONS'
9032       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9033 c      DIMENSION AI3(2,2)
9034 c        DO  J=1,2
9035 c          A3IJ=0.0
9036 c          DO K=1,2
9037 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9038 c          enddo
9039 c          A3(I,J)=A3IJ
9040 c       enddo
9041 c      enddo
9042
9043       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9044       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9045       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9046       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9047
9048       A3(1,1)=AI3_11
9049       A3(2,1)=AI3_21
9050       A3(1,2)=AI3_12
9051       A3(2,2)=AI3_22
9052       END
9053
9054 c-------------------------------------------------------------------------
9055       double precision function scalar2(u,v)
9056 !DIR$ INLINEALWAYS scalar2
9057       implicit none
9058       double precision u(2),v(2)
9059       double precision sc
9060       integer i
9061       scalar2=u(1)*v(1)+u(2)*v(2)
9062       return
9063       end
9064
9065 C-----------------------------------------------------------------------------
9066
9067       subroutine transpose2(a,at)
9068 !DIR$ INLINEALWAYS transpose2
9069 #ifndef OSF
9070 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9071 #endif
9072       implicit none
9073       double precision a(2,2),at(2,2)
9074       at(1,1)=a(1,1)
9075       at(1,2)=a(2,1)
9076       at(2,1)=a(1,2)
9077       at(2,2)=a(2,2)
9078       return
9079       end
9080 c--------------------------------------------------------------------------
9081       subroutine transpose(n,a,at)
9082       implicit none
9083       integer n,i,j
9084       double precision a(n,n),at(n,n)
9085       do i=1,n
9086         do j=1,n
9087           at(j,i)=a(i,j)
9088         enddo
9089       enddo
9090       return
9091       end
9092 C---------------------------------------------------------------------------
9093       subroutine prodmat3(a1,a2,kk,transp,prod)
9094 !DIR$ INLINEALWAYS prodmat3
9095 #ifndef OSF
9096 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9097 #endif
9098       implicit none
9099       integer i,j
9100       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9101       logical transp
9102 crc      double precision auxmat(2,2),prod_(2,2)
9103
9104       if (transp) then
9105 crc        call transpose2(kk(1,1),auxmat(1,1))
9106 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9107 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9108
9109            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9110      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9111            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9112      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9113            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9114      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9115            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9116      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9117
9118       else
9119 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9120 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9121
9122            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9123      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9124            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9125      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9126            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9127      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9128            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9129      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9130
9131       endif
9132 c      call transpose2(a2(1,1),a2t(1,1))
9133
9134 crc      print *,transp
9135 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9136 crc      print *,((prod(i,j),i=1,2),j=1,2)
9137
9138       return
9139       end
9140