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       do i=1,3
4091        ggg(i)=0.0d0
4092       enddo
4093 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4094 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4095       if (link_end.eq.0) return
4096       do i=link_start,link_end
4097 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4098 C CA-CA distance used in regularization of structure.
4099         ii=ihpb(i)
4100         jj=jhpb(i)
4101 C iii and jjj point to the residues for which the distance is assigned.
4102         if (ii.gt.nres) then
4103           iii=ii-nres
4104           jjj=jj-nres
4105         else
4106           iii=ii
4107           jjj=jj
4108         endif
4109 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4110 c     &    dhpb(i),dhpb1(i),forcon(i)
4111 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4112 C    distance and angle dependent SS bond potential.
4113 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4114 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4115         if (.not.dyn_ss .and. i.le.nss) then
4116 C 15/02/13 CC dynamic SSbond - additional check
4117          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4118      & iabs(itype(jjj)).eq.1) then
4119           call ssbond_ene(iii,jjj,eij)
4120           ehpb=ehpb+2*eij
4121          endif
4122 cd          write (iout,*) "eij",eij
4123 cd   &   ' waga=',waga,' fac=',fac
4124         else if (ii.gt.nres .and. jj.gt.nres) then
4125 c Restraints from contact prediction
4126           dd=dist(ii,jj)
4127           if (constr_dist.eq.11) then
4128             ehpb=ehpb+fordepth(i)**4.0d0
4129      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4130             fac=fordepth(i)**4.0d0
4131      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4132            else
4133           if (dhpb1(i).gt.0.0d0) then
4134             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4135             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4136 c            write (iout,*) "beta nmr",
4137 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4138           else
4139             dd=dist(ii,jj)
4140             rdis=dd-dhpb(i)
4141 C Get the force constant corresponding to this distance.
4142             waga=forcon(i)
4143 C Calculate the contribution to energy.
4144             ehpb=ehpb+waga*rdis*rdis
4145 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4146 C
4147 C Evaluate gradient.
4148 C
4149             fac=waga*rdis/dd
4150           endif
4151           endif
4152           do j=1,3
4153             ggg(j)=fac*(c(j,jj)-c(j,ii))
4154           enddo
4155           do j=1,3
4156             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4157             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4158           enddo
4159           do k=1,3
4160             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4161             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4162           enddo
4163         else
4164 C Calculate the distance between the two points and its difference from the
4165 C target distance.
4166           dd=dist(ii,jj)
4167           if (constr_dist.eq.11) then
4168             ehpb=ehpb+fordepth(i)**4.0d0
4169      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4170             fac=fordepth(i)**4.0d0
4171      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4172            else
4173           if (dhpb1(i).gt.0.0d0) then
4174             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4175             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4176 c            write (iout,*) "alph nmr",
4177 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4178           else
4179             rdis=dd-dhpb(i)
4180 C Get the force constant corresponding to this distance.
4181             waga=forcon(i)
4182 C Calculate the contribution to energy.
4183             ehpb=ehpb+waga*rdis*rdis
4184 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4185 C
4186 C Evaluate gradient.
4187 C
4188             fac=waga*rdis/dd
4189           endif
4190           endif
4191             do j=1,3
4192               ggg(j)=fac*(c(j,jj)-c(j,ii))
4193             enddo
4194 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4195 C If this is a SC-SC distance, we need to calculate the contributions to the
4196 C Cartesian gradient in the SC vectors (ghpbx).
4197           if (iii.lt.ii) then
4198           do j=1,3
4199             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4200             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4201           enddo
4202           endif
4203 cgrad        do j=iii,jjj-1
4204 cgrad          do k=1,3
4205 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4206 cgrad          enddo
4207 cgrad        enddo
4208           do k=1,3
4209             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4210             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4211           enddo
4212         endif
4213       enddo
4214       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4215       return
4216       end
4217 C--------------------------------------------------------------------------
4218       subroutine ssbond_ene(i,j,eij)
4219 C
4220 C Calculate the distance and angle dependent SS-bond potential energy
4221 C using a free-energy function derived based on RHF/6-31G** ab initio
4222 C calculations of diethyl disulfide.
4223 C
4224 C A. Liwo and U. Kozlowska, 11/24/03
4225 C
4226       implicit real*8 (a-h,o-z)
4227       include 'DIMENSIONS'
4228       include 'COMMON.SBRIDGE'
4229       include 'COMMON.CHAIN'
4230       include 'COMMON.DERIV'
4231       include 'COMMON.LOCAL'
4232       include 'COMMON.INTERACT'
4233       include 'COMMON.VAR'
4234       include 'COMMON.IOUNITS'
4235       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4236       itypi=iabs(itype(i))
4237       xi=c(1,nres+i)
4238       yi=c(2,nres+i)
4239       zi=c(3,nres+i)
4240       dxi=dc_norm(1,nres+i)
4241       dyi=dc_norm(2,nres+i)
4242       dzi=dc_norm(3,nres+i)
4243 c      dsci_inv=dsc_inv(itypi)
4244       dsci_inv=vbld_inv(nres+i)
4245       itypj=iabs(itype(j))
4246 c      dscj_inv=dsc_inv(itypj)
4247       dscj_inv=vbld_inv(nres+j)
4248       xj=c(1,nres+j)-xi
4249       yj=c(2,nres+j)-yi
4250       zj=c(3,nres+j)-zi
4251       dxj=dc_norm(1,nres+j)
4252       dyj=dc_norm(2,nres+j)
4253       dzj=dc_norm(3,nres+j)
4254       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4255       rij=dsqrt(rrij)
4256       erij(1)=xj*rij
4257       erij(2)=yj*rij
4258       erij(3)=zj*rij
4259       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4260       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4261       om12=dxi*dxj+dyi*dyj+dzi*dzj
4262       do k=1,3
4263         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4264         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4265       enddo
4266       rij=1.0d0/rij
4267       deltad=rij-d0cm
4268       deltat1=1.0d0-om1
4269       deltat2=1.0d0+om2
4270       deltat12=om2-om1+2.0d0
4271       cosphi=om12-om1*om2
4272       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4273      &  +akct*deltad*deltat12
4274      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4275 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4276 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4277 c     &  " deltat12",deltat12," eij",eij
4278       ed=2*akcm*deltad+akct*deltat12
4279       pom1=akct*deltad
4280       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4281       eom1=-2*akth*deltat1-pom1-om2*pom2
4282       eom2= 2*akth*deltat2+pom1-om1*pom2
4283       eom12=pom2
4284       do k=1,3
4285         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4286         ghpbx(k,i)=ghpbx(k,i)-ggk
4287      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4288      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4289         ghpbx(k,j)=ghpbx(k,j)+ggk
4290      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4291      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4292         ghpbc(k,i)=ghpbc(k,i)-ggk
4293         ghpbc(k,j)=ghpbc(k,j)+ggk
4294       enddo
4295 C
4296 C Calculate the components of the gradient in DC and X
4297 C
4298 cgrad      do k=i,j-1
4299 cgrad        do l=1,3
4300 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4301 cgrad        enddo
4302 cgrad      enddo
4303       return
4304       end
4305 C--------------------------------------------------------------------------
4306       subroutine ebond(estr)
4307 c
4308 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4309 c
4310       implicit real*8 (a-h,o-z)
4311       include 'DIMENSIONS'
4312       include 'COMMON.LOCAL'
4313       include 'COMMON.GEO'
4314       include 'COMMON.INTERACT'
4315       include 'COMMON.DERIV'
4316       include 'COMMON.VAR'
4317       include 'COMMON.CHAIN'
4318       include 'COMMON.IOUNITS'
4319       include 'COMMON.NAMES'
4320       include 'COMMON.FFIELD'
4321       include 'COMMON.CONTROL'
4322       include 'COMMON.SETUP'
4323       double precision u(3),ud(3)
4324       estr=0.0d0
4325       estr1=0.0d0
4326       do i=ibondp_start,ibondp_end
4327         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4328           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4329           do j=1,3
4330           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4331      &      *dc(j,i-1)/vbld(i)
4332           enddo
4333           if (energy_dec) write(iout,*)
4334      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4335         else
4336         diff = vbld(i)-vbldp0
4337         if (energy_dec) write (iout,*)
4338      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4339         estr=estr+diff*diff
4340         do j=1,3
4341           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4342         enddo
4343 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4344         endif
4345       enddo
4346       estr=0.5d0*AKP*estr+estr1
4347 c
4348 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4349 c
4350       do i=ibond_start,ibond_end
4351         iti=iabs(itype(i))
4352         if (iti.ne.10 .and. iti.ne.ntyp1) then
4353           nbi=nbondterm(iti)
4354           if (nbi.eq.1) then
4355             diff=vbld(i+nres)-vbldsc0(1,iti)
4356             if (energy_dec) write (iout,*)
4357      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4358      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4359             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4360             do j=1,3
4361               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4362             enddo
4363           else
4364             do j=1,nbi
4365               diff=vbld(i+nres)-vbldsc0(j,iti)
4366               ud(j)=aksc(j,iti)*diff
4367               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4368             enddo
4369             uprod=u(1)
4370             do j=2,nbi
4371               uprod=uprod*u(j)
4372             enddo
4373             usum=0.0d0
4374             usumsqder=0.0d0
4375             do j=1,nbi
4376               uprod1=1.0d0
4377               uprod2=1.0d0
4378               do k=1,nbi
4379                 if (k.ne.j) then
4380                   uprod1=uprod1*u(k)
4381                   uprod2=uprod2*u(k)*u(k)
4382                 endif
4383               enddo
4384               usum=usum+uprod1
4385               usumsqder=usumsqder+ud(j)*uprod2
4386             enddo
4387             estr=estr+uprod/usum
4388             do j=1,3
4389              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4390             enddo
4391           endif
4392         endif
4393       enddo
4394       return
4395       end
4396 #ifdef CRYST_THETA
4397 C--------------------------------------------------------------------------
4398       subroutine ebend(etheta)
4399 C
4400 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4401 C angles gamma and its derivatives in consecutive thetas and gammas.
4402 C
4403       implicit real*8 (a-h,o-z)
4404       include 'DIMENSIONS'
4405       include 'COMMON.LOCAL'
4406       include 'COMMON.GEO'
4407       include 'COMMON.INTERACT'
4408       include 'COMMON.DERIV'
4409       include 'COMMON.VAR'
4410       include 'COMMON.CHAIN'
4411       include 'COMMON.IOUNITS'
4412       include 'COMMON.NAMES'
4413       include 'COMMON.FFIELD'
4414       include 'COMMON.CONTROL'
4415       common /calcthet/ term1,term2,termm,diffak,ratak,
4416      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4417      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4418       double precision y(2),z(2)
4419       delta=0.02d0*pi
4420 c      time11=dexp(-2*time)
4421 c      time12=1.0d0
4422       etheta=0.0D0
4423 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4424       do i=ithet_start,ithet_end
4425         if (itype(i-1).eq.ntyp1) cycle
4426 C Zero the energy function and its derivative at 0 or pi.
4427         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4428         it=itype(i-1)
4429         ichir1=isign(1,itype(i-2))
4430         ichir2=isign(1,itype(i))
4431          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4432          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4433          if (itype(i-1).eq.10) then
4434           itype1=isign(10,itype(i-2))
4435           ichir11=isign(1,itype(i-2))
4436           ichir12=isign(1,itype(i-2))
4437           itype2=isign(10,itype(i))
4438           ichir21=isign(1,itype(i))
4439           ichir22=isign(1,itype(i))
4440          endif
4441
4442         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4443 #ifdef OSF
4444           phii=phi(i)
4445           if (phii.ne.phii) phii=150.0
4446 #else
4447           phii=phi(i)
4448 #endif
4449           y(1)=dcos(phii)
4450           y(2)=dsin(phii)
4451         else
4452           y(1)=0.0D0
4453           y(2)=0.0D0
4454         endif
4455         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4456 #ifdef OSF
4457           phii1=phi(i+1)
4458           if (phii1.ne.phii1) phii1=150.0
4459           phii1=pinorm(phii1)
4460           z(1)=cos(phii1)
4461 #else
4462           phii1=phi(i+1)
4463           z(1)=dcos(phii1)
4464 #endif
4465           z(2)=dsin(phii1)
4466         else
4467           z(1)=0.0D0
4468           z(2)=0.0D0
4469         endif
4470 C Calculate the "mean" value of theta from the part of the distribution
4471 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4472 C In following comments this theta will be referred to as t_c.
4473         thet_pred_mean=0.0d0
4474         do k=1,2
4475             athetk=athet(k,it,ichir1,ichir2)
4476             bthetk=bthet(k,it,ichir1,ichir2)
4477           if (it.eq.10) then
4478              athetk=athet(k,itype1,ichir11,ichir12)
4479              bthetk=bthet(k,itype2,ichir21,ichir22)
4480           endif
4481          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4482         enddo
4483         dthett=thet_pred_mean*ssd
4484         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4485 C Derivatives of the "mean" values in gamma1 and gamma2.
4486         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4487      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4488          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4489      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4490          if (it.eq.10) then
4491       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4492      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4493         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4494      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4495          endif
4496         if (theta(i).gt.pi-delta) then
4497           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4498      &         E_tc0)
4499           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4500           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4501           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4502      &        E_theta)
4503           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4504      &        E_tc)
4505         else if (theta(i).lt.delta) then
4506           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4507           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4508           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4509      &        E_theta)
4510           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4511           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4512      &        E_tc)
4513         else
4514           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4515      &        E_theta,E_tc)
4516         endif
4517         etheta=etheta+ethetai
4518         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4519      &      'ebend',i,ethetai
4520         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4521         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4522         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4523       enddo
4524 C Ufff.... We've done all this!!!
4525       return
4526       end
4527 C---------------------------------------------------------------------------
4528       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4529      &     E_tc)
4530       implicit real*8 (a-h,o-z)
4531       include 'DIMENSIONS'
4532       include 'COMMON.LOCAL'
4533       include 'COMMON.IOUNITS'
4534       common /calcthet/ term1,term2,termm,diffak,ratak,
4535      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4536      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4537 C Calculate the contributions to both Gaussian lobes.
4538 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4539 C The "polynomial part" of the "standard deviation" of this part of
4540 C the distribution.
4541         sig=polthet(3,it)
4542         do j=2,0,-1
4543           sig=sig*thet_pred_mean+polthet(j,it)
4544         enddo
4545 C Derivative of the "interior part" of the "standard deviation of the"
4546 C gamma-dependent Gaussian lobe in t_c.
4547         sigtc=3*polthet(3,it)
4548         do j=2,1,-1
4549           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4550         enddo
4551         sigtc=sig*sigtc
4552 C Set the parameters of both Gaussian lobes of the distribution.
4553 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4554         fac=sig*sig+sigc0(it)
4555         sigcsq=fac+fac
4556         sigc=1.0D0/sigcsq
4557 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4558         sigsqtc=-4.0D0*sigcsq*sigtc
4559 c       print *,i,sig,sigtc,sigsqtc
4560 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4561         sigtc=-sigtc/(fac*fac)
4562 C Following variable is sigma(t_c)**(-2)
4563         sigcsq=sigcsq*sigcsq
4564         sig0i=sig0(it)
4565         sig0inv=1.0D0/sig0i**2
4566         delthec=thetai-thet_pred_mean
4567         delthe0=thetai-theta0i
4568         term1=-0.5D0*sigcsq*delthec*delthec
4569         term2=-0.5D0*sig0inv*delthe0*delthe0
4570 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4571 C NaNs in taking the logarithm. We extract the largest exponent which is added
4572 C to the energy (this being the log of the distribution) at the end of energy
4573 C term evaluation for this virtual-bond angle.
4574         if (term1.gt.term2) then
4575           termm=term1
4576           term2=dexp(term2-termm)
4577           term1=1.0d0
4578         else
4579           termm=term2
4580           term1=dexp(term1-termm)
4581           term2=1.0d0
4582         endif
4583 C The ratio between the gamma-independent and gamma-dependent lobes of
4584 C the distribution is a Gaussian function of thet_pred_mean too.
4585         diffak=gthet(2,it)-thet_pred_mean
4586         ratak=diffak/gthet(3,it)**2
4587         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4588 C Let's differentiate it in thet_pred_mean NOW.
4589         aktc=ak*ratak
4590 C Now put together the distribution terms to make complete distribution.
4591         termexp=term1+ak*term2
4592         termpre=sigc+ak*sig0i
4593 C Contribution of the bending energy from this theta is just the -log of
4594 C the sum of the contributions from the two lobes and the pre-exponential
4595 C factor. Simple enough, isn't it?
4596         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4597 C NOW the derivatives!!!
4598 C 6/6/97 Take into account the deformation.
4599         E_theta=(delthec*sigcsq*term1
4600      &       +ak*delthe0*sig0inv*term2)/termexp
4601         E_tc=((sigtc+aktc*sig0i)/termpre
4602      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4603      &       aktc*term2)/termexp)
4604       return
4605       end
4606 c-----------------------------------------------------------------------------
4607       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4608       implicit real*8 (a-h,o-z)
4609       include 'DIMENSIONS'
4610       include 'COMMON.LOCAL'
4611       include 'COMMON.IOUNITS'
4612       common /calcthet/ term1,term2,termm,diffak,ratak,
4613      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4614      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4615       delthec=thetai-thet_pred_mean
4616       delthe0=thetai-theta0i
4617 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4618       t3 = thetai-thet_pred_mean
4619       t6 = t3**2
4620       t9 = term1
4621       t12 = t3*sigcsq
4622       t14 = t12+t6*sigsqtc
4623       t16 = 1.0d0
4624       t21 = thetai-theta0i
4625       t23 = t21**2
4626       t26 = term2
4627       t27 = t21*t26
4628       t32 = termexp
4629       t40 = t32**2
4630       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4631      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4632      & *(-t12*t9-ak*sig0inv*t27)
4633       return
4634       end
4635 #else
4636 C--------------------------------------------------------------------------
4637       subroutine ebend(etheta)
4638 C
4639 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4640 C angles gamma and its derivatives in consecutive thetas and gammas.
4641 C ab initio-derived potentials from
4642 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4643 C
4644       implicit real*8 (a-h,o-z)
4645       include 'DIMENSIONS'
4646       include 'COMMON.LOCAL'
4647       include 'COMMON.GEO'
4648       include 'COMMON.INTERACT'
4649       include 'COMMON.DERIV'
4650       include 'COMMON.VAR'
4651       include 'COMMON.CHAIN'
4652       include 'COMMON.IOUNITS'
4653       include 'COMMON.NAMES'
4654       include 'COMMON.FFIELD'
4655       include 'COMMON.CONTROL'
4656       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4657      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4658      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4659      & sinph1ph2(maxdouble,maxdouble)
4660       logical lprn /.false./, lprn1 /.false./
4661       etheta=0.0D0
4662       do i=ithet_start,ithet_end
4663         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4664      &(itype(i).eq.ntyp1)) cycle
4665 C        print *,i,theta(i)
4666         if (iabs(itype(i+1)).eq.20) iblock=2
4667         if (iabs(itype(i+1)).ne.20) iblock=1
4668         dethetai=0.0d0
4669         dephii=0.0d0
4670         dephii1=0.0d0
4671         theti2=0.5d0*theta(i)
4672         ityp2=ithetyp((itype(i-1)))
4673         do k=1,nntheterm
4674           coskt(k)=dcos(k*theti2)
4675           sinkt(k)=dsin(k*theti2)
4676         enddo
4677 C        print *,ethetai
4678
4679         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4680 #ifdef OSF
4681           phii=phi(i)
4682           if (phii.ne.phii) phii=150.0
4683 #else
4684           phii=phi(i)
4685 #endif
4686           ityp1=ithetyp((itype(i-2)))
4687 C propagation of chirality for glycine type
4688           do k=1,nsingle
4689             cosph1(k)=dcos(k*phii)
4690             sinph1(k)=dsin(k*phii)
4691           enddo
4692         else
4693           phii=0.0d0
4694           do k=1,nsingle
4695           ityp1=ithetyp((itype(i-2)))
4696             cosph1(k)=0.0d0
4697             sinph1(k)=0.0d0
4698           enddo
4699         endif
4700         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4701 #ifdef OSF
4702           phii1=phi(i+1)
4703           if (phii1.ne.phii1) phii1=150.0
4704           phii1=pinorm(phii1)
4705 #else
4706           phii1=phi(i+1)
4707 #endif
4708           ityp3=ithetyp((itype(i)))
4709           do k=1,nsingle
4710             cosph2(k)=dcos(k*phii1)
4711             sinph2(k)=dsin(k*phii1)
4712           enddo
4713         else
4714           phii1=0.0d0
4715           ityp3=ithetyp((itype(i)))
4716           do k=1,nsingle
4717             cosph2(k)=0.0d0
4718             sinph2(k)=0.0d0
4719           enddo
4720         endif
4721         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4722         do k=1,ndouble
4723           do l=1,k-1
4724             ccl=cosph1(l)*cosph2(k-l)
4725             ssl=sinph1(l)*sinph2(k-l)
4726             scl=sinph1(l)*cosph2(k-l)
4727             csl=cosph1(l)*sinph2(k-l)
4728             cosph1ph2(l,k)=ccl-ssl
4729             cosph1ph2(k,l)=ccl+ssl
4730             sinph1ph2(l,k)=scl+csl
4731             sinph1ph2(k,l)=scl-csl
4732           enddo
4733         enddo
4734         if (lprn) then
4735         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4736      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4737         write (iout,*) "coskt and sinkt"
4738         do k=1,nntheterm
4739           write (iout,*) k,coskt(k),sinkt(k)
4740         enddo
4741         endif
4742         do k=1,ntheterm
4743           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4744           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4745      &      *coskt(k)
4746           if (lprn)
4747      &    write (iout,*) "k",k,"
4748      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4749      &     " ethetai",ethetai
4750         enddo
4751         if (lprn) then
4752         write (iout,*) "cosph and sinph"
4753         do k=1,nsingle
4754           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4755         enddo
4756         write (iout,*) "cosph1ph2 and sinph2ph2"
4757         do k=2,ndouble
4758           do l=1,k-1
4759             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4760      &         sinph1ph2(l,k),sinph1ph2(k,l)
4761           enddo
4762         enddo
4763         write(iout,*) "ethetai",ethetai
4764         endif
4765 C       print *,ethetai
4766         do m=1,ntheterm2
4767           do k=1,nsingle
4768             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4769      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4770      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4771      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4772             ethetai=ethetai+sinkt(m)*aux
4773             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4774             dephii=dephii+k*sinkt(m)*(
4775      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4776      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4777             dephii1=dephii1+k*sinkt(m)*(
4778      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4779      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4780             if (lprn)
4781      &      write (iout,*) "m",m," k",k," bbthet",
4782      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4783      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4784      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4785      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4786 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4787           enddo
4788         enddo
4789 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4790 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4791 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4792 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4793         if (lprn)
4794      &  write(iout,*) "ethetai",ethetai
4795 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4796         do m=1,ntheterm3
4797           do k=2,ndouble
4798             do l=1,k-1
4799               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4800      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4801      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4802      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4803               ethetai=ethetai+sinkt(m)*aux
4804               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4805               dephii=dephii+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               dephii1=dephii1+(k-l)*sinkt(m)*(
4811      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4812      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4813      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4814      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4815               if (lprn) then
4816               write (iout,*) "m",m," k",k," l",l," ffthet",
4817      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4818      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4819      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4820      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4821      &            " ethetai",ethetai
4822               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4823      &            cosph1ph2(k,l)*sinkt(m),
4824      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4825               endif
4826             enddo
4827           enddo
4828         enddo
4829 10      continue
4830 c        lprn1=.true.
4831 C        print *,ethetai
4832         if (lprn1)
4833      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4834      &   i,theta(i)*rad2deg,phii*rad2deg,
4835      &   phii1*rad2deg,ethetai
4836 c        lprn1=.false.
4837         etheta=etheta+ethetai
4838         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4839         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4840         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4841       enddo
4842       return
4843       end
4844 #endif
4845 #ifdef CRYST_SC
4846 c-----------------------------------------------------------------------------
4847       subroutine esc(escloc)
4848 C Calculate the local energy of a side chain and its derivatives in the
4849 C corresponding virtual-bond valence angles THETA and the spherical angles
4850 C ALPHA and OMEGA.
4851       implicit real*8 (a-h,o-z)
4852       include 'DIMENSIONS'
4853       include 'COMMON.GEO'
4854       include 'COMMON.LOCAL'
4855       include 'COMMON.VAR'
4856       include 'COMMON.INTERACT'
4857       include 'COMMON.DERIV'
4858       include 'COMMON.CHAIN'
4859       include 'COMMON.IOUNITS'
4860       include 'COMMON.NAMES'
4861       include 'COMMON.FFIELD'
4862       include 'COMMON.CONTROL'
4863       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4864      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4865       common /sccalc/ time11,time12,time112,theti,it,nlobit
4866       delta=0.02d0*pi
4867       escloc=0.0D0
4868 c     write (iout,'(a)') 'ESC'
4869       do i=loc_start,loc_end
4870         it=itype(i)
4871         if (it.eq.ntyp1) cycle
4872         if (it.eq.10) goto 1
4873         nlobit=nlob(iabs(it))
4874 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4875 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4876         theti=theta(i+1)-pipol
4877         x(1)=dtan(theti)
4878         x(2)=alph(i)
4879         x(3)=omeg(i)
4880
4881         if (x(2).gt.pi-delta) then
4882           xtemp(1)=x(1)
4883           xtemp(2)=pi-delta
4884           xtemp(3)=x(3)
4885           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4886           xtemp(2)=pi
4887           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4888           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4889      &        escloci,dersc(2))
4890           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4891      &        ddersc0(1),dersc(1))
4892           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4893      &        ddersc0(3),dersc(3))
4894           xtemp(2)=pi-delta
4895           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4896           xtemp(2)=pi
4897           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4898           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4899      &            dersc0(2),esclocbi,dersc02)
4900           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4901      &            dersc12,dersc01)
4902           call splinthet(x(2),0.5d0*delta,ss,ssd)
4903           dersc0(1)=dersc01
4904           dersc0(2)=dersc02
4905           dersc0(3)=0.0d0
4906           do k=1,3
4907             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4908           enddo
4909           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4910 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4911 c    &             esclocbi,ss,ssd
4912           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4913 c         escloci=esclocbi
4914 c         write (iout,*) escloci
4915         else if (x(2).lt.delta) then
4916           xtemp(1)=x(1)
4917           xtemp(2)=delta
4918           xtemp(3)=x(3)
4919           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4920           xtemp(2)=0.0d0
4921           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4922           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4923      &        escloci,dersc(2))
4924           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4925      &        ddersc0(1),dersc(1))
4926           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4927      &        ddersc0(3),dersc(3))
4928           xtemp(2)=delta
4929           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4930           xtemp(2)=0.0d0
4931           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4932           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4933      &            dersc0(2),esclocbi,dersc02)
4934           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4935      &            dersc12,dersc01)
4936           dersc0(1)=dersc01
4937           dersc0(2)=dersc02
4938           dersc0(3)=0.0d0
4939           call splinthet(x(2),0.5d0*delta,ss,ssd)
4940           do k=1,3
4941             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4942           enddo
4943           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4944 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4945 c    &             esclocbi,ss,ssd
4946           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4947 c         write (iout,*) escloci
4948         else
4949           call enesc(x,escloci,dersc,ddummy,.false.)
4950         endif
4951
4952         escloc=escloc+escloci
4953         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4954      &     'escloc',i,escloci
4955 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4956
4957         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4958      &   wscloc*dersc(1)
4959         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4960         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4961     1   continue
4962       enddo
4963       return
4964       end
4965 C---------------------------------------------------------------------------
4966       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4967       implicit real*8 (a-h,o-z)
4968       include 'DIMENSIONS'
4969       include 'COMMON.GEO'
4970       include 'COMMON.LOCAL'
4971       include 'COMMON.IOUNITS'
4972       common /sccalc/ time11,time12,time112,theti,it,nlobit
4973       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4974       double precision contr(maxlob,-1:1)
4975       logical mixed
4976 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4977         escloc_i=0.0D0
4978         do j=1,3
4979           dersc(j)=0.0D0
4980           if (mixed) ddersc(j)=0.0d0
4981         enddo
4982         x3=x(3)
4983
4984 C Because of periodicity of the dependence of the SC energy in omega we have
4985 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4986 C To avoid underflows, first compute & store the exponents.
4987
4988         do iii=-1,1
4989
4990           x(3)=x3+iii*dwapi
4991
4992           do j=1,nlobit
4993             do k=1,3
4994               z(k)=x(k)-censc(k,j,it)
4995             enddo
4996             do k=1,3
4997               Axk=0.0D0
4998               do l=1,3
4999                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5000               enddo
5001               Ax(k,j,iii)=Axk
5002             enddo
5003             expfac=0.0D0
5004             do k=1,3
5005               expfac=expfac+Ax(k,j,iii)*z(k)
5006             enddo
5007             contr(j,iii)=expfac
5008           enddo ! j
5009
5010         enddo ! iii
5011
5012         x(3)=x3
5013 C As in the case of ebend, we want to avoid underflows in exponentiation and
5014 C subsequent NaNs and INFs in energy calculation.
5015 C Find the largest exponent
5016         emin=contr(1,-1)
5017         do iii=-1,1
5018           do j=1,nlobit
5019             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5020           enddo
5021         enddo
5022         emin=0.5D0*emin
5023 cd      print *,'it=',it,' emin=',emin
5024
5025 C Compute the contribution to SC energy and derivatives
5026         do iii=-1,1
5027
5028           do j=1,nlobit
5029 #ifdef OSF
5030             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5031             if(adexp.ne.adexp) adexp=1.0
5032             expfac=dexp(adexp)
5033 #else
5034             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5035 #endif
5036 cd          print *,'j=',j,' expfac=',expfac
5037             escloc_i=escloc_i+expfac
5038             do k=1,3
5039               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5040             enddo
5041             if (mixed) then
5042               do k=1,3,2
5043                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5044      &            +gaussc(k,2,j,it))*expfac
5045               enddo
5046             endif
5047           enddo
5048
5049         enddo ! iii
5050
5051         dersc(1)=dersc(1)/cos(theti)**2
5052         ddersc(1)=ddersc(1)/cos(theti)**2
5053         ddersc(3)=ddersc(3)
5054
5055         escloci=-(dlog(escloc_i)-emin)
5056         do j=1,3
5057           dersc(j)=dersc(j)/escloc_i
5058         enddo
5059         if (mixed) then
5060           do j=1,3,2
5061             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5062           enddo
5063         endif
5064       return
5065       end
5066 C------------------------------------------------------------------------------
5067       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5068       implicit real*8 (a-h,o-z)
5069       include 'DIMENSIONS'
5070       include 'COMMON.GEO'
5071       include 'COMMON.LOCAL'
5072       include 'COMMON.IOUNITS'
5073       common /sccalc/ time11,time12,time112,theti,it,nlobit
5074       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5075       double precision contr(maxlob)
5076       logical mixed
5077
5078       escloc_i=0.0D0
5079
5080       do j=1,3
5081         dersc(j)=0.0D0
5082       enddo
5083
5084       do j=1,nlobit
5085         do k=1,2
5086           z(k)=x(k)-censc(k,j,it)
5087         enddo
5088         z(3)=dwapi
5089         do k=1,3
5090           Axk=0.0D0
5091           do l=1,3
5092             Axk=Axk+gaussc(l,k,j,it)*z(l)
5093           enddo
5094           Ax(k,j)=Axk
5095         enddo
5096         expfac=0.0D0
5097         do k=1,3
5098           expfac=expfac+Ax(k,j)*z(k)
5099         enddo
5100         contr(j)=expfac
5101       enddo ! j
5102
5103 C As in the case of ebend, we want to avoid underflows in exponentiation and
5104 C subsequent NaNs and INFs in energy calculation.
5105 C Find the largest exponent
5106       emin=contr(1)
5107       do j=1,nlobit
5108         if (emin.gt.contr(j)) emin=contr(j)
5109       enddo
5110       emin=0.5D0*emin
5111
5112 C Compute the contribution to SC energy and derivatives
5113
5114       dersc12=0.0d0
5115       do j=1,nlobit
5116         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5117         escloc_i=escloc_i+expfac
5118         do k=1,2
5119           dersc(k)=dersc(k)+Ax(k,j)*expfac
5120         enddo
5121         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5122      &            +gaussc(1,2,j,it))*expfac
5123         dersc(3)=0.0d0
5124       enddo
5125
5126       dersc(1)=dersc(1)/cos(theti)**2
5127       dersc12=dersc12/cos(theti)**2
5128       escloci=-(dlog(escloc_i)-emin)
5129       do j=1,2
5130         dersc(j)=dersc(j)/escloc_i
5131       enddo
5132       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5133       return
5134       end
5135 #else
5136 c----------------------------------------------------------------------------------
5137       subroutine esc(escloc)
5138 C Calculate the local energy of a side chain and its derivatives in the
5139 C corresponding virtual-bond valence angles THETA and the spherical angles
5140 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5141 C added by Urszula Kozlowska. 07/11/2007
5142 C
5143       implicit real*8 (a-h,o-z)
5144       include 'DIMENSIONS'
5145       include 'COMMON.GEO'
5146       include 'COMMON.LOCAL'
5147       include 'COMMON.VAR'
5148       include 'COMMON.SCROT'
5149       include 'COMMON.INTERACT'
5150       include 'COMMON.DERIV'
5151       include 'COMMON.CHAIN'
5152       include 'COMMON.IOUNITS'
5153       include 'COMMON.NAMES'
5154       include 'COMMON.FFIELD'
5155       include 'COMMON.CONTROL'
5156       include 'COMMON.VECTORS'
5157       double precision x_prime(3),y_prime(3),z_prime(3)
5158      &    , sumene,dsc_i,dp2_i,x(65),
5159      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5160      &    de_dxx,de_dyy,de_dzz,de_dt
5161       double precision s1_t,s1_6_t,s2_t,s2_6_t
5162       double precision
5163      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5164      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5165      & dt_dCi(3),dt_dCi1(3)
5166       common /sccalc/ time11,time12,time112,theti,it,nlobit
5167       delta=0.02d0*pi
5168       escloc=0.0D0
5169       do i=loc_start,loc_end
5170         if (itype(i).eq.ntyp1) cycle
5171         costtab(i+1) =dcos(theta(i+1))
5172         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5173         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5174         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5175         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5176         cosfac=dsqrt(cosfac2)
5177         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5178         sinfac=dsqrt(sinfac2)
5179         it=iabs(itype(i))
5180         if (it.eq.10) goto 1
5181 c
5182 C  Compute the axes of tghe local cartesian coordinates system; store in
5183 c   x_prime, y_prime and z_prime
5184 c
5185         do j=1,3
5186           x_prime(j) = 0.00
5187           y_prime(j) = 0.00
5188           z_prime(j) = 0.00
5189         enddo
5190 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5191 C     &   dc_norm(3,i+nres)
5192         do j = 1,3
5193           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5194           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5195         enddo
5196         do j = 1,3
5197           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5198         enddo
5199 c       write (2,*) "i",i
5200 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5201 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5202 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5203 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5204 c      & " xy",scalar(x_prime(1),y_prime(1)),
5205 c      & " xz",scalar(x_prime(1),z_prime(1)),
5206 c      & " yy",scalar(y_prime(1),y_prime(1)),
5207 c      & " yz",scalar(y_prime(1),z_prime(1)),
5208 c      & " zz",scalar(z_prime(1),z_prime(1))
5209 c
5210 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5211 C to local coordinate system. Store in xx, yy, zz.
5212 c
5213         xx=0.0d0
5214         yy=0.0d0
5215         zz=0.0d0
5216         do j = 1,3
5217           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5218           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5219           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5220         enddo
5221
5222         xxtab(i)=xx
5223         yytab(i)=yy
5224         zztab(i)=zz
5225 C
5226 C Compute the energy of the ith side cbain
5227 C
5228 c        write (2,*) "xx",xx," yy",yy," zz",zz
5229         it=iabs(itype(i))
5230         do j = 1,65
5231           x(j) = sc_parmin(j,it)
5232         enddo
5233 #ifdef CHECK_COORD
5234 Cc diagnostics - remove later
5235         xx1 = dcos(alph(2))
5236         yy1 = dsin(alph(2))*dcos(omeg(2))
5237         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5238         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5239      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5240      &    xx1,yy1,zz1
5241 C,"  --- ", xx_w,yy_w,zz_w
5242 c end diagnostics
5243 #endif
5244         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5245      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5246      &   + x(10)*yy*zz
5247         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5248      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5249      & + x(20)*yy*zz
5250         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5251      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5252      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5253      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5254      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5255      &  +x(40)*xx*yy*zz
5256         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5257      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5258      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5259      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5260      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5261      &  +x(60)*xx*yy*zz
5262         dsc_i   = 0.743d0+x(61)
5263         dp2_i   = 1.9d0+x(62)
5264         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5265      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5266         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5267      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5268         s1=(1+x(63))/(0.1d0 + dscp1)
5269         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5270         s2=(1+x(65))/(0.1d0 + dscp2)
5271         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5272         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5273      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5274 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5275 c     &   sumene4,
5276 c     &   dscp1,dscp2,sumene
5277 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5278         escloc = escloc + sumene
5279 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5280 c     & ,zz,xx,yy
5281 c#define DEBUG
5282 #ifdef DEBUG
5283 C
5284 C This section to check the numerical derivatives of the energy of ith side
5285 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5286 C #define DEBUG in the code to turn it on.
5287 C
5288         write (2,*) "sumene               =",sumene
5289         aincr=1.0d-7
5290         xxsave=xx
5291         xx=xx+aincr
5292         write (2,*) xx,yy,zz
5293         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5294         de_dxx_num=(sumenep-sumene)/aincr
5295         xx=xxsave
5296         write (2,*) "xx+ sumene from enesc=",sumenep
5297         yysave=yy
5298         yy=yy+aincr
5299         write (2,*) xx,yy,zz
5300         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5301         de_dyy_num=(sumenep-sumene)/aincr
5302         yy=yysave
5303         write (2,*) "yy+ sumene from enesc=",sumenep
5304         zzsave=zz
5305         zz=zz+aincr
5306         write (2,*) xx,yy,zz
5307         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5308         de_dzz_num=(sumenep-sumene)/aincr
5309         zz=zzsave
5310         write (2,*) "zz+ sumene from enesc=",sumenep
5311         costsave=cost2tab(i+1)
5312         sintsave=sint2tab(i+1)
5313         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5314         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5315         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5316         de_dt_num=(sumenep-sumene)/aincr
5317         write (2,*) " t+ sumene from enesc=",sumenep
5318         cost2tab(i+1)=costsave
5319         sint2tab(i+1)=sintsave
5320 C End of diagnostics section.
5321 #endif
5322 C
5323 C Compute the gradient of esc
5324 C
5325 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5326         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5327         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5328         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5329         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5330         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5331         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5332         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5333         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5334         pom1=(sumene3*sint2tab(i+1)+sumene1)
5335      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5336         pom2=(sumene4*cost2tab(i+1)+sumene2)
5337      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5338         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5339         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5340      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5341      &  +x(40)*yy*zz
5342         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5343         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5344      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5345      &  +x(60)*yy*zz
5346         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5347      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5348      &        +(pom1+pom2)*pom_dx
5349 #ifdef DEBUG
5350         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5351 #endif
5352 C
5353         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5354         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5355      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5356      &  +x(40)*xx*zz
5357         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5358         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5359      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5360      &  +x(59)*zz**2 +x(60)*xx*zz
5361         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5362      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5363      &        +(pom1-pom2)*pom_dy
5364 #ifdef DEBUG
5365         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5366 #endif
5367 C
5368         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5369      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5370      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5371      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5372      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5373      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5374      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5375      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5376 #ifdef DEBUG
5377         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5378 #endif
5379 C
5380         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5381      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5382      &  +pom1*pom_dt1+pom2*pom_dt2
5383 #ifdef DEBUG
5384         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5385 #endif
5386 c#undef DEBUG
5387 c
5388 C
5389        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5390        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5391        cosfac2xx=cosfac2*xx
5392        sinfac2yy=sinfac2*yy
5393        do k = 1,3
5394          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5395      &      vbld_inv(i+1)
5396          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5397      &      vbld_inv(i)
5398          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5399          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5400 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5401 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5402 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5403 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5404          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5405          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5406          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5407          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5408          dZZ_Ci1(k)=0.0d0
5409          dZZ_Ci(k)=0.0d0
5410          do j=1,3
5411            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5412      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5413            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5414      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5415          enddo
5416
5417          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5418          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5419          dZZ_XYZ(k)=vbld_inv(i+nres)*
5420      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5421 c
5422          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5423          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5424        enddo
5425
5426        do k=1,3
5427          dXX_Ctab(k,i)=dXX_Ci(k)
5428          dXX_C1tab(k,i)=dXX_Ci1(k)
5429          dYY_Ctab(k,i)=dYY_Ci(k)
5430          dYY_C1tab(k,i)=dYY_Ci1(k)
5431          dZZ_Ctab(k,i)=dZZ_Ci(k)
5432          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5433          dXX_XYZtab(k,i)=dXX_XYZ(k)
5434          dYY_XYZtab(k,i)=dYY_XYZ(k)
5435          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5436        enddo
5437
5438        do k = 1,3
5439 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5440 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5441 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5442 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5443 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5444 c     &    dt_dci(k)
5445 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5446 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5447          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5448      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5449          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5450      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5451          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5452      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5453        enddo
5454 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5455 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5456
5457 C to check gradient call subroutine check_grad
5458
5459     1 continue
5460       enddo
5461       return
5462       end
5463 c------------------------------------------------------------------------------
5464       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5465       implicit none
5466       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5467      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5468       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5469      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5470      &   + x(10)*yy*zz
5471       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5472      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5473      & + x(20)*yy*zz
5474       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5475      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5476      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5477      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5478      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5479      &  +x(40)*xx*yy*zz
5480       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5481      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5482      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5483      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5484      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5485      &  +x(60)*xx*yy*zz
5486       dsc_i   = 0.743d0+x(61)
5487       dp2_i   = 1.9d0+x(62)
5488       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5489      &          *(xx*cost2+yy*sint2))
5490       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5491      &          *(xx*cost2-yy*sint2))
5492       s1=(1+x(63))/(0.1d0 + dscp1)
5493       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5494       s2=(1+x(65))/(0.1d0 + dscp2)
5495       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5496       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5497      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5498       enesc=sumene
5499       return
5500       end
5501 #endif
5502 c------------------------------------------------------------------------------
5503       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5504 C
5505 C This procedure calculates two-body contact function g(rij) and its derivative:
5506 C
5507 C           eps0ij                                     !       x < -1
5508 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5509 C            0                                         !       x > 1
5510 C
5511 C where x=(rij-r0ij)/delta
5512 C
5513 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5514 C
5515       implicit none
5516       double precision rij,r0ij,eps0ij,fcont,fprimcont
5517       double precision x,x2,x4,delta
5518 c     delta=0.02D0*r0ij
5519 c      delta=0.2D0*r0ij
5520       x=(rij-r0ij)/delta
5521       if (x.lt.-1.0D0) then
5522         fcont=eps0ij
5523         fprimcont=0.0D0
5524       else if (x.le.1.0D0) then
5525         x2=x*x
5526         x4=x2*x2
5527         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5528         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5529       else
5530         fcont=0.0D0
5531         fprimcont=0.0D0
5532       endif
5533       return
5534       end
5535 c------------------------------------------------------------------------------
5536       subroutine splinthet(theti,delta,ss,ssder)
5537       implicit real*8 (a-h,o-z)
5538       include 'DIMENSIONS'
5539       include 'COMMON.VAR'
5540       include 'COMMON.GEO'
5541       thetup=pi-delta
5542       thetlow=delta
5543       if (theti.gt.pipol) then
5544         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5545       else
5546         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5547         ssder=-ssder
5548       endif
5549       return
5550       end
5551 c------------------------------------------------------------------------------
5552       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5553       implicit none
5554       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5555       double precision ksi,ksi2,ksi3,a1,a2,a3
5556       a1=fprim0*delta/(f1-f0)
5557       a2=3.0d0-2.0d0*a1
5558       a3=a1-2.0d0
5559       ksi=(x-x0)/delta
5560       ksi2=ksi*ksi
5561       ksi3=ksi2*ksi
5562       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5563       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5564       return
5565       end
5566 c------------------------------------------------------------------------------
5567       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5568       implicit none
5569       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5570       double precision ksi,ksi2,ksi3,a1,a2,a3
5571       ksi=(x-x0)/delta
5572       ksi2=ksi*ksi
5573       ksi3=ksi2*ksi
5574       a1=fprim0x*delta
5575       a2=3*(f1x-f0x)-2*fprim0x*delta
5576       a3=fprim0x*delta-2*(f1x-f0x)
5577       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5578       return
5579       end
5580 C-----------------------------------------------------------------------------
5581 #ifdef CRYST_TOR
5582 C-----------------------------------------------------------------------------
5583       subroutine etor(etors,edihcnstr)
5584       implicit real*8 (a-h,o-z)
5585       include 'DIMENSIONS'
5586       include 'COMMON.VAR'
5587       include 'COMMON.GEO'
5588       include 'COMMON.LOCAL'
5589       include 'COMMON.TORSION'
5590       include 'COMMON.INTERACT'
5591       include 'COMMON.DERIV'
5592       include 'COMMON.CHAIN'
5593       include 'COMMON.NAMES'
5594       include 'COMMON.IOUNITS'
5595       include 'COMMON.FFIELD'
5596       include 'COMMON.TORCNSTR'
5597       include 'COMMON.CONTROL'
5598       logical lprn
5599 C Set lprn=.true. for debugging
5600       lprn=.false.
5601 c      lprn=.true.
5602       etors=0.0D0
5603       do i=iphi_start,iphi_end
5604       etors_ii=0.0D0
5605         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5606      &      .or. itype(i).eq.ntyp1) cycle
5607         itori=itortyp(itype(i-2))
5608         itori1=itortyp(itype(i-1))
5609         phii=phi(i)
5610         gloci=0.0D0
5611 C Proline-Proline pair is a special case...
5612         if (itori.eq.3 .and. itori1.eq.3) then
5613           if (phii.gt.-dwapi3) then
5614             cosphi=dcos(3*phii)
5615             fac=1.0D0/(1.0D0-cosphi)
5616             etorsi=v1(1,3,3)*fac
5617             etorsi=etorsi+etorsi
5618             etors=etors+etorsi-v1(1,3,3)
5619             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5620             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5621           endif
5622           do j=1,3
5623             v1ij=v1(j+1,itori,itori1)
5624             v2ij=v2(j+1,itori,itori1)
5625             cosphi=dcos(j*phii)
5626             sinphi=dsin(j*phii)
5627             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5628             if (energy_dec) etors_ii=etors_ii+
5629      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5630             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5631           enddo
5632         else
5633           do j=1,nterm_old
5634             v1ij=v1(j,itori,itori1)
5635             v2ij=v2(j,itori,itori1)
5636             cosphi=dcos(j*phii)
5637             sinphi=dsin(j*phii)
5638             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5639             if (energy_dec) etors_ii=etors_ii+
5640      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5641             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5642           enddo
5643         endif
5644         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5645              'etor',i,etors_ii
5646         if (lprn)
5647      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5648      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5649      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5650         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5651 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5652       enddo
5653 ! 6/20/98 - dihedral angle constraints
5654       edihcnstr=0.0d0
5655       do i=1,ndih_constr
5656         itori=idih_constr(i)
5657         phii=phi(itori)
5658         difi=phii-phi0(i)
5659         if (difi.gt.drange(i)) then
5660           difi=difi-drange(i)
5661           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5662           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5663         else if (difi.lt.-drange(i)) then
5664           difi=difi+drange(i)
5665           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5666           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5667         endif
5668 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5669 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5670       enddo
5671 !      write (iout,*) 'edihcnstr',edihcnstr
5672       return
5673       end
5674 c------------------------------------------------------------------------------
5675       subroutine etor_d(etors_d)
5676       etors_d=0.0d0
5677       return
5678       end
5679 c----------------------------------------------------------------------------
5680 #else
5681       subroutine etor(etors,edihcnstr)
5682       implicit real*8 (a-h,o-z)
5683       include 'DIMENSIONS'
5684       include 'COMMON.VAR'
5685       include 'COMMON.GEO'
5686       include 'COMMON.LOCAL'
5687       include 'COMMON.TORSION'
5688       include 'COMMON.INTERACT'
5689       include 'COMMON.DERIV'
5690       include 'COMMON.CHAIN'
5691       include 'COMMON.NAMES'
5692       include 'COMMON.IOUNITS'
5693       include 'COMMON.FFIELD'
5694       include 'COMMON.TORCNSTR'
5695       include 'COMMON.CONTROL'
5696       logical lprn
5697 C Set lprn=.true. for debugging
5698       lprn=.false.
5699 c     lprn=.true.
5700       etors=0.0D0
5701       do i=iphi_start,iphi_end
5702         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5703      &       .or. itype(i).eq.ntyp1) cycle
5704         etors_ii=0.0D0
5705          if (iabs(itype(i)).eq.20) then
5706          iblock=2
5707          else
5708          iblock=1
5709          endif
5710         itori=itortyp(itype(i-2))
5711         itori1=itortyp(itype(i-1))
5712         phii=phi(i)
5713         gloci=0.0D0
5714 C Regular cosine and sine terms
5715         do j=1,nterm(itori,itori1,iblock)
5716           v1ij=v1(j,itori,itori1,iblock)
5717           v2ij=v2(j,itori,itori1,iblock)
5718           cosphi=dcos(j*phii)
5719           sinphi=dsin(j*phii)
5720           etors=etors+v1ij*cosphi+v2ij*sinphi
5721           if (energy_dec) etors_ii=etors_ii+
5722      &                v1ij*cosphi+v2ij*sinphi
5723           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5724         enddo
5725 C Lorentz terms
5726 C                         v1
5727 C  E = SUM ----------------------------------- - v1
5728 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5729 C
5730         cosphi=dcos(0.5d0*phii)
5731         sinphi=dsin(0.5d0*phii)
5732         do j=1,nlor(itori,itori1,iblock)
5733           vl1ij=vlor1(j,itori,itori1)
5734           vl2ij=vlor2(j,itori,itori1)
5735           vl3ij=vlor3(j,itori,itori1)
5736           pom=vl2ij*cosphi+vl3ij*sinphi
5737           pom1=1.0d0/(pom*pom+1.0d0)
5738           etors=etors+vl1ij*pom1
5739           if (energy_dec) etors_ii=etors_ii+
5740      &                vl1ij*pom1
5741           pom=-pom*pom1*pom1
5742           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5743         enddo
5744 C Subtract the constant term
5745         etors=etors-v0(itori,itori1,iblock)
5746           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5747      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5748         if (lprn)
5749      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5750      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5751      &  (v1(j,itori,itori1,iblock),j=1,6),
5752      &  (v2(j,itori,itori1,iblock),j=1,6)
5753         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5754 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5755       enddo
5756 ! 6/20/98 - dihedral angle constraints
5757       edihcnstr=0.0d0
5758 c      do i=1,ndih_constr
5759       do i=idihconstr_start,idihconstr_end
5760         itori=idih_constr(i)
5761         phii=phi(itori)
5762         difi=pinorm(phii-phi0(i))
5763         if (difi.gt.drange(i)) then
5764           difi=difi-drange(i)
5765           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5766           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5767         else if (difi.lt.-drange(i)) then
5768           difi=difi+drange(i)
5769           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5770           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5771         else
5772           difi=0.0
5773         endif
5774 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5775 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5776 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5777       enddo
5778 cd       write (iout,*) 'edihcnstr',edihcnstr
5779       return
5780       end
5781 c----------------------------------------------------------------------------
5782       subroutine etor_d(etors_d)
5783 C 6/23/01 Compute double torsional energy
5784       implicit real*8 (a-h,o-z)
5785       include 'DIMENSIONS'
5786       include 'COMMON.VAR'
5787       include 'COMMON.GEO'
5788       include 'COMMON.LOCAL'
5789       include 'COMMON.TORSION'
5790       include 'COMMON.INTERACT'
5791       include 'COMMON.DERIV'
5792       include 'COMMON.CHAIN'
5793       include 'COMMON.NAMES'
5794       include 'COMMON.IOUNITS'
5795       include 'COMMON.FFIELD'
5796       include 'COMMON.TORCNSTR'
5797       logical lprn
5798 C Set lprn=.true. for debugging
5799       lprn=.false.
5800 c     lprn=.true.
5801       etors_d=0.0D0
5802 c      write(iout,*) "a tu??"
5803       do i=iphid_start,iphid_end
5804         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5805      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5806         itori=itortyp(itype(i-2))
5807         itori1=itortyp(itype(i-1))
5808         itori2=itortyp(itype(i))
5809         phii=phi(i)
5810         phii1=phi(i+1)
5811         gloci1=0.0D0
5812         gloci2=0.0D0
5813         iblock=1
5814         if (iabs(itype(i+1)).eq.20) iblock=2
5815
5816 C Regular cosine and sine terms
5817         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5818           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5819           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5820           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5821           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5822           cosphi1=dcos(j*phii)
5823           sinphi1=dsin(j*phii)
5824           cosphi2=dcos(j*phii1)
5825           sinphi2=dsin(j*phii1)
5826           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5827      &     v2cij*cosphi2+v2sij*sinphi2
5828           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5829           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5830         enddo
5831         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5832           do l=1,k-1
5833             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5834             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5835             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5836             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5837             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5838             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5839             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5840             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5841             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5842      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5843             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5844      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5845             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5846      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5847           enddo
5848         enddo
5849         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5850         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5851       enddo
5852       return
5853       end
5854 #endif
5855 c------------------------------------------------------------------------------
5856       subroutine eback_sc_corr(esccor)
5857 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5858 c        conformational states; temporarily implemented as differences
5859 c        between UNRES torsional potentials (dependent on three types of
5860 c        residues) and the torsional potentials dependent on all 20 types
5861 c        of residues computed from AM1  energy surfaces of terminally-blocked
5862 c        amino-acid residues.
5863       implicit real*8 (a-h,o-z)
5864       include 'DIMENSIONS'
5865       include 'COMMON.VAR'
5866       include 'COMMON.GEO'
5867       include 'COMMON.LOCAL'
5868       include 'COMMON.TORSION'
5869       include 'COMMON.SCCOR'
5870       include 'COMMON.INTERACT'
5871       include 'COMMON.DERIV'
5872       include 'COMMON.CHAIN'
5873       include 'COMMON.NAMES'
5874       include 'COMMON.IOUNITS'
5875       include 'COMMON.FFIELD'
5876       include 'COMMON.CONTROL'
5877       logical lprn
5878 C Set lprn=.true. for debugging
5879       lprn=.false.
5880 c      lprn=.true.
5881 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5882       esccor=0.0D0
5883       do i=itau_start,itau_end
5884         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5885         esccor_ii=0.0D0
5886         isccori=isccortyp(itype(i-2))
5887         isccori1=isccortyp(itype(i-1))
5888 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5889         phii=phi(i)
5890         do intertyp=1,3 !intertyp
5891 cc Added 09 May 2012 (Adasko)
5892 cc  Intertyp means interaction type of backbone mainchain correlation:
5893 c   1 = SC...Ca...Ca...Ca
5894 c   2 = Ca...Ca...Ca...SC
5895 c   3 = SC...Ca...Ca...SCi
5896         gloci=0.0D0
5897         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5898      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5899      &      (itype(i-1).eq.ntyp1)))
5900      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5901      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5902      &     .or.(itype(i).eq.ntyp1)))
5903      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5904      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5905      &      (itype(i-3).eq.ntyp1)))) cycle
5906         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5907         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5908      & cycle
5909        do j=1,nterm_sccor(isccori,isccori1)
5910           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5911           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5912           cosphi=dcos(j*tauangle(intertyp,i))
5913           sinphi=dsin(j*tauangle(intertyp,i))
5914           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5915           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5916         enddo
5917 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5918         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5919         if (lprn)
5920      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5921      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5922      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5923      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5924         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5925        enddo !intertyp
5926       enddo
5927
5928       return
5929       end
5930 c----------------------------------------------------------------------------
5931       subroutine multibody(ecorr)
5932 C This subroutine calculates multi-body contributions to energy following
5933 C the idea of Skolnick et al. If side chains I and J make a contact and
5934 C at the same time side chains I+1 and J+1 make a contact, an extra
5935 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5936       implicit real*8 (a-h,o-z)
5937       include 'DIMENSIONS'
5938       include 'COMMON.IOUNITS'
5939       include 'COMMON.DERIV'
5940       include 'COMMON.INTERACT'
5941       include 'COMMON.CONTACTS'
5942       double precision gx(3),gx1(3)
5943       logical lprn
5944
5945 C Set lprn=.true. for debugging
5946       lprn=.false.
5947
5948       if (lprn) then
5949         write (iout,'(a)') 'Contact function values:'
5950         do i=nnt,nct-2
5951           write (iout,'(i2,20(1x,i2,f10.5))')
5952      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5953         enddo
5954       endif
5955       ecorr=0.0D0
5956       do i=nnt,nct
5957         do j=1,3
5958           gradcorr(j,i)=0.0D0
5959           gradxorr(j,i)=0.0D0
5960         enddo
5961       enddo
5962       do i=nnt,nct-2
5963
5964         DO ISHIFT = 3,4
5965
5966         i1=i+ishift
5967         num_conti=num_cont(i)
5968         num_conti1=num_cont(i1)
5969         do jj=1,num_conti
5970           j=jcont(jj,i)
5971           do kk=1,num_conti1
5972             j1=jcont(kk,i1)
5973             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5974 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5975 cd   &                   ' ishift=',ishift
5976 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5977 C The system gains extra energy.
5978               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5979             endif   ! j1==j+-ishift
5980           enddo     ! kk
5981         enddo       ! jj
5982
5983         ENDDO ! ISHIFT
5984
5985       enddo         ! i
5986       return
5987       end
5988 c------------------------------------------------------------------------------
5989       double precision function esccorr(i,j,k,l,jj,kk)
5990       implicit real*8 (a-h,o-z)
5991       include 'DIMENSIONS'
5992       include 'COMMON.IOUNITS'
5993       include 'COMMON.DERIV'
5994       include 'COMMON.INTERACT'
5995       include 'COMMON.CONTACTS'
5996       double precision gx(3),gx1(3)
5997       logical lprn
5998       lprn=.false.
5999       eij=facont(jj,i)
6000       ekl=facont(kk,k)
6001 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6002 C Calculate the multi-body contribution to energy.
6003 C Calculate multi-body contributions to the gradient.
6004 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6005 cd   & k,l,(gacont(m,kk,k),m=1,3)
6006       do m=1,3
6007         gx(m) =ekl*gacont(m,jj,i)
6008         gx1(m)=eij*gacont(m,kk,k)
6009         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6010         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6011         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6012         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6013       enddo
6014       do m=i,j-1
6015         do ll=1,3
6016           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6017         enddo
6018       enddo
6019       do m=k,l-1
6020         do ll=1,3
6021           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6022         enddo
6023       enddo
6024       esccorr=-eij*ekl
6025       return
6026       end
6027 c------------------------------------------------------------------------------
6028       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6029 C This subroutine calculates multi-body contributions to hydrogen-bonding
6030       implicit real*8 (a-h,o-z)
6031       include 'DIMENSIONS'
6032       include 'COMMON.IOUNITS'
6033 #ifdef MPI
6034       include "mpif.h"
6035       parameter (max_cont=maxconts)
6036       parameter (max_dim=26)
6037       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6038       double precision zapas(max_dim,maxconts,max_fg_procs),
6039      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6040       common /przechowalnia/ zapas
6041       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6042      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6043 #endif
6044       include 'COMMON.SETUP'
6045       include 'COMMON.FFIELD'
6046       include 'COMMON.DERIV'
6047       include 'COMMON.INTERACT'
6048       include 'COMMON.CONTACTS'
6049       include 'COMMON.CONTROL'
6050       include 'COMMON.LOCAL'
6051       double precision gx(3),gx1(3),time00
6052       logical lprn,ldone
6053
6054 C Set lprn=.true. for debugging
6055       lprn=.false.
6056 #ifdef MPI
6057       n_corr=0
6058       n_corr1=0
6059       if (nfgtasks.le.1) goto 30
6060       if (lprn) then
6061         write (iout,'(a)') 'Contact function values before RECEIVE:'
6062         do i=nnt,nct-2
6063           write (iout,'(2i3,50(1x,i2,f5.2))')
6064      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6065      &    j=1,num_cont_hb(i))
6066         enddo
6067       endif
6068       call flush(iout)
6069       do i=1,ntask_cont_from
6070         ncont_recv(i)=0
6071       enddo
6072       do i=1,ntask_cont_to
6073         ncont_sent(i)=0
6074       enddo
6075 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6076 c     & ntask_cont_to
6077 C Make the list of contacts to send to send to other procesors
6078 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6079 c      call flush(iout)
6080       do i=iturn3_start,iturn3_end
6081 c        write (iout,*) "make contact list turn3",i," num_cont",
6082 c     &    num_cont_hb(i)
6083         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6084       enddo
6085       do i=iturn4_start,iturn4_end
6086 c        write (iout,*) "make contact list turn4",i," num_cont",
6087 c     &   num_cont_hb(i)
6088         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6089       enddo
6090       do ii=1,nat_sent
6091         i=iat_sent(ii)
6092 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6093 c     &    num_cont_hb(i)
6094         do j=1,num_cont_hb(i)
6095         do k=1,4
6096           jjc=jcont_hb(j,i)
6097           iproc=iint_sent_local(k,jjc,ii)
6098 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6099           if (iproc.gt.0) then
6100             ncont_sent(iproc)=ncont_sent(iproc)+1
6101             nn=ncont_sent(iproc)
6102             zapas(1,nn,iproc)=i
6103             zapas(2,nn,iproc)=jjc
6104             zapas(3,nn,iproc)=facont_hb(j,i)
6105             zapas(4,nn,iproc)=ees0p(j,i)
6106             zapas(5,nn,iproc)=ees0m(j,i)
6107             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6108             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6109             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6110             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6111             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6112             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6113             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6114             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6115             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6116             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6117             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6118             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6119             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6120             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6121             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6122             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6123             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6124             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6125             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6126             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6127             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6128           endif
6129         enddo
6130         enddo
6131       enddo
6132       if (lprn) then
6133       write (iout,*)
6134      &  "Numbers of contacts to be sent to other processors",
6135      &  (ncont_sent(i),i=1,ntask_cont_to)
6136       write (iout,*) "Contacts sent"
6137       do ii=1,ntask_cont_to
6138         nn=ncont_sent(ii)
6139         iproc=itask_cont_to(ii)
6140         write (iout,*) nn," contacts to processor",iproc,
6141      &   " of CONT_TO_COMM group"
6142         do i=1,nn
6143           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6144         enddo
6145       enddo
6146       call flush(iout)
6147       endif
6148       CorrelType=477
6149       CorrelID=fg_rank+1
6150       CorrelType1=478
6151       CorrelID1=nfgtasks+fg_rank+1
6152       ireq=0
6153 C Receive the numbers of needed contacts from other processors
6154       do ii=1,ntask_cont_from
6155         iproc=itask_cont_from(ii)
6156         ireq=ireq+1
6157         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6158      &    FG_COMM,req(ireq),IERR)
6159       enddo
6160 c      write (iout,*) "IRECV ended"
6161 c      call flush(iout)
6162 C Send the number of contacts needed by other processors
6163       do ii=1,ntask_cont_to
6164         iproc=itask_cont_to(ii)
6165         ireq=ireq+1
6166         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6167      &    FG_COMM,req(ireq),IERR)
6168       enddo
6169 c      write (iout,*) "ISEND ended"
6170 c      write (iout,*) "number of requests (nn)",ireq
6171       call flush(iout)
6172       if (ireq.gt.0)
6173      &  call MPI_Waitall(ireq,req,status_array,ierr)
6174 c      write (iout,*)
6175 c     &  "Numbers of contacts to be received from other processors",
6176 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6177 c      call flush(iout)
6178 C Receive contacts
6179       ireq=0
6180       do ii=1,ntask_cont_from
6181         iproc=itask_cont_from(ii)
6182         nn=ncont_recv(ii)
6183 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6184 c     &   " of CONT_TO_COMM group"
6185         call flush(iout)
6186         if (nn.gt.0) then
6187           ireq=ireq+1
6188           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6189      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6190 c          write (iout,*) "ireq,req",ireq,req(ireq)
6191         endif
6192       enddo
6193 C Send the contacts to processors that need them
6194       do ii=1,ntask_cont_to
6195         iproc=itask_cont_to(ii)
6196         nn=ncont_sent(ii)
6197 c        write (iout,*) nn," contacts to processor",iproc,
6198 c     &   " of CONT_TO_COMM group"
6199         if (nn.gt.0) then
6200           ireq=ireq+1
6201           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6202      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6203 c          write (iout,*) "ireq,req",ireq,req(ireq)
6204 c          do i=1,nn
6205 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6206 c          enddo
6207         endif
6208       enddo
6209 c      write (iout,*) "number of requests (contacts)",ireq
6210 c      write (iout,*) "req",(req(i),i=1,4)
6211 c      call flush(iout)
6212       if (ireq.gt.0)
6213      & call MPI_Waitall(ireq,req,status_array,ierr)
6214       do iii=1,ntask_cont_from
6215         iproc=itask_cont_from(iii)
6216         nn=ncont_recv(iii)
6217         if (lprn) then
6218         write (iout,*) "Received",nn," contacts from processor",iproc,
6219      &   " of CONT_FROM_COMM group"
6220         call flush(iout)
6221         do i=1,nn
6222           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6223         enddo
6224         call flush(iout)
6225         endif
6226         do i=1,nn
6227           ii=zapas_recv(1,i,iii)
6228 c Flag the received contacts to prevent double-counting
6229           jj=-zapas_recv(2,i,iii)
6230 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6231 c          call flush(iout)
6232           nnn=num_cont_hb(ii)+1
6233           num_cont_hb(ii)=nnn
6234           jcont_hb(nnn,ii)=jj
6235           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6236           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6237           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6238           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6239           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6240           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6241           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6242           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6243           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6244           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6245           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6246           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6247           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6248           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6249           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6250           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6251           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6252           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6253           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6254           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6255           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6256           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6257           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6258           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6259         enddo
6260       enddo
6261       call flush(iout)
6262       if (lprn) then
6263         write (iout,'(a)') 'Contact function values after receive:'
6264         do i=nnt,nct-2
6265           write (iout,'(2i3,50(1x,i3,f5.2))')
6266      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6267      &    j=1,num_cont_hb(i))
6268         enddo
6269         call flush(iout)
6270       endif
6271    30 continue
6272 #endif
6273       if (lprn) then
6274         write (iout,'(a)') 'Contact function values:'
6275         do i=nnt,nct-2
6276           write (iout,'(2i3,50(1x,i3,f5.2))')
6277      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6278      &    j=1,num_cont_hb(i))
6279         enddo
6280       endif
6281       ecorr=0.0D0
6282 C Remove the loop below after debugging !!!
6283       do i=nnt,nct
6284         do j=1,3
6285           gradcorr(j,i)=0.0D0
6286           gradxorr(j,i)=0.0D0
6287         enddo
6288       enddo
6289 C Calculate the local-electrostatic correlation terms
6290       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6291         i1=i+1
6292         num_conti=num_cont_hb(i)
6293         num_conti1=num_cont_hb(i+1)
6294         do jj=1,num_conti
6295           j=jcont_hb(jj,i)
6296           jp=iabs(j)
6297           do kk=1,num_conti1
6298             j1=jcont_hb(kk,i1)
6299             jp1=iabs(j1)
6300 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6301 c     &         ' jj=',jj,' kk=',kk
6302             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6303      &          .or. j.lt.0 .and. j1.gt.0) .and.
6304      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6305 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6306 C The system gains extra energy.
6307               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6308               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6309      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6310               n_corr=n_corr+1
6311             else if (j1.eq.j) then
6312 C Contacts I-J and I-(J+1) occur simultaneously.
6313 C The system loses extra energy.
6314 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6315             endif
6316           enddo ! kk
6317           do kk=1,num_conti
6318             j1=jcont_hb(kk,i)
6319 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6320 c    &         ' jj=',jj,' kk=',kk
6321             if (j1.eq.j+1) then
6322 C Contacts I-J and (I+1)-J occur simultaneously.
6323 C The system loses extra energy.
6324 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6325             endif ! j1==j+1
6326           enddo ! kk
6327         enddo ! jj
6328       enddo ! i
6329       return
6330       end
6331 c------------------------------------------------------------------------------
6332       subroutine add_hb_contact(ii,jj,itask)
6333       implicit real*8 (a-h,o-z)
6334       include "DIMENSIONS"
6335       include "COMMON.IOUNITS"
6336       integer max_cont
6337       integer max_dim
6338       parameter (max_cont=maxconts)
6339       parameter (max_dim=26)
6340       include "COMMON.CONTACTS"
6341       double precision zapas(max_dim,maxconts,max_fg_procs),
6342      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6343       common /przechowalnia/ zapas
6344       integer i,j,ii,jj,iproc,itask(4),nn
6345 c      write (iout,*) "itask",itask
6346       do i=1,2
6347         iproc=itask(i)
6348         if (iproc.gt.0) then
6349           do j=1,num_cont_hb(ii)
6350             jjc=jcont_hb(j,ii)
6351 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6352             if (jjc.eq.jj) then
6353               ncont_sent(iproc)=ncont_sent(iproc)+1
6354               nn=ncont_sent(iproc)
6355               zapas(1,nn,iproc)=ii
6356               zapas(2,nn,iproc)=jjc
6357               zapas(3,nn,iproc)=facont_hb(j,ii)
6358               zapas(4,nn,iproc)=ees0p(j,ii)
6359               zapas(5,nn,iproc)=ees0m(j,ii)
6360               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6361               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6362               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6363               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6364               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6365               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6366               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6367               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6368               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6369               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6370               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6371               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6372               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6373               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6374               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6375               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6376               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6377               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6378               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6379               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6380               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6381               exit
6382             endif
6383           enddo
6384         endif
6385       enddo
6386       return
6387       end
6388 c------------------------------------------------------------------------------
6389       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6390      &  n_corr1)
6391 C This subroutine calculates multi-body contributions to hydrogen-bonding
6392       implicit real*8 (a-h,o-z)
6393       include 'DIMENSIONS'
6394       include 'COMMON.IOUNITS'
6395 #ifdef MPI
6396       include "mpif.h"
6397       parameter (max_cont=maxconts)
6398       parameter (max_dim=70)
6399       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6400       double precision zapas(max_dim,maxconts,max_fg_procs),
6401      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6402       common /przechowalnia/ zapas
6403       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6404      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6405 #endif
6406       include 'COMMON.SETUP'
6407       include 'COMMON.FFIELD'
6408       include 'COMMON.DERIV'
6409       include 'COMMON.LOCAL'
6410       include 'COMMON.INTERACT'
6411       include 'COMMON.CONTACTS'
6412       include 'COMMON.CHAIN'
6413       include 'COMMON.CONTROL'
6414       double precision gx(3),gx1(3)
6415       integer num_cont_hb_old(maxres)
6416       logical lprn,ldone
6417       double precision eello4,eello5,eelo6,eello_turn6
6418       external eello4,eello5,eello6,eello_turn6
6419 C Set lprn=.true. for debugging
6420       lprn=.false.
6421       eturn6=0.0d0
6422 #ifdef MPI
6423       do i=1,nres
6424         num_cont_hb_old(i)=num_cont_hb(i)
6425       enddo
6426       n_corr=0
6427       n_corr1=0
6428       if (nfgtasks.le.1) goto 30
6429       if (lprn) then
6430         write (iout,'(a)') 'Contact function values before RECEIVE:'
6431         do i=nnt,nct-2
6432           write (iout,'(2i3,50(1x,i2,f5.2))')
6433      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6434      &    j=1,num_cont_hb(i))
6435         enddo
6436       endif
6437       call flush(iout)
6438       do i=1,ntask_cont_from
6439         ncont_recv(i)=0
6440       enddo
6441       do i=1,ntask_cont_to
6442         ncont_sent(i)=0
6443       enddo
6444 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6445 c     & ntask_cont_to
6446 C Make the list of contacts to send to send to other procesors
6447       do i=iturn3_start,iturn3_end
6448 c        write (iout,*) "make contact list turn3",i," num_cont",
6449 c     &    num_cont_hb(i)
6450         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6451       enddo
6452       do i=iturn4_start,iturn4_end
6453 c        write (iout,*) "make contact list turn4",i," num_cont",
6454 c     &   num_cont_hb(i)
6455         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6456       enddo
6457       do ii=1,nat_sent
6458         i=iat_sent(ii)
6459 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6460 c     &    num_cont_hb(i)
6461         do j=1,num_cont_hb(i)
6462         do k=1,4
6463           jjc=jcont_hb(j,i)
6464           iproc=iint_sent_local(k,jjc,ii)
6465 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6466           if (iproc.ne.0) then
6467             ncont_sent(iproc)=ncont_sent(iproc)+1
6468             nn=ncont_sent(iproc)
6469             zapas(1,nn,iproc)=i
6470             zapas(2,nn,iproc)=jjc
6471             zapas(3,nn,iproc)=d_cont(j,i)
6472             ind=3
6473             do kk=1,3
6474               ind=ind+1
6475               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6476             enddo
6477             do kk=1,2
6478               do ll=1,2
6479                 ind=ind+1
6480                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6481               enddo
6482             enddo
6483             do jj=1,5
6484               do kk=1,3
6485                 do ll=1,2
6486                   do mm=1,2
6487                     ind=ind+1
6488                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6489                   enddo
6490                 enddo
6491               enddo
6492             enddo
6493           endif
6494         enddo
6495         enddo
6496       enddo
6497       if (lprn) then
6498       write (iout,*)
6499      &  "Numbers of contacts to be sent to other processors",
6500      &  (ncont_sent(i),i=1,ntask_cont_to)
6501       write (iout,*) "Contacts sent"
6502       do ii=1,ntask_cont_to
6503         nn=ncont_sent(ii)
6504         iproc=itask_cont_to(ii)
6505         write (iout,*) nn," contacts to processor",iproc,
6506      &   " of CONT_TO_COMM group"
6507         do i=1,nn
6508           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6509         enddo
6510       enddo
6511       call flush(iout)
6512       endif
6513       CorrelType=477
6514       CorrelID=fg_rank+1
6515       CorrelType1=478
6516       CorrelID1=nfgtasks+fg_rank+1
6517       ireq=0
6518 C Receive the numbers of needed contacts from other processors
6519       do ii=1,ntask_cont_from
6520         iproc=itask_cont_from(ii)
6521         ireq=ireq+1
6522         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6523      &    FG_COMM,req(ireq),IERR)
6524       enddo
6525 c      write (iout,*) "IRECV ended"
6526 c      call flush(iout)
6527 C Send the number of contacts needed by other processors
6528       do ii=1,ntask_cont_to
6529         iproc=itask_cont_to(ii)
6530         ireq=ireq+1
6531         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6532      &    FG_COMM,req(ireq),IERR)
6533       enddo
6534 c      write (iout,*) "ISEND ended"
6535 c      write (iout,*) "number of requests (nn)",ireq
6536       call flush(iout)
6537       if (ireq.gt.0)
6538      &  call MPI_Waitall(ireq,req,status_array,ierr)
6539 c      write (iout,*)
6540 c     &  "Numbers of contacts to be received from other processors",
6541 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6542 c      call flush(iout)
6543 C Receive contacts
6544       ireq=0
6545       do ii=1,ntask_cont_from
6546         iproc=itask_cont_from(ii)
6547         nn=ncont_recv(ii)
6548 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6549 c     &   " of CONT_TO_COMM group"
6550         call flush(iout)
6551         if (nn.gt.0) then
6552           ireq=ireq+1
6553           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6554      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6555 c          write (iout,*) "ireq,req",ireq,req(ireq)
6556         endif
6557       enddo
6558 C Send the contacts to processors that need them
6559       do ii=1,ntask_cont_to
6560         iproc=itask_cont_to(ii)
6561         nn=ncont_sent(ii)
6562 c        write (iout,*) nn," contacts to processor",iproc,
6563 c     &   " of CONT_TO_COMM group"
6564         if (nn.gt.0) then
6565           ireq=ireq+1
6566           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6567      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6568 c          write (iout,*) "ireq,req",ireq,req(ireq)
6569 c          do i=1,nn
6570 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6571 c          enddo
6572         endif
6573       enddo
6574 c      write (iout,*) "number of requests (contacts)",ireq
6575 c      write (iout,*) "req",(req(i),i=1,4)
6576 c      call flush(iout)
6577       if (ireq.gt.0)
6578      & call MPI_Waitall(ireq,req,status_array,ierr)
6579       do iii=1,ntask_cont_from
6580         iproc=itask_cont_from(iii)
6581         nn=ncont_recv(iii)
6582         if (lprn) then
6583         write (iout,*) "Received",nn," contacts from processor",iproc,
6584      &   " of CONT_FROM_COMM group"
6585         call flush(iout)
6586         do i=1,nn
6587           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6588         enddo
6589         call flush(iout)
6590         endif
6591         do i=1,nn
6592           ii=zapas_recv(1,i,iii)
6593 c Flag the received contacts to prevent double-counting
6594           jj=-zapas_recv(2,i,iii)
6595 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6596 c          call flush(iout)
6597           nnn=num_cont_hb(ii)+1
6598           num_cont_hb(ii)=nnn
6599           jcont_hb(nnn,ii)=jj
6600           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6601           ind=3
6602           do kk=1,3
6603             ind=ind+1
6604             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6605           enddo
6606           do kk=1,2
6607             do ll=1,2
6608               ind=ind+1
6609               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6610             enddo
6611           enddo
6612           do jj=1,5
6613             do kk=1,3
6614               do ll=1,2
6615                 do mm=1,2
6616                   ind=ind+1
6617                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6618                 enddo
6619               enddo
6620             enddo
6621           enddo
6622         enddo
6623       enddo
6624       call flush(iout)
6625       if (lprn) then
6626         write (iout,'(a)') 'Contact function values after receive:'
6627         do i=nnt,nct-2
6628           write (iout,'(2i3,50(1x,i3,5f6.3))')
6629      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6630      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6631         enddo
6632         call flush(iout)
6633       endif
6634    30 continue
6635 #endif
6636       if (lprn) then
6637         write (iout,'(a)') 'Contact function values:'
6638         do i=nnt,nct-2
6639           write (iout,'(2i3,50(1x,i2,5f6.3))')
6640      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6641      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6642         enddo
6643       endif
6644       ecorr=0.0D0
6645       ecorr5=0.0d0
6646       ecorr6=0.0d0
6647 C Remove the loop below after debugging !!!
6648       do i=nnt,nct
6649         do j=1,3
6650           gradcorr(j,i)=0.0D0
6651           gradxorr(j,i)=0.0D0
6652         enddo
6653       enddo
6654 C Calculate the dipole-dipole interaction energies
6655       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6656       do i=iatel_s,iatel_e+1
6657         num_conti=num_cont_hb(i)
6658         do jj=1,num_conti
6659           j=jcont_hb(jj,i)
6660 #ifdef MOMENT
6661           call dipole(i,j,jj)
6662 #endif
6663         enddo
6664       enddo
6665       endif
6666 C Calculate the local-electrostatic correlation terms
6667 c                write (iout,*) "gradcorr5 in eello5 before loop"
6668 c                do iii=1,nres
6669 c                  write (iout,'(i5,3f10.5)')
6670 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6671 c                enddo
6672       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6673 c        write (iout,*) "corr loop i",i
6674         i1=i+1
6675         num_conti=num_cont_hb(i)
6676         num_conti1=num_cont_hb(i+1)
6677         do jj=1,num_conti
6678           j=jcont_hb(jj,i)
6679           jp=iabs(j)
6680           do kk=1,num_conti1
6681             j1=jcont_hb(kk,i1)
6682             jp1=iabs(j1)
6683 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6684 c     &         ' jj=',jj,' kk=',kk
6685 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6686             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6687      &          .or. j.lt.0 .and. j1.gt.0) .and.
6688      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6689 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6690 C The system gains extra energy.
6691               n_corr=n_corr+1
6692               sqd1=dsqrt(d_cont(jj,i))
6693               sqd2=dsqrt(d_cont(kk,i1))
6694               sred_geom = sqd1*sqd2
6695               IF (sred_geom.lt.cutoff_corr) THEN
6696                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6697      &            ekont,fprimcont)
6698 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6699 cd     &         ' jj=',jj,' kk=',kk
6700                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6701                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6702                 do l=1,3
6703                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6704                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6705                 enddo
6706                 n_corr1=n_corr1+1
6707 cd               write (iout,*) 'sred_geom=',sred_geom,
6708 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6709 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6710 cd               write (iout,*) "g_contij",g_contij
6711 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6712 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6713                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6714                 if (wcorr4.gt.0.0d0)
6715      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6716                   if (energy_dec.and.wcorr4.gt.0.0d0)
6717      1                 write (iout,'(a6,4i5,0pf7.3)')
6718      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6719 c                write (iout,*) "gradcorr5 before eello5"
6720 c                do iii=1,nres
6721 c                  write (iout,'(i5,3f10.5)')
6722 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6723 c                enddo
6724                 if (wcorr5.gt.0.0d0)
6725      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6726 c                write (iout,*) "gradcorr5 after eello5"
6727 c                do iii=1,nres
6728 c                  write (iout,'(i5,3f10.5)')
6729 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6730 c                enddo
6731                   if (energy_dec.and.wcorr5.gt.0.0d0)
6732      1                 write (iout,'(a6,4i5,0pf7.3)')
6733      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6734 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6735 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6736                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6737      &               .or. wturn6.eq.0.0d0))then
6738 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6739                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6740                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6741      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6742 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6743 cd     &            'ecorr6=',ecorr6
6744 cd                write (iout,'(4e15.5)') sred_geom,
6745 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6746 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6747 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6748                 else if (wturn6.gt.0.0d0
6749      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6750 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6751                   eturn6=eturn6+eello_turn6(i,jj,kk)
6752                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6753      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6754 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6755                 endif
6756               ENDIF
6757 1111          continue
6758             endif
6759           enddo ! kk
6760         enddo ! jj
6761       enddo ! i
6762       do i=1,nres
6763         num_cont_hb(i)=num_cont_hb_old(i)
6764       enddo
6765 c                write (iout,*) "gradcorr5 in eello5"
6766 c                do iii=1,nres
6767 c                  write (iout,'(i5,3f10.5)')
6768 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6769 c                enddo
6770       return
6771       end
6772 c------------------------------------------------------------------------------
6773       subroutine add_hb_contact_eello(ii,jj,itask)
6774       implicit real*8 (a-h,o-z)
6775       include "DIMENSIONS"
6776       include "COMMON.IOUNITS"
6777       integer max_cont
6778       integer max_dim
6779       parameter (max_cont=maxconts)
6780       parameter (max_dim=70)
6781       include "COMMON.CONTACTS"
6782       double precision zapas(max_dim,maxconts,max_fg_procs),
6783      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6784       common /przechowalnia/ zapas
6785       integer i,j,ii,jj,iproc,itask(4),nn
6786 c      write (iout,*) "itask",itask
6787       do i=1,2
6788         iproc=itask(i)
6789         if (iproc.gt.0) then
6790           do j=1,num_cont_hb(ii)
6791             jjc=jcont_hb(j,ii)
6792 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6793             if (jjc.eq.jj) then
6794               ncont_sent(iproc)=ncont_sent(iproc)+1
6795               nn=ncont_sent(iproc)
6796               zapas(1,nn,iproc)=ii
6797               zapas(2,nn,iproc)=jjc
6798               zapas(3,nn,iproc)=d_cont(j,ii)
6799               ind=3
6800               do kk=1,3
6801                 ind=ind+1
6802                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6803               enddo
6804               do kk=1,2
6805                 do ll=1,2
6806                   ind=ind+1
6807                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6808                 enddo
6809               enddo
6810               do jj=1,5
6811                 do kk=1,3
6812                   do ll=1,2
6813                     do mm=1,2
6814                       ind=ind+1
6815                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6816                     enddo
6817                   enddo
6818                 enddo
6819               enddo
6820               exit
6821             endif
6822           enddo
6823         endif
6824       enddo
6825       return
6826       end
6827 c------------------------------------------------------------------------------
6828       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6829       implicit real*8 (a-h,o-z)
6830       include 'DIMENSIONS'
6831       include 'COMMON.IOUNITS'
6832       include 'COMMON.DERIV'
6833       include 'COMMON.INTERACT'
6834       include 'COMMON.CONTACTS'
6835       double precision gx(3),gx1(3)
6836       logical lprn
6837       lprn=.false.
6838       eij=facont_hb(jj,i)
6839       ekl=facont_hb(kk,k)
6840       ees0pij=ees0p(jj,i)
6841       ees0pkl=ees0p(kk,k)
6842       ees0mij=ees0m(jj,i)
6843       ees0mkl=ees0m(kk,k)
6844       ekont=eij*ekl
6845       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6846 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6847 C Following 4 lines for diagnostics.
6848 cd    ees0pkl=0.0D0
6849 cd    ees0pij=1.0D0
6850 cd    ees0mkl=0.0D0
6851 cd    ees0mij=1.0D0
6852 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6853 c     & 'Contacts ',i,j,
6854 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6855 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6856 c     & 'gradcorr_long'
6857 C Calculate the multi-body contribution to energy.
6858 c      ecorr=ecorr+ekont*ees
6859 C Calculate multi-body contributions to the gradient.
6860       coeffpees0pij=coeffp*ees0pij
6861       coeffmees0mij=coeffm*ees0mij
6862       coeffpees0pkl=coeffp*ees0pkl
6863       coeffmees0mkl=coeffm*ees0mkl
6864       do ll=1,3
6865 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6866         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6867      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6868      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6869         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6870      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6871      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6872 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6873         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6874      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6875      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6876         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6877      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6878      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6879         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6880      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6881      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6882         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6883         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6884         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6885      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6886      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6887         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6888         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6889 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6890       enddo
6891 c      write (iout,*)
6892 cgrad      do m=i+1,j-1
6893 cgrad        do ll=1,3
6894 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6895 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6896 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6897 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6898 cgrad        enddo
6899 cgrad      enddo
6900 cgrad      do m=k+1,l-1
6901 cgrad        do ll=1,3
6902 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6903 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6904 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6905 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6906 cgrad        enddo
6907 cgrad      enddo
6908 c      write (iout,*) "ehbcorr",ekont*ees
6909       ehbcorr=ekont*ees
6910       return
6911       end
6912 #ifdef MOMENT
6913 C---------------------------------------------------------------------------
6914       subroutine dipole(i,j,jj)
6915       implicit real*8 (a-h,o-z)
6916       include 'DIMENSIONS'
6917       include 'COMMON.IOUNITS'
6918       include 'COMMON.CHAIN'
6919       include 'COMMON.FFIELD'
6920       include 'COMMON.DERIV'
6921       include 'COMMON.INTERACT'
6922       include 'COMMON.CONTACTS'
6923       include 'COMMON.TORSION'
6924       include 'COMMON.VAR'
6925       include 'COMMON.GEO'
6926       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6927      &  auxmat(2,2)
6928       iti1 = itortyp(itype(i+1))
6929       if (j.lt.nres-1) then
6930         itj1 = itortyp(itype(j+1))
6931       else
6932         itj1=ntortyp+1
6933       endif
6934       do iii=1,2
6935         dipi(iii,1)=Ub2(iii,i)
6936         dipderi(iii)=Ub2der(iii,i)
6937         dipi(iii,2)=b1(iii,iti1)
6938         dipj(iii,1)=Ub2(iii,j)
6939         dipderj(iii)=Ub2der(iii,j)
6940         dipj(iii,2)=b1(iii,itj1)
6941       enddo
6942       kkk=0
6943       do iii=1,2
6944         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6945         do jjj=1,2
6946           kkk=kkk+1
6947           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6948         enddo
6949       enddo
6950       do kkk=1,5
6951         do lll=1,3
6952           mmm=0
6953           do iii=1,2
6954             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6955      &        auxvec(1))
6956             do jjj=1,2
6957               mmm=mmm+1
6958               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6959             enddo
6960           enddo
6961         enddo
6962       enddo
6963       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6964       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6965       do iii=1,2
6966         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6967       enddo
6968       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6969       do iii=1,2
6970         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6971       enddo
6972       return
6973       end
6974 #endif
6975 C---------------------------------------------------------------------------
6976       subroutine calc_eello(i,j,k,l,jj,kk)
6977 C
6978 C This subroutine computes matrices and vectors needed to calculate
6979 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6980 C
6981       implicit real*8 (a-h,o-z)
6982       include 'DIMENSIONS'
6983       include 'COMMON.IOUNITS'
6984       include 'COMMON.CHAIN'
6985       include 'COMMON.DERIV'
6986       include 'COMMON.INTERACT'
6987       include 'COMMON.CONTACTS'
6988       include 'COMMON.TORSION'
6989       include 'COMMON.VAR'
6990       include 'COMMON.GEO'
6991       include 'COMMON.FFIELD'
6992       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6993      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6994       logical lprn
6995       common /kutas/ lprn
6996 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6997 cd     & ' jj=',jj,' kk=',kk
6998 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6999 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7000 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7001       do iii=1,2
7002         do jjj=1,2
7003           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7004           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7005         enddo
7006       enddo
7007       call transpose2(aa1(1,1),aa1t(1,1))
7008       call transpose2(aa2(1,1),aa2t(1,1))
7009       do kkk=1,5
7010         do lll=1,3
7011           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7012      &      aa1tder(1,1,lll,kkk))
7013           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7014      &      aa2tder(1,1,lll,kkk))
7015         enddo
7016       enddo
7017       if (l.eq.j+1) then
7018 C parallel orientation of the two CA-CA-CA frames.
7019         if (i.gt.1) then
7020           iti=itortyp(itype(i))
7021         else
7022           iti=ntortyp+1
7023         endif
7024         itk1=itortyp(itype(k+1))
7025         itj=itortyp(itype(j))
7026         if (l.lt.nres-1) then
7027           itl1=itortyp(itype(l+1))
7028         else
7029           itl1=ntortyp+1
7030         endif
7031 C A1 kernel(j+1) A2T
7032 cd        do iii=1,2
7033 cd          write (iout,'(3f10.5,5x,3f10.5)')
7034 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7035 cd        enddo
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.,EUg(1,1,l),EUgder(1,1,l),
7038      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7039 C Following matrices are needed only for 6-th order cumulants
7040         IF (wcorr6.gt.0.0d0) THEN
7041         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7042      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7043      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
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.,Ug2DtEUg(1,1,l),
7046      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7047      &   ADtEAderx(1,1,1,1,1,1))
7048         lprn=.false.
7049         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7050      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7051      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7052      &   ADtEA1derx(1,1,1,1,1,1))
7053         ENDIF
7054 C End 6-th order cumulants
7055 cd        lprn=.false.
7056 cd        if (lprn) then
7057 cd        write (2,*) 'In calc_eello6'
7058 cd        do iii=1,2
7059 cd          write (2,*) 'iii=',iii
7060 cd          do kkk=1,5
7061 cd            write (2,*) 'kkk=',kkk
7062 cd            do jjj=1,2
7063 cd              write (2,'(3(2f10.5),5x)')
7064 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7065 cd            enddo
7066 cd          enddo
7067 cd        enddo
7068 cd        endif
7069         call transpose2(EUgder(1,1,k),auxmat(1,1))
7070         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7071         call transpose2(EUg(1,1,k),auxmat(1,1))
7072         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7073         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7074         do iii=1,2
7075           do kkk=1,5
7076             do lll=1,3
7077               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7078      &          EAEAderx(1,1,lll,kkk,iii,1))
7079             enddo
7080           enddo
7081         enddo
7082 C A1T kernel(i+1) A2
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.,EUg(1,1,k),EUgder(1,1,k),
7085      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7086 C Following matrices are needed only for 6-th order cumulants
7087         IF (wcorr6.gt.0.0d0) THEN
7088         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7089      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7090      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7091         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7092      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7093      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7094      &   ADtEAderx(1,1,1,1,1,2))
7095         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7096      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7097      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7098      &   ADtEA1derx(1,1,1,1,1,2))
7099         ENDIF
7100 C End 6-th order cumulants
7101         call transpose2(EUgder(1,1,l),auxmat(1,1))
7102         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7103         call transpose2(EUg(1,1,l),auxmat(1,1))
7104         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7105         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7106         do iii=1,2
7107           do kkk=1,5
7108             do lll=1,3
7109               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7110      &          EAEAderx(1,1,lll,kkk,iii,2))
7111             enddo
7112           enddo
7113         enddo
7114 C AEAb1 and AEAb2
7115 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7116 C They are needed only when the fifth- or the sixth-order cumulants are
7117 C indluded.
7118         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7119         call transpose2(AEA(1,1,1),auxmat(1,1))
7120         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7121         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7122         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7123         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7124         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7125         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7126         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7127         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7128         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7129         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7130         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7131         call transpose2(AEA(1,1,2),auxmat(1,1))
7132         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7133         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7134         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7135         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7136         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7137         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7138         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7139         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7140         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7141         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7142         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7143 C Calculate the Cartesian derivatives of the vectors.
7144         do iii=1,2
7145           do kkk=1,5
7146             do lll=1,3
7147               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7148               call matvec2(auxmat(1,1),b1(1,iti),
7149      &          AEAb1derx(1,lll,kkk,iii,1,1))
7150               call matvec2(auxmat(1,1),Ub2(1,i),
7151      &          AEAb2derx(1,lll,kkk,iii,1,1))
7152               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7153      &          AEAb1derx(1,lll,kkk,iii,2,1))
7154               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7155      &          AEAb2derx(1,lll,kkk,iii,2,1))
7156               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7157               call matvec2(auxmat(1,1),b1(1,itj),
7158      &          AEAb1derx(1,lll,kkk,iii,1,2))
7159               call matvec2(auxmat(1,1),Ub2(1,j),
7160      &          AEAb2derx(1,lll,kkk,iii,1,2))
7161               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7162      &          AEAb1derx(1,lll,kkk,iii,2,2))
7163               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7164      &          AEAb2derx(1,lll,kkk,iii,2,2))
7165             enddo
7166           enddo
7167         enddo
7168         ENDIF
7169 C End vectors
7170       else
7171 C Antiparallel orientation of the two CA-CA-CA frames.
7172         if (i.gt.1) then
7173           iti=itortyp(itype(i))
7174         else
7175           iti=ntortyp+1
7176         endif
7177         itk1=itortyp(itype(k+1))
7178         itl=itortyp(itype(l))
7179         itj=itortyp(itype(j))
7180         if (j.lt.nres-1) then
7181           itj1=itortyp(itype(j+1))
7182         else
7183           itj1=ntortyp+1
7184         endif
7185 C A2 kernel(j-1)T A1T
7186         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7187      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7188      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7189 C Following matrices are needed only for 6-th order cumulants
7190         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7191      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7192         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7193      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7194      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7195         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7196      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7197      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7198      &   ADtEAderx(1,1,1,1,1,1))
7199         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7200      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7201      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7202      &   ADtEA1derx(1,1,1,1,1,1))
7203         ENDIF
7204 C End 6-th order cumulants
7205         call transpose2(EUgder(1,1,k),auxmat(1,1))
7206         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7207         call transpose2(EUg(1,1,k),auxmat(1,1))
7208         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7209         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7210         do iii=1,2
7211           do kkk=1,5
7212             do lll=1,3
7213               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7214      &          EAEAderx(1,1,lll,kkk,iii,1))
7215             enddo
7216           enddo
7217         enddo
7218 C A2T kernel(i+1)T A1
7219         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7220      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7221      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7222 C Following matrices are needed only for 6-th order cumulants
7223         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7224      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7225         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7226      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7227      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7228         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7229      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7230      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7231      &   ADtEAderx(1,1,1,1,1,2))
7232         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7233      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7234      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7235      &   ADtEA1derx(1,1,1,1,1,2))
7236         ENDIF
7237 C End 6-th order cumulants
7238         call transpose2(EUgder(1,1,j),auxmat(1,1))
7239         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7240         call transpose2(EUg(1,1,j),auxmat(1,1))
7241         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7242         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7243         do iii=1,2
7244           do kkk=1,5
7245             do lll=1,3
7246               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7247      &          EAEAderx(1,1,lll,kkk,iii,2))
7248             enddo
7249           enddo
7250         enddo
7251 C AEAb1 and AEAb2
7252 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7253 C They are needed only when the fifth- or the sixth-order cumulants are
7254 C indluded.
7255         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7256      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7257         call transpose2(AEA(1,1,1),auxmat(1,1))
7258         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7259         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7260         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7261         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7262         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7263         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7264         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7265         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7266         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7267         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7268         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7269         call transpose2(AEA(1,1,2),auxmat(1,1))
7270         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7271         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7272         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7273         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7274         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7275         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7276         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7277         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7278         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7279         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7280         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7281 C Calculate the Cartesian derivatives of the vectors.
7282         do iii=1,2
7283           do kkk=1,5
7284             do lll=1,3
7285               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7286               call matvec2(auxmat(1,1),b1(1,iti),
7287      &          AEAb1derx(1,lll,kkk,iii,1,1))
7288               call matvec2(auxmat(1,1),Ub2(1,i),
7289      &          AEAb2derx(1,lll,kkk,iii,1,1))
7290               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7291      &          AEAb1derx(1,lll,kkk,iii,2,1))
7292               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7293      &          AEAb2derx(1,lll,kkk,iii,2,1))
7294               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7295               call matvec2(auxmat(1,1),b1(1,itl),
7296      &          AEAb1derx(1,lll,kkk,iii,1,2))
7297               call matvec2(auxmat(1,1),Ub2(1,l),
7298      &          AEAb2derx(1,lll,kkk,iii,1,2))
7299               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7300      &          AEAb1derx(1,lll,kkk,iii,2,2))
7301               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7302      &          AEAb2derx(1,lll,kkk,iii,2,2))
7303             enddo
7304           enddo
7305         enddo
7306         ENDIF
7307 C End vectors
7308       endif
7309       return
7310       end
7311 C---------------------------------------------------------------------------
7312       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7313      &  KK,KKderg,AKA,AKAderg,AKAderx)
7314       implicit none
7315       integer nderg
7316       logical transp
7317       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7318      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7319      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7320       integer iii,kkk,lll
7321       integer jjj,mmm
7322       logical lprn
7323       common /kutas/ lprn
7324       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7325       do iii=1,nderg
7326         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7327      &    AKAderg(1,1,iii))
7328       enddo
7329 cd      if (lprn) write (2,*) 'In kernel'
7330       do kkk=1,5
7331 cd        if (lprn) write (2,*) 'kkk=',kkk
7332         do lll=1,3
7333           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7334      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7335 cd          if (lprn) then
7336 cd            write (2,*) 'lll=',lll
7337 cd            write (2,*) 'iii=1'
7338 cd            do jjj=1,2
7339 cd              write (2,'(3(2f10.5),5x)')
7340 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7341 cd            enddo
7342 cd          endif
7343           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7344      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7345 cd          if (lprn) then
7346 cd            write (2,*) 'lll=',lll
7347 cd            write (2,*) 'iii=2'
7348 cd            do jjj=1,2
7349 cd              write (2,'(3(2f10.5),5x)')
7350 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7351 cd            enddo
7352 cd          endif
7353         enddo
7354       enddo
7355       return
7356       end
7357 C---------------------------------------------------------------------------
7358       double precision function eello4(i,j,k,l,jj,kk)
7359       implicit real*8 (a-h,o-z)
7360       include 'DIMENSIONS'
7361       include 'COMMON.IOUNITS'
7362       include 'COMMON.CHAIN'
7363       include 'COMMON.DERIV'
7364       include 'COMMON.INTERACT'
7365       include 'COMMON.CONTACTS'
7366       include 'COMMON.TORSION'
7367       include 'COMMON.VAR'
7368       include 'COMMON.GEO'
7369       double precision pizda(2,2),ggg1(3),ggg2(3)
7370 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7371 cd        eello4=0.0d0
7372 cd        return
7373 cd      endif
7374 cd      print *,'eello4:',i,j,k,l,jj,kk
7375 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7376 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7377 cold      eij=facont_hb(jj,i)
7378 cold      ekl=facont_hb(kk,k)
7379 cold      ekont=eij*ekl
7380       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7381 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7382       gcorr_loc(k-1)=gcorr_loc(k-1)
7383      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7384       if (l.eq.j+1) then
7385         gcorr_loc(l-1)=gcorr_loc(l-1)
7386      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7387       else
7388         gcorr_loc(j-1)=gcorr_loc(j-1)
7389      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7390       endif
7391       do iii=1,2
7392         do kkk=1,5
7393           do lll=1,3
7394             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7395      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7396 cd            derx(lll,kkk,iii)=0.0d0
7397           enddo
7398         enddo
7399       enddo
7400 cd      gcorr_loc(l-1)=0.0d0
7401 cd      gcorr_loc(j-1)=0.0d0
7402 cd      gcorr_loc(k-1)=0.0d0
7403 cd      eel4=1.0d0
7404 cd      write (iout,*)'Contacts have occurred for peptide groups',
7405 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7406 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7407       if (j.lt.nres-1) then
7408         j1=j+1
7409         j2=j-1
7410       else
7411         j1=j-1
7412         j2=j-2
7413       endif
7414       if (l.lt.nres-1) then
7415         l1=l+1
7416         l2=l-1
7417       else
7418         l1=l-1
7419         l2=l-2
7420       endif
7421       do ll=1,3
7422 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7423 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7424         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7425         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7426 cgrad        ghalf=0.5d0*ggg1(ll)
7427         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7428         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7429         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7430         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7431         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7432         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7433 cgrad        ghalf=0.5d0*ggg2(ll)
7434         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7435         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7436         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7437         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7438         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7439         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7440       enddo
7441 cgrad      do m=i+1,j-1
7442 cgrad        do ll=1,3
7443 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7444 cgrad        enddo
7445 cgrad      enddo
7446 cgrad      do m=k+1,l-1
7447 cgrad        do ll=1,3
7448 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7449 cgrad        enddo
7450 cgrad      enddo
7451 cgrad      do m=i+2,j2
7452 cgrad        do ll=1,3
7453 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7454 cgrad        enddo
7455 cgrad      enddo
7456 cgrad      do m=k+2,l2
7457 cgrad        do ll=1,3
7458 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7459 cgrad        enddo
7460 cgrad      enddo
7461 cd      do iii=1,nres-3
7462 cd        write (2,*) iii,gcorr_loc(iii)
7463 cd      enddo
7464       eello4=ekont*eel4
7465 cd      write (2,*) 'ekont',ekont
7466 cd      write (iout,*) 'eello4',ekont*eel4
7467       return
7468       end
7469 C---------------------------------------------------------------------------
7470       double precision function eello5(i,j,k,l,jj,kk)
7471       implicit real*8 (a-h,o-z)
7472       include 'DIMENSIONS'
7473       include 'COMMON.IOUNITS'
7474       include 'COMMON.CHAIN'
7475       include 'COMMON.DERIV'
7476       include 'COMMON.INTERACT'
7477       include 'COMMON.CONTACTS'
7478       include 'COMMON.TORSION'
7479       include 'COMMON.VAR'
7480       include 'COMMON.GEO'
7481       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7482       double precision ggg1(3),ggg2(3)
7483 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7484 C                                                                              C
7485 C                            Parallel chains                                   C
7486 C                                                                              C
7487 C          o             o                   o             o                   C
7488 C         /l\           / \             \   / \           / \   /              C
7489 C        /   \         /   \             \ /   \         /   \ /               C
7490 C       j| o |l1       | o |              o| o |         | o |o                C
7491 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7492 C      \i/   \         /   \ /             /   \         /   \                 C
7493 C       o    k1             o                                                  C
7494 C         (I)          (II)                (III)          (IV)                 C
7495 C                                                                              C
7496 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7497 C                                                                              C
7498 C                            Antiparallel chains                               C
7499 C                                                                              C
7500 C          o             o                   o             o                   C
7501 C         /j\           / \             \   / \           / \   /              C
7502 C        /   \         /   \             \ /   \         /   \ /               C
7503 C      j1| o |l        | o |              o| o |         | o |o                C
7504 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7505 C      \i/   \         /   \ /             /   \         /   \                 C
7506 C       o     k1            o                                                  C
7507 C         (I)          (II)                (III)          (IV)                 C
7508 C                                                                              C
7509 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7510 C                                                                              C
7511 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7512 C                                                                              C
7513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7514 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7515 cd        eello5=0.0d0
7516 cd        return
7517 cd      endif
7518 cd      write (iout,*)
7519 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7520 cd     &   ' and',k,l
7521       itk=itortyp(itype(k))
7522       itl=itortyp(itype(l))
7523       itj=itortyp(itype(j))
7524       eello5_1=0.0d0
7525       eello5_2=0.0d0
7526       eello5_3=0.0d0
7527       eello5_4=0.0d0
7528 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7529 cd     &   eel5_3_num,eel5_4_num)
7530       do iii=1,2
7531         do kkk=1,5
7532           do lll=1,3
7533             derx(lll,kkk,iii)=0.0d0
7534           enddo
7535         enddo
7536       enddo
7537 cd      eij=facont_hb(jj,i)
7538 cd      ekl=facont_hb(kk,k)
7539 cd      ekont=eij*ekl
7540 cd      write (iout,*)'Contacts have occurred for peptide groups',
7541 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7542 cd      goto 1111
7543 C Contribution from the graph I.
7544 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7545 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7546       call transpose2(EUg(1,1,k),auxmat(1,1))
7547       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7548       vv(1)=pizda(1,1)-pizda(2,2)
7549       vv(2)=pizda(1,2)+pizda(2,1)
7550       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7551      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7552 C Explicit gradient in virtual-dihedral angles.
7553       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7554      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7555      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7556       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7557       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7558       vv(1)=pizda(1,1)-pizda(2,2)
7559       vv(2)=pizda(1,2)+pizda(2,1)
7560       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7561      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7562      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7563       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7564       vv(1)=pizda(1,1)-pizda(2,2)
7565       vv(2)=pizda(1,2)+pizda(2,1)
7566       if (l.eq.j+1) then
7567         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7568      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7569      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7570       else
7571         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7572      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7573      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7574       endif
7575 C Cartesian gradient
7576       do iii=1,2
7577         do kkk=1,5
7578           do lll=1,3
7579             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7580      &        pizda(1,1))
7581             vv(1)=pizda(1,1)-pizda(2,2)
7582             vv(2)=pizda(1,2)+pizda(2,1)
7583             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7584      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7585      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7586           enddo
7587         enddo
7588       enddo
7589 c      goto 1112
7590 c1111  continue
7591 C Contribution from graph II
7592       call transpose2(EE(1,1,itk),auxmat(1,1))
7593       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7594       vv(1)=pizda(1,1)+pizda(2,2)
7595       vv(2)=pizda(2,1)-pizda(1,2)
7596       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7597      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7598 C Explicit gradient in virtual-dihedral angles.
7599       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7600      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7601       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7602       vv(1)=pizda(1,1)+pizda(2,2)
7603       vv(2)=pizda(2,1)-pizda(1,2)
7604       if (l.eq.j+1) then
7605         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7606      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7607      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7608       else
7609         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7610      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7611      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7612       endif
7613 C Cartesian gradient
7614       do iii=1,2
7615         do kkk=1,5
7616           do lll=1,3
7617             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7618      &        pizda(1,1))
7619             vv(1)=pizda(1,1)+pizda(2,2)
7620             vv(2)=pizda(2,1)-pizda(1,2)
7621             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7622      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7623      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7624           enddo
7625         enddo
7626       enddo
7627 cd      goto 1112
7628 cd1111  continue
7629       if (l.eq.j+1) then
7630 cd        goto 1110
7631 C Parallel orientation
7632 C Contribution from graph III
7633         call transpose2(EUg(1,1,l),auxmat(1,1))
7634         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7635         vv(1)=pizda(1,1)-pizda(2,2)
7636         vv(2)=pizda(1,2)+pizda(2,1)
7637         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7638      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7639 C Explicit gradient in virtual-dihedral angles.
7640         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7641      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7642      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7643         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7644         vv(1)=pizda(1,1)-pizda(2,2)
7645         vv(2)=pizda(1,2)+pizda(2,1)
7646         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7647      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7648      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7649         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7650         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7651         vv(1)=pizda(1,1)-pizda(2,2)
7652         vv(2)=pizda(1,2)+pizda(2,1)
7653         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7654      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7655      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7656 C Cartesian gradient
7657         do iii=1,2
7658           do kkk=1,5
7659             do lll=1,3
7660               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7661      &          pizda(1,1))
7662               vv(1)=pizda(1,1)-pizda(2,2)
7663               vv(2)=pizda(1,2)+pizda(2,1)
7664               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7665      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7666      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7667             enddo
7668           enddo
7669         enddo
7670 cd        goto 1112
7671 C Contribution from graph IV
7672 cd1110    continue
7673         call transpose2(EE(1,1,itl),auxmat(1,1))
7674         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7675         vv(1)=pizda(1,1)+pizda(2,2)
7676         vv(2)=pizda(2,1)-pizda(1,2)
7677         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7678      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7679 C Explicit gradient in virtual-dihedral angles.
7680         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7681      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7682         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7683         vv(1)=pizda(1,1)+pizda(2,2)
7684         vv(2)=pizda(2,1)-pizda(1,2)
7685         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7686      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7687      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7688 C Cartesian gradient
7689         do iii=1,2
7690           do kkk=1,5
7691             do lll=1,3
7692               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7693      &          pizda(1,1))
7694               vv(1)=pizda(1,1)+pizda(2,2)
7695               vv(2)=pizda(2,1)-pizda(1,2)
7696               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7697      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7698      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7699             enddo
7700           enddo
7701         enddo
7702       else
7703 C Antiparallel orientation
7704 C Contribution from graph III
7705 c        goto 1110
7706         call transpose2(EUg(1,1,j),auxmat(1,1))
7707         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7708         vv(1)=pizda(1,1)-pizda(2,2)
7709         vv(2)=pizda(1,2)+pizda(2,1)
7710         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7711      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7712 C Explicit gradient in virtual-dihedral angles.
7713         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7714      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7715      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7716         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7717         vv(1)=pizda(1,1)-pizda(2,2)
7718         vv(2)=pizda(1,2)+pizda(2,1)
7719         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7720      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7721      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7722         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7723         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7724         vv(1)=pizda(1,1)-pizda(2,2)
7725         vv(2)=pizda(1,2)+pizda(2,1)
7726         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7727      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7728      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7729 C Cartesian gradient
7730         do iii=1,2
7731           do kkk=1,5
7732             do lll=1,3
7733               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7734      &          pizda(1,1))
7735               vv(1)=pizda(1,1)-pizda(2,2)
7736               vv(2)=pizda(1,2)+pizda(2,1)
7737               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7738      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7739      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7740             enddo
7741           enddo
7742         enddo
7743 cd        goto 1112
7744 C Contribution from graph IV
7745 1110    continue
7746         call transpose2(EE(1,1,itj),auxmat(1,1))
7747         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7748         vv(1)=pizda(1,1)+pizda(2,2)
7749         vv(2)=pizda(2,1)-pizda(1,2)
7750         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7751      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7752 C Explicit gradient in virtual-dihedral angles.
7753         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7754      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7755         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7756         vv(1)=pizda(1,1)+pizda(2,2)
7757         vv(2)=pizda(2,1)-pizda(1,2)
7758         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7759      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7760      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7761 C Cartesian gradient
7762         do iii=1,2
7763           do kkk=1,5
7764             do lll=1,3
7765               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7766      &          pizda(1,1))
7767               vv(1)=pizda(1,1)+pizda(2,2)
7768               vv(2)=pizda(2,1)-pizda(1,2)
7769               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7770      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7771      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7772             enddo
7773           enddo
7774         enddo
7775       endif
7776 1112  continue
7777       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7778 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7779 cd        write (2,*) 'ijkl',i,j,k,l
7780 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7781 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7782 cd      endif
7783 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7784 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7785 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7786 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7787       if (j.lt.nres-1) then
7788         j1=j+1
7789         j2=j-1
7790       else
7791         j1=j-1
7792         j2=j-2
7793       endif
7794       if (l.lt.nres-1) then
7795         l1=l+1
7796         l2=l-1
7797       else
7798         l1=l-1
7799         l2=l-2
7800       endif
7801 cd      eij=1.0d0
7802 cd      ekl=1.0d0
7803 cd      ekont=1.0d0
7804 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7805 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7806 C        summed up outside the subrouine as for the other subroutines
7807 C        handling long-range interactions. The old code is commented out
7808 C        with "cgrad" to keep track of changes.
7809       do ll=1,3
7810 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7811 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7812         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7813         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7814 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7815 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7816 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7817 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7818 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7819 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7820 c     &   gradcorr5ij,
7821 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7822 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7823 cgrad        ghalf=0.5d0*ggg1(ll)
7824 cd        ghalf=0.0d0
7825         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7826         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7827         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7828         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7829         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7830         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7831 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7832 cgrad        ghalf=0.5d0*ggg2(ll)
7833 cd        ghalf=0.0d0
7834         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7835         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7836         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7837         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7838         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7839         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7840       enddo
7841 cd      goto 1112
7842 cgrad      do m=i+1,j-1
7843 cgrad        do ll=1,3
7844 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7845 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7846 cgrad        enddo
7847 cgrad      enddo
7848 cgrad      do m=k+1,l-1
7849 cgrad        do ll=1,3
7850 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7851 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7852 cgrad        enddo
7853 cgrad      enddo
7854 c1112  continue
7855 cgrad      do m=i+2,j2
7856 cgrad        do ll=1,3
7857 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7858 cgrad        enddo
7859 cgrad      enddo
7860 cgrad      do m=k+2,l2
7861 cgrad        do ll=1,3
7862 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7863 cgrad        enddo
7864 cgrad      enddo
7865 cd      do iii=1,nres-3
7866 cd        write (2,*) iii,g_corr5_loc(iii)
7867 cd      enddo
7868       eello5=ekont*eel5
7869 cd      write (2,*) 'ekont',ekont
7870 cd      write (iout,*) 'eello5',ekont*eel5
7871       return
7872       end
7873 c--------------------------------------------------------------------------
7874       double precision function eello6(i,j,k,l,jj,kk)
7875       implicit real*8 (a-h,o-z)
7876       include 'DIMENSIONS'
7877       include 'COMMON.IOUNITS'
7878       include 'COMMON.CHAIN'
7879       include 'COMMON.DERIV'
7880       include 'COMMON.INTERACT'
7881       include 'COMMON.CONTACTS'
7882       include 'COMMON.TORSION'
7883       include 'COMMON.VAR'
7884       include 'COMMON.GEO'
7885       include 'COMMON.FFIELD'
7886       double precision ggg1(3),ggg2(3)
7887 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7888 cd        eello6=0.0d0
7889 cd        return
7890 cd      endif
7891 cd      write (iout,*)
7892 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7893 cd     &   ' and',k,l
7894       eello6_1=0.0d0
7895       eello6_2=0.0d0
7896       eello6_3=0.0d0
7897       eello6_4=0.0d0
7898       eello6_5=0.0d0
7899       eello6_6=0.0d0
7900 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7901 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7902       do iii=1,2
7903         do kkk=1,5
7904           do lll=1,3
7905             derx(lll,kkk,iii)=0.0d0
7906           enddo
7907         enddo
7908       enddo
7909 cd      eij=facont_hb(jj,i)
7910 cd      ekl=facont_hb(kk,k)
7911 cd      ekont=eij*ekl
7912 cd      eij=1.0d0
7913 cd      ekl=1.0d0
7914 cd      ekont=1.0d0
7915       if (l.eq.j+1) then
7916         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7917         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7918         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7919         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7920         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7921         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7922       else
7923         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7924         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7925         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7926         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7927         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7928           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7929         else
7930           eello6_5=0.0d0
7931         endif
7932         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7933       endif
7934 C If turn contributions are considered, they will be handled separately.
7935       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7936 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7937 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7938 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7939 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7940 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7941 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7942 cd      goto 1112
7943       if (j.lt.nres-1) then
7944         j1=j+1
7945         j2=j-1
7946       else
7947         j1=j-1
7948         j2=j-2
7949       endif
7950       if (l.lt.nres-1) then
7951         l1=l+1
7952         l2=l-1
7953       else
7954         l1=l-1
7955         l2=l-2
7956       endif
7957       do ll=1,3
7958 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7959 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7960 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7961 cgrad        ghalf=0.5d0*ggg1(ll)
7962 cd        ghalf=0.0d0
7963         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7964         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7965         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7966         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7967         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7968         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7969         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7970         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7971 cgrad        ghalf=0.5d0*ggg2(ll)
7972 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7973 cd        ghalf=0.0d0
7974         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7975         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7976         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7977         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7978         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7979         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7980       enddo
7981 cd      goto 1112
7982 cgrad      do m=i+1,j-1
7983 cgrad        do ll=1,3
7984 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7985 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7986 cgrad        enddo
7987 cgrad      enddo
7988 cgrad      do m=k+1,l-1
7989 cgrad        do ll=1,3
7990 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7991 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7992 cgrad        enddo
7993 cgrad      enddo
7994 cgrad1112  continue
7995 cgrad      do m=i+2,j2
7996 cgrad        do ll=1,3
7997 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7998 cgrad        enddo
7999 cgrad      enddo
8000 cgrad      do m=k+2,l2
8001 cgrad        do ll=1,3
8002 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8003 cgrad        enddo
8004 cgrad      enddo
8005 cd      do iii=1,nres-3
8006 cd        write (2,*) iii,g_corr6_loc(iii)
8007 cd      enddo
8008       eello6=ekont*eel6
8009 cd      write (2,*) 'ekont',ekont
8010 cd      write (iout,*) 'eello6',ekont*eel6
8011       return
8012       end
8013 c--------------------------------------------------------------------------
8014       double precision function eello6_graph1(i,j,k,l,imat,swap)
8015       implicit real*8 (a-h,o-z)
8016       include 'DIMENSIONS'
8017       include 'COMMON.IOUNITS'
8018       include 'COMMON.CHAIN'
8019       include 'COMMON.DERIV'
8020       include 'COMMON.INTERACT'
8021       include 'COMMON.CONTACTS'
8022       include 'COMMON.TORSION'
8023       include 'COMMON.VAR'
8024       include 'COMMON.GEO'
8025       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8026       logical swap
8027       logical lprn
8028       common /kutas/ lprn
8029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8030 C                                                                              C
8031 C      Parallel       Antiparallel                                             C
8032 C                                                                              C
8033 C          o             o                                                     C
8034 C         /l\           /j\                                                    C
8035 C        /   \         /   \                                                   C
8036 C       /| o |         | o |\                                                  C
8037 C     \ j|/k\|  /   \  |/k\|l /                                                C
8038 C      \ /   \ /     \ /   \ /                                                 C
8039 C       o     o       o     o                                                  C
8040 C       i             i                                                        C
8041 C                                                                              C
8042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8043       itk=itortyp(itype(k))
8044       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8045       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8046       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8047       call transpose2(EUgC(1,1,k),auxmat(1,1))
8048       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8049       vv1(1)=pizda1(1,1)-pizda1(2,2)
8050       vv1(2)=pizda1(1,2)+pizda1(2,1)
8051       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8052       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8053       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8054       s5=scalar2(vv(1),Dtobr2(1,i))
8055 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8056       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8057       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8058      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8059      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8060      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8061      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8062      & +scalar2(vv(1),Dtobr2der(1,i)))
8063       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8064       vv1(1)=pizda1(1,1)-pizda1(2,2)
8065       vv1(2)=pizda1(1,2)+pizda1(2,1)
8066       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8067       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8068       if (l.eq.j+1) then
8069         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8070      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8071      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8072      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8073      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8074       else
8075         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8076      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8077      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8078      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8079      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8080       endif
8081       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8082       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8083       vv1(1)=pizda1(1,1)-pizda1(2,2)
8084       vv1(2)=pizda1(1,2)+pizda1(2,1)
8085       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8086      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8087      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8088      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8089       do iii=1,2
8090         if (swap) then
8091           ind=3-iii
8092         else
8093           ind=iii
8094         endif
8095         do kkk=1,5
8096           do lll=1,3
8097             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8098             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8099             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8100             call transpose2(EUgC(1,1,k),auxmat(1,1))
8101             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8102      &        pizda1(1,1))
8103             vv1(1)=pizda1(1,1)-pizda1(2,2)
8104             vv1(2)=pizda1(1,2)+pizda1(2,1)
8105             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8106             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8107      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8108             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8109      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8110             s5=scalar2(vv(1),Dtobr2(1,i))
8111             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8112           enddo
8113         enddo
8114       enddo
8115       return
8116       end
8117 c----------------------------------------------------------------------------
8118       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8119       implicit real*8 (a-h,o-z)
8120       include 'DIMENSIONS'
8121       include 'COMMON.IOUNITS'
8122       include 'COMMON.CHAIN'
8123       include 'COMMON.DERIV'
8124       include 'COMMON.INTERACT'
8125       include 'COMMON.CONTACTS'
8126       include 'COMMON.TORSION'
8127       include 'COMMON.VAR'
8128       include 'COMMON.GEO'
8129       logical swap
8130       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8131      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8132       logical lprn
8133       common /kutas/ lprn
8134 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8135 C                                                                              C
8136 C      Parallel       Antiparallel                                             C
8137 C                                                                              C
8138 C          o             o                                                     C
8139 C     \   /l\           /j\   /                                                C
8140 C      \ /   \         /   \ /                                                 C
8141 C       o| o |         | o |o                                                  C
8142 C     \ j|/k\|      \  |/k\|l                                                  C
8143 C      \ /   \       \ /   \                                                   C
8144 C       o             o                                                        C
8145 C       i             i                                                        C
8146 C                                                                              C
8147 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8148 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8149 C AL 7/4/01 s1 would occur in the sixth-order moment,
8150 C           but not in a cluster cumulant
8151 #ifdef MOMENT
8152       s1=dip(1,jj,i)*dip(1,kk,k)
8153 #endif
8154       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8155       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8156       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8157       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8158       call transpose2(EUg(1,1,k),auxmat(1,1))
8159       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8160       vv(1)=pizda(1,1)-pizda(2,2)
8161       vv(2)=pizda(1,2)+pizda(2,1)
8162       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8163 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8164 #ifdef MOMENT
8165       eello6_graph2=-(s1+s2+s3+s4)
8166 #else
8167       eello6_graph2=-(s2+s3+s4)
8168 #endif
8169 c      eello6_graph2=-s3
8170 C Derivatives in gamma(i-1)
8171       if (i.gt.1) then
8172 #ifdef MOMENT
8173         s1=dipderg(1,jj,i)*dip(1,kk,k)
8174 #endif
8175         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8176         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8177         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8178         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8179 #ifdef MOMENT
8180         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8181 #else
8182         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8183 #endif
8184 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8185       endif
8186 C Derivatives in gamma(k-1)
8187 #ifdef MOMENT
8188       s1=dip(1,jj,i)*dipderg(1,kk,k)
8189 #endif
8190       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8191       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8192       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8193       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8194       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8195       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8196       vv(1)=pizda(1,1)-pizda(2,2)
8197       vv(2)=pizda(1,2)+pizda(2,1)
8198       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8199 #ifdef MOMENT
8200       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8201 #else
8202       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8203 #endif
8204 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8205 C Derivatives in gamma(j-1) or gamma(l-1)
8206       if (j.gt.1) then
8207 #ifdef MOMENT
8208         s1=dipderg(3,jj,i)*dip(1,kk,k)
8209 #endif
8210         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8211         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8212         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8213         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8214         vv(1)=pizda(1,1)-pizda(2,2)
8215         vv(2)=pizda(1,2)+pizda(2,1)
8216         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8217 #ifdef MOMENT
8218         if (swap) then
8219           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8220         else
8221           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8222         endif
8223 #endif
8224         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8225 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8226       endif
8227 C Derivatives in gamma(l-1) or gamma(j-1)
8228       if (l.gt.1) then
8229 #ifdef MOMENT
8230         s1=dip(1,jj,i)*dipderg(3,kk,k)
8231 #endif
8232         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8233         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8234         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8235         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8236         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8237         vv(1)=pizda(1,1)-pizda(2,2)
8238         vv(2)=pizda(1,2)+pizda(2,1)
8239         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8240 #ifdef MOMENT
8241         if (swap) then
8242           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8243         else
8244           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8245         endif
8246 #endif
8247         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8248 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8249       endif
8250 C Cartesian derivatives.
8251       if (lprn) then
8252         write (2,*) 'In eello6_graph2'
8253         do iii=1,2
8254           write (2,*) 'iii=',iii
8255           do kkk=1,5
8256             write (2,*) 'kkk=',kkk
8257             do jjj=1,2
8258               write (2,'(3(2f10.5),5x)')
8259      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8260             enddo
8261           enddo
8262         enddo
8263       endif
8264       do iii=1,2
8265         do kkk=1,5
8266           do lll=1,3
8267 #ifdef MOMENT
8268             if (iii.eq.1) then
8269               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8270             else
8271               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8272             endif
8273 #endif
8274             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8275      &        auxvec(1))
8276             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8277             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8278      &        auxvec(1))
8279             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8280             call transpose2(EUg(1,1,k),auxmat(1,1))
8281             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8282      &        pizda(1,1))
8283             vv(1)=pizda(1,1)-pizda(2,2)
8284             vv(2)=pizda(1,2)+pizda(2,1)
8285             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8286 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8287 #ifdef MOMENT
8288             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8289 #else
8290             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8291 #endif
8292             if (swap) then
8293               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8294             else
8295               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8296             endif
8297           enddo
8298         enddo
8299       enddo
8300       return
8301       end
8302 c----------------------------------------------------------------------------
8303       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8304       implicit real*8 (a-h,o-z)
8305       include 'DIMENSIONS'
8306       include 'COMMON.IOUNITS'
8307       include 'COMMON.CHAIN'
8308       include 'COMMON.DERIV'
8309       include 'COMMON.INTERACT'
8310       include 'COMMON.CONTACTS'
8311       include 'COMMON.TORSION'
8312       include 'COMMON.VAR'
8313       include 'COMMON.GEO'
8314       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8315       logical swap
8316 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8317 C                                                                              C
8318 C      Parallel       Antiparallel                                             C
8319 C                                                                              C
8320 C          o             o                                                     C
8321 C         /l\   /   \   /j\                                                    C
8322 C        /   \ /     \ /   \                                                   C
8323 C       /| o |o       o| o |\                                                  C
8324 C       j|/k\|  /      |/k\|l /                                                C
8325 C        /   \ /       /   \ /                                                 C
8326 C       /     o       /     o                                                  C
8327 C       i             i                                                        C
8328 C                                                                              C
8329 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8330 C
8331 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8332 C           energy moment and not to the cluster cumulant.
8333       iti=itortyp(itype(i))
8334       if (j.lt.nres-1) then
8335         itj1=itortyp(itype(j+1))
8336       else
8337         itj1=ntortyp+1
8338       endif
8339       itk=itortyp(itype(k))
8340       itk1=itortyp(itype(k+1))
8341       if (l.lt.nres-1) then
8342         itl1=itortyp(itype(l+1))
8343       else
8344         itl1=ntortyp+1
8345       endif
8346 #ifdef MOMENT
8347       s1=dip(4,jj,i)*dip(4,kk,k)
8348 #endif
8349       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8350       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8351       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8352       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8353       call transpose2(EE(1,1,itk),auxmat(1,1))
8354       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8355       vv(1)=pizda(1,1)+pizda(2,2)
8356       vv(2)=pizda(2,1)-pizda(1,2)
8357       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8358 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8359 cd     & "sum",-(s2+s3+s4)
8360 #ifdef MOMENT
8361       eello6_graph3=-(s1+s2+s3+s4)
8362 #else
8363       eello6_graph3=-(s2+s3+s4)
8364 #endif
8365 c      eello6_graph3=-s4
8366 C Derivatives in gamma(k-1)
8367       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8368       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8369       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8370       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8371 C Derivatives in gamma(l-1)
8372       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8373       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8374       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8375       vv(1)=pizda(1,1)+pizda(2,2)
8376       vv(2)=pizda(2,1)-pizda(1,2)
8377       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8378       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8379 C Cartesian derivatives.
8380       do iii=1,2
8381         do kkk=1,5
8382           do lll=1,3
8383 #ifdef MOMENT
8384             if (iii.eq.1) then
8385               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8386             else
8387               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8388             endif
8389 #endif
8390             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8391      &        auxvec(1))
8392             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8393             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8394      &        auxvec(1))
8395             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8396             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8397      &        pizda(1,1))
8398             vv(1)=pizda(1,1)+pizda(2,2)
8399             vv(2)=pizda(2,1)-pizda(1,2)
8400             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8401 #ifdef MOMENT
8402             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8403 #else
8404             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8405 #endif
8406             if (swap) then
8407               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8408             else
8409               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8410             endif
8411 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8412           enddo
8413         enddo
8414       enddo
8415       return
8416       end
8417 c----------------------------------------------------------------------------
8418       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8419       implicit real*8 (a-h,o-z)
8420       include 'DIMENSIONS'
8421       include 'COMMON.IOUNITS'
8422       include 'COMMON.CHAIN'
8423       include 'COMMON.DERIV'
8424       include 'COMMON.INTERACT'
8425       include 'COMMON.CONTACTS'
8426       include 'COMMON.TORSION'
8427       include 'COMMON.VAR'
8428       include 'COMMON.GEO'
8429       include 'COMMON.FFIELD'
8430       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8431      & auxvec1(2),auxmat1(2,2)
8432       logical swap
8433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8434 C                                                                              C
8435 C      Parallel       Antiparallel                                             C
8436 C                                                                              C
8437 C          o             o                                                     C
8438 C         /l\   /   \   /j\                                                    C
8439 C        /   \ /     \ /   \                                                   C
8440 C       /| o |o       o| o |\                                                  C
8441 C     \ j|/k\|      \  |/k\|l                                                  C
8442 C      \ /   \       \ /   \                                                   C
8443 C       o     \       o     \                                                  C
8444 C       i             i                                                        C
8445 C                                                                              C
8446 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8447 C
8448 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8449 C           energy moment and not to the cluster cumulant.
8450 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8451       iti=itortyp(itype(i))
8452       itj=itortyp(itype(j))
8453       if (j.lt.nres-1) then
8454         itj1=itortyp(itype(j+1))
8455       else
8456         itj1=ntortyp+1
8457       endif
8458       itk=itortyp(itype(k))
8459       if (k.lt.nres-1) then
8460         itk1=itortyp(itype(k+1))
8461       else
8462         itk1=ntortyp+1
8463       endif
8464       itl=itortyp(itype(l))
8465       if (l.lt.nres-1) then
8466         itl1=itortyp(itype(l+1))
8467       else
8468         itl1=ntortyp+1
8469       endif
8470 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8471 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8472 cd     & ' itl',itl,' itl1',itl1
8473 #ifdef MOMENT
8474       if (imat.eq.1) then
8475         s1=dip(3,jj,i)*dip(3,kk,k)
8476       else
8477         s1=dip(2,jj,j)*dip(2,kk,l)
8478       endif
8479 #endif
8480       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8481       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8482       if (j.eq.l+1) then
8483         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8484         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8485       else
8486         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8487         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8488       endif
8489       call transpose2(EUg(1,1,k),auxmat(1,1))
8490       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8491       vv(1)=pizda(1,1)-pizda(2,2)
8492       vv(2)=pizda(2,1)+pizda(1,2)
8493       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8494 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8495 #ifdef MOMENT
8496       eello6_graph4=-(s1+s2+s3+s4)
8497 #else
8498       eello6_graph4=-(s2+s3+s4)
8499 #endif
8500 C Derivatives in gamma(i-1)
8501       if (i.gt.1) then
8502 #ifdef MOMENT
8503         if (imat.eq.1) then
8504           s1=dipderg(2,jj,i)*dip(3,kk,k)
8505         else
8506           s1=dipderg(4,jj,j)*dip(2,kk,l)
8507         endif
8508 #endif
8509         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8510         if (j.eq.l+1) then
8511           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8512           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8513         else
8514           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8515           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8516         endif
8517         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8518         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8519 cd          write (2,*) 'turn6 derivatives'
8520 #ifdef MOMENT
8521           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8522 #else
8523           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8524 #endif
8525         else
8526 #ifdef MOMENT
8527           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8528 #else
8529           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8530 #endif
8531         endif
8532       endif
8533 C Derivatives in gamma(k-1)
8534 #ifdef MOMENT
8535       if (imat.eq.1) then
8536         s1=dip(3,jj,i)*dipderg(2,kk,k)
8537       else
8538         s1=dip(2,jj,j)*dipderg(4,kk,l)
8539       endif
8540 #endif
8541       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8542       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8543       if (j.eq.l+1) then
8544         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8545         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8546       else
8547         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8548         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8549       endif
8550       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8551       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8552       vv(1)=pizda(1,1)-pizda(2,2)
8553       vv(2)=pizda(2,1)+pizda(1,2)
8554       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8555       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8556 #ifdef MOMENT
8557         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8558 #else
8559         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8560 #endif
8561       else
8562 #ifdef MOMENT
8563         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8564 #else
8565         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8566 #endif
8567       endif
8568 C Derivatives in gamma(j-1) or gamma(l-1)
8569       if (l.eq.j+1 .and. l.gt.1) then
8570         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8571         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8572         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8573         vv(1)=pizda(1,1)-pizda(2,2)
8574         vv(2)=pizda(2,1)+pizda(1,2)
8575         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8576         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8577       else if (j.gt.1) then
8578         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8579         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8580         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8581         vv(1)=pizda(1,1)-pizda(2,2)
8582         vv(2)=pizda(2,1)+pizda(1,2)
8583         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8584         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8585           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8586         else
8587           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8588         endif
8589       endif
8590 C Cartesian derivatives.
8591       do iii=1,2
8592         do kkk=1,5
8593           do lll=1,3
8594 #ifdef MOMENT
8595             if (iii.eq.1) then
8596               if (imat.eq.1) then
8597                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8598               else
8599                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8600               endif
8601             else
8602               if (imat.eq.1) then
8603                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8604               else
8605                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8606               endif
8607             endif
8608 #endif
8609             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8610      &        auxvec(1))
8611             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8612             if (j.eq.l+1) then
8613               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8614      &          b1(1,itj1),auxvec(1))
8615               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8616             else
8617               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8618      &          b1(1,itl1),auxvec(1))
8619               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8620             endif
8621             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8622      &        pizda(1,1))
8623             vv(1)=pizda(1,1)-pizda(2,2)
8624             vv(2)=pizda(2,1)+pizda(1,2)
8625             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8626             if (swap) then
8627               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8628 #ifdef MOMENT
8629                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8630      &             -(s1+s2+s4)
8631 #else
8632                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8633      &             -(s2+s4)
8634 #endif
8635                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8636               else
8637 #ifdef MOMENT
8638                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8639 #else
8640                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8641 #endif
8642                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8643               endif
8644             else
8645 #ifdef MOMENT
8646               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8647 #else
8648               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8649 #endif
8650               if (l.eq.j+1) then
8651                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8652               else
8653                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8654               endif
8655             endif
8656           enddo
8657         enddo
8658       enddo
8659       return
8660       end
8661 c----------------------------------------------------------------------------
8662       double precision function eello_turn6(i,jj,kk)
8663       implicit real*8 (a-h,o-z)
8664       include 'DIMENSIONS'
8665       include 'COMMON.IOUNITS'
8666       include 'COMMON.CHAIN'
8667       include 'COMMON.DERIV'
8668       include 'COMMON.INTERACT'
8669       include 'COMMON.CONTACTS'
8670       include 'COMMON.TORSION'
8671       include 'COMMON.VAR'
8672       include 'COMMON.GEO'
8673       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8674      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8675      &  ggg1(3),ggg2(3)
8676       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8677      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8678 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8679 C           the respective energy moment and not to the cluster cumulant.
8680       s1=0.0d0
8681       s8=0.0d0
8682       s13=0.0d0
8683 c
8684       eello_turn6=0.0d0
8685       j=i+4
8686       k=i+1
8687       l=i+3
8688       iti=itortyp(itype(i))
8689       itk=itortyp(itype(k))
8690       itk1=itortyp(itype(k+1))
8691       itl=itortyp(itype(l))
8692       itj=itortyp(itype(j))
8693 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8694 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8695 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8696 cd        eello6=0.0d0
8697 cd        return
8698 cd      endif
8699 cd      write (iout,*)
8700 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8701 cd     &   ' and',k,l
8702 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8703       do iii=1,2
8704         do kkk=1,5
8705           do lll=1,3
8706             derx_turn(lll,kkk,iii)=0.0d0
8707           enddo
8708         enddo
8709       enddo
8710 cd      eij=1.0d0
8711 cd      ekl=1.0d0
8712 cd      ekont=1.0d0
8713       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8714 cd      eello6_5=0.0d0
8715 cd      write (2,*) 'eello6_5',eello6_5
8716 #ifdef MOMENT
8717       call transpose2(AEA(1,1,1),auxmat(1,1))
8718       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8719       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8720       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8721 #endif
8722       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8723       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8724       s2 = scalar2(b1(1,itk),vtemp1(1))
8725 #ifdef MOMENT
8726       call transpose2(AEA(1,1,2),atemp(1,1))
8727       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8728       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8729       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8730 #endif
8731       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8732       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8733       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8734 #ifdef MOMENT
8735       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8736       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8737       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8738       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8739       ss13 = scalar2(b1(1,itk),vtemp4(1))
8740       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8741 #endif
8742 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8743 c      s1=0.0d0
8744 c      s2=0.0d0
8745 c      s8=0.0d0
8746 c      s12=0.0d0
8747 c      s13=0.0d0
8748       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8749 C Derivatives in gamma(i+2)
8750       s1d =0.0d0
8751       s8d =0.0d0
8752 #ifdef MOMENT
8753       call transpose2(AEA(1,1,1),auxmatd(1,1))
8754       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8755       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8756       call transpose2(AEAderg(1,1,2),atempd(1,1))
8757       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8758       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8759 #endif
8760       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8761       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8762       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8763 c      s1d=0.0d0
8764 c      s2d=0.0d0
8765 c      s8d=0.0d0
8766 c      s12d=0.0d0
8767 c      s13d=0.0d0
8768       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8769 C Derivatives in gamma(i+3)
8770 #ifdef MOMENT
8771       call transpose2(AEA(1,1,1),auxmatd(1,1))
8772       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8773       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8774       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8775 #endif
8776       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8777       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8778       s2d = scalar2(b1(1,itk),vtemp1d(1))
8779 #ifdef MOMENT
8780       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8781       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8782 #endif
8783       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8784 #ifdef MOMENT
8785       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8786       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8787       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8788 #endif
8789 c      s1d=0.0d0
8790 c      s2d=0.0d0
8791 c      s8d=0.0d0
8792 c      s12d=0.0d0
8793 c      s13d=0.0d0
8794 #ifdef MOMENT
8795       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8796      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8797 #else
8798       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8799      &               -0.5d0*ekont*(s2d+s12d)
8800 #endif
8801 C Derivatives in gamma(i+4)
8802       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8803       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8804       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8805 #ifdef MOMENT
8806       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8807       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8808       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8809 #endif
8810 c      s1d=0.0d0
8811 c      s2d=0.0d0
8812 c      s8d=0.0d0
8813 C      s12d=0.0d0
8814 c      s13d=0.0d0
8815 #ifdef MOMENT
8816       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8817 #else
8818       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8819 #endif
8820 C Derivatives in gamma(i+5)
8821 #ifdef MOMENT
8822       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8823       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8824       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8825 #endif
8826       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8827       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8828       s2d = scalar2(b1(1,itk),vtemp1d(1))
8829 #ifdef MOMENT
8830       call transpose2(AEA(1,1,2),atempd(1,1))
8831       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8832       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8833 #endif
8834       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8835       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8836 #ifdef MOMENT
8837       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8838       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8839       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8840 #endif
8841 c      s1d=0.0d0
8842 c      s2d=0.0d0
8843 c      s8d=0.0d0
8844 c      s12d=0.0d0
8845 c      s13d=0.0d0
8846 #ifdef MOMENT
8847       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8848      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8849 #else
8850       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8851      &               -0.5d0*ekont*(s2d+s12d)
8852 #endif
8853 C Cartesian derivatives
8854       do iii=1,2
8855         do kkk=1,5
8856           do lll=1,3
8857 #ifdef MOMENT
8858             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8859             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8860             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8861 #endif
8862             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8863             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8864      &          vtemp1d(1))
8865             s2d = scalar2(b1(1,itk),vtemp1d(1))
8866 #ifdef MOMENT
8867             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8868             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8869             s8d = -(atempd(1,1)+atempd(2,2))*
8870      &           scalar2(cc(1,1,itl),vtemp2(1))
8871 #endif
8872             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8873      &           auxmatd(1,1))
8874             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8875             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8876 c      s1d=0.0d0
8877 c      s2d=0.0d0
8878 c      s8d=0.0d0
8879 c      s12d=0.0d0
8880 c      s13d=0.0d0
8881 #ifdef MOMENT
8882             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8883      &        - 0.5d0*(s1d+s2d)
8884 #else
8885             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8886      &        - 0.5d0*s2d
8887 #endif
8888 #ifdef MOMENT
8889             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8890      &        - 0.5d0*(s8d+s12d)
8891 #else
8892             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8893      &        - 0.5d0*s12d
8894 #endif
8895           enddo
8896         enddo
8897       enddo
8898 #ifdef MOMENT
8899       do kkk=1,5
8900         do lll=1,3
8901           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8902      &      achuj_tempd(1,1))
8903           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8904           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8905           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8906           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8907           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8908      &      vtemp4d(1))
8909           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8910           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8911           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8912         enddo
8913       enddo
8914 #endif
8915 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8916 cd     &  16*eel_turn6_num
8917 cd      goto 1112
8918       if (j.lt.nres-1) then
8919         j1=j+1
8920         j2=j-1
8921       else
8922         j1=j-1
8923         j2=j-2
8924       endif
8925       if (l.lt.nres-1) then
8926         l1=l+1
8927         l2=l-1
8928       else
8929         l1=l-1
8930         l2=l-2
8931       endif
8932       do ll=1,3
8933 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8934 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8935 cgrad        ghalf=0.5d0*ggg1(ll)
8936 cd        ghalf=0.0d0
8937         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8938         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8939         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8940      &    +ekont*derx_turn(ll,2,1)
8941         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8942         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8943      &    +ekont*derx_turn(ll,4,1)
8944         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8945         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8946         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8947 cgrad        ghalf=0.5d0*ggg2(ll)
8948 cd        ghalf=0.0d0
8949         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8950      &    +ekont*derx_turn(ll,2,2)
8951         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8952         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8953      &    +ekont*derx_turn(ll,4,2)
8954         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8955         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8956         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8957       enddo
8958 cd      goto 1112
8959 cgrad      do m=i+1,j-1
8960 cgrad        do ll=1,3
8961 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8962 cgrad        enddo
8963 cgrad      enddo
8964 cgrad      do m=k+1,l-1
8965 cgrad        do ll=1,3
8966 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8967 cgrad        enddo
8968 cgrad      enddo
8969 cgrad1112  continue
8970 cgrad      do m=i+2,j2
8971 cgrad        do ll=1,3
8972 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8973 cgrad        enddo
8974 cgrad      enddo
8975 cgrad      do m=k+2,l2
8976 cgrad        do ll=1,3
8977 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8978 cgrad        enddo
8979 cgrad      enddo
8980 cd      do iii=1,nres-3
8981 cd        write (2,*) iii,g_corr6_loc(iii)
8982 cd      enddo
8983       eello_turn6=ekont*eel_turn6
8984 cd      write (2,*) 'ekont',ekont
8985 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8986       return
8987       end
8988
8989 C-----------------------------------------------------------------------------
8990       double precision function scalar(u,v)
8991 !DIR$ INLINEALWAYS scalar
8992 #ifndef OSF
8993 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8994 #endif
8995       implicit none
8996       double precision u(3),v(3)
8997 cd      double precision sc
8998 cd      integer i
8999 cd      sc=0.0d0
9000 cd      do i=1,3
9001 cd        sc=sc+u(i)*v(i)
9002 cd      enddo
9003 cd      scalar=sc
9004
9005       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9006       return
9007       end
9008 crc-------------------------------------------------
9009       SUBROUTINE MATVEC2(A1,V1,V2)
9010 !DIR$ INLINEALWAYS MATVEC2
9011 #ifndef OSF
9012 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9013 #endif
9014       implicit real*8 (a-h,o-z)
9015       include 'DIMENSIONS'
9016       DIMENSION A1(2,2),V1(2),V2(2)
9017 c      DO 1 I=1,2
9018 c        VI=0.0
9019 c        DO 3 K=1,2
9020 c    3     VI=VI+A1(I,K)*V1(K)
9021 c        Vaux(I)=VI
9022 c    1 CONTINUE
9023
9024       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9025       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9026
9027       v2(1)=vaux1
9028       v2(2)=vaux2
9029       END
9030 C---------------------------------------
9031       SUBROUTINE MATMAT2(A1,A2,A3)
9032 #ifndef OSF
9033 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9034 #endif
9035       implicit real*8 (a-h,o-z)
9036       include 'DIMENSIONS'
9037       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9038 c      DIMENSION AI3(2,2)
9039 c        DO  J=1,2
9040 c          A3IJ=0.0
9041 c          DO K=1,2
9042 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9043 c          enddo
9044 c          A3(I,J)=A3IJ
9045 c       enddo
9046 c      enddo
9047
9048       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9049       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9050       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9051       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9052
9053       A3(1,1)=AI3_11
9054       A3(2,1)=AI3_21
9055       A3(1,2)=AI3_12
9056       A3(2,2)=AI3_22
9057       END
9058
9059 c-------------------------------------------------------------------------
9060       double precision function scalar2(u,v)
9061 !DIR$ INLINEALWAYS scalar2
9062       implicit none
9063       double precision u(2),v(2)
9064       double precision sc
9065       integer i
9066       scalar2=u(1)*v(1)+u(2)*v(2)
9067       return
9068       end
9069
9070 C-----------------------------------------------------------------------------
9071
9072       subroutine transpose2(a,at)
9073 !DIR$ INLINEALWAYS transpose2
9074 #ifndef OSF
9075 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9076 #endif
9077       implicit none
9078       double precision a(2,2),at(2,2)
9079       at(1,1)=a(1,1)
9080       at(1,2)=a(2,1)
9081       at(2,1)=a(1,2)
9082       at(2,2)=a(2,2)
9083       return
9084       end
9085 c--------------------------------------------------------------------------
9086       subroutine transpose(n,a,at)
9087       implicit none
9088       integer n,i,j
9089       double precision a(n,n),at(n,n)
9090       do i=1,n
9091         do j=1,n
9092           at(j,i)=a(i,j)
9093         enddo
9094       enddo
9095       return
9096       end
9097 C---------------------------------------------------------------------------
9098       subroutine prodmat3(a1,a2,kk,transp,prod)
9099 !DIR$ INLINEALWAYS prodmat3
9100 #ifndef OSF
9101 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9102 #endif
9103       implicit none
9104       integer i,j
9105       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9106       logical transp
9107 crc      double precision auxmat(2,2),prod_(2,2)
9108
9109       if (transp) then
9110 crc        call transpose2(kk(1,1),auxmat(1,1))
9111 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9112 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9113
9114            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9115      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9116            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9117      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9118            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9119      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9120            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9121      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9122
9123       else
9124 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9125 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9126
9127            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9128      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9129            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9130      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9131            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9132      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9133            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9134      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9135
9136       endif
9137 c      call transpose2(a2(1,1),a2t(1,1))
9138
9139 crc      print *,transp
9140 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9141 crc      print *,((prod(i,j),i=1,2),j=1,2)
9142
9143       return
9144       end
9145