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       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 c      print *,"Processor",myrank," computed USCSC"
 126 #ifdef TIMING
 127       time01=MPI_Wtime()
 128 #endif
 129       call vec_and_deriv
 130 #ifdef TIMING
 131       time_vec=time_vec+MPI_Wtime()-time01
 132 #endif
 133 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 134       if (ipot.lt.6) then
 135 #ifdef SPLITELE
 136          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 137      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 138      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 139      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 140 #else
 141          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #endif
 146             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 147          else
 148             ees=0.0d0
 149             evdw1=0.0d0
 150             eel_loc=0.0d0
 151             eello_turn3=0.0d0
 152             eello_turn4=0.0d0
 153          endif
 154       else
 155 c        write (iout,*) "Soft-spheer ELEC potential"
 156         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 157      &   eello_turn4)
 158       endif
 159 c      print *,"Processor",myrank," computed UELEC"
 160 C
 161 C Calculate excluded-volume interaction energy between peptide groups
 162 C and side chains.
 163 C
 164       if (ipot.lt.6) then
 165        if(wscp.gt.0d0) then
 166         call escp(evdw2,evdw2_14)
 167        else
 168         evdw2=0
 169         evdw2_14=0
 170        endif
 171       else
 172 c        write (iout,*) "Soft-sphere SCP potential"
 173         call escp_soft_sphere(evdw2,evdw2_14)
 174       endif
 175 c
 176 c Calculate the bond-stretching energy
 177 c
 178       call ebond(estr)
 179 C
 180 C Calculate the disulfide-bridge and other energy and the contributions
 181 C from other distance constraints.
 182 cd    print *,'Calling EHPB'
 183       call edis(ehpb)
 184 cd    print *,'EHPB exitted succesfully.'
 185 C
 186 C Calculate the virtual-bond-angle energy.
 187 C
 188       if (wang.gt.0d0) then
 189         call ebend(ebe)
 190       else
 191         ebe=0
 192       endif
 193 c      print *,"Processor",myrank," computed UB"
 194 C
 195 C Calculate the SC local energy.
 196 C
 197       call esc(escloc)
 198 c      print *,"Processor",myrank," computed USC"
 199 C
 200 C Calculate the virtual-bond torsional energy.
 201 C
 202 cd    print *,'nterm=',nterm
 203       if (wtor.gt.0) then
 204        call etor(etors,edihcnstr)
 205       else
 206        etors=0
 207        edihcnstr=0
 208       endif
 209 c      print *,"Processor",myrank," computed Utor"
 210 C
 211 C 6/23/01 Calculate double-torsional energy
 212 C
 213       if (wtor_d.gt.0) then
 214        call etor_d(etors_d)
 215       else
 216        etors_d=0
 217       endif
 218 c      print *,"Processor",myrank," computed Utord"
 219 C
 220 C 21/5/07 Calculate local sicdechain correlation energy
 221 C
 222       if (wsccor.gt.0.0d0) then
 223         call eback_sc_corr(esccor)
 224       else
 225         esccor=0.0d0
 226       endif
 227 c      print *,"Processor",myrank," computed Usccorr"
 228 C
 229 C 12/1/95 Multi-body terms
 230 C
 231       n_corr=0
 232       n_corr1=0
 233       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 234      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 235          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 236 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 237 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 238       else
 239          ecorr=0.0d0
 240          ecorr5=0.0d0
 241          ecorr6=0.0d0
 242          eturn6=0.0d0
 243       endif
 244       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 245          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 246 cd         write (iout,*) "multibody_hb ecorr",ecorr
 247       endif
 248 c      print *,"Processor",myrank," computed Ucorr"
 249 C
 250 C If performing constraint dynamics, call the constraint energy
 251 C  after the equilibration time
 252       if(usampl.and.totT.gt.eq_time) then
 253          call EconstrQ
 254          call Econstr_back
 255       else
 256          Uconst=0.0d0
 257          Uconst_back=0.0d0
 258       endif
 259 #ifdef TIMING
 260       time_enecalc=time_enecalc+MPI_Wtime()-time00
 261 #endif
 262 c      print *,"Processor",myrank," computed Uconstr"
 263 #ifdef TIMING
 264       time00=MPI_Wtime()
 265 #endif
 266 c
 267 C Sum the energies
 268 C
 269       energia(1)=evdw
 270 #ifdef SCP14
 271       energia(2)=evdw2-evdw2_14
 272       energia(18)=evdw2_14
 273 #else
 274       energia(2)=evdw2
 275       energia(18)=0.0d0
 276 #endif
 277 #ifdef SPLITELE
 278       energia(3)=ees
 279       energia(16)=evdw1
 280 #else
 281       energia(3)=ees+evdw1
 282       energia(16)=0.0d0
 283 #endif
 284       energia(4)=ecorr
 285       energia(5)=ecorr5
 286       energia(6)=ecorr6
 287       energia(7)=eel_loc
 288       energia(8)=eello_turn3
 289       energia(9)=eello_turn4
 290       energia(10)=eturn6
 291       energia(11)=ebe
 292       energia(12)=escloc
 293       energia(13)=etors
 294       energia(14)=etors_d
 295       energia(15)=ehpb
 296       energia(19)=edihcnstr
 297       energia(17)=estr
 298       energia(20)=Uconst+Uconst_back
 299       energia(21)=esccor
 300 c    Here are the energies showed per procesor if the are more processors
 301 c    per molecule then we sum it up in sum_energy subroutine
 302 c      print *," Processor",myrank," calls SUM_ENERGY"
 303       call sum_energy(energia,.true.)
 304 c      print *," Processor",myrank," left SUM_ENERGY"
 305 #ifdef TIMING
 306       time_sumene=time_sumene+MPI_Wtime()-time00
 307 #endif
 308       return
 309       end
 310 c-------------------------------------------------------------------------------
 311       subroutine sum_energy(energia,reduce)
 312       implicit real*8 (a-h,o-z)
 313       include 'DIMENSIONS'
 314 #ifndef ISNAN
 315       external proc_proc
 316 #ifdef WINPGI
 317 cMS$ATTRIBUTES C ::  proc_proc
 318 #endif
 319 #endif
 320 #ifdef MPI
 321       include "mpif.h"
 322 #endif
 323       include 'COMMON.SETUP'
 324       include 'COMMON.IOUNITS'
 325       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 326       include 'COMMON.FFIELD'
 327       include 'COMMON.DERIV'
 328       include 'COMMON.INTERACT'
 329       include 'COMMON.SBRIDGE'
 330       include 'COMMON.CHAIN'
 331       include 'COMMON.VAR'
 332       include 'COMMON.CONTROL'
 333       include 'COMMON.TIME1'
 334       logical reduce
 335 #ifdef MPI
 336       if (nfgtasks.gt.1 .and. reduce) then
 337 #ifdef DEBUG
 338         write (iout,*) "energies before REDUCE"
 339         call enerprint(energia)
 340         call flush(iout)
 341 #endif
 342         do i=0,n_ene
 343           enebuff(i)=energia(i)
 344         enddo
 345         time00=MPI_Wtime()
 346         call MPI_Barrier(FG_COMM,IERR)
 347         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 348         time00=MPI_Wtime()
 349         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 350      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 351 #ifdef DEBUG
 352         write (iout,*) "energies after REDUCE"
 353         call enerprint(energia)
 354         call flush(iout)
 355 #endif
 356         time_Reduce=time_Reduce+MPI_Wtime()-time00
 357       endif
 358       if (fg_rank.eq.0) then
 359 #endif
 360       evdw=energia(1)
 361 #ifdef SCP14
 362       evdw2=energia(2)+energia(18)
 363       evdw2_14=energia(18)
 364 #else
 365       evdw2=energia(2)
 366 #endif
 367 #ifdef SPLITELE
 368       ees=energia(3)
 369       evdw1=energia(16)
 370 #else
 371       ees=energia(3)
 372       evdw1=0.0d0
 373 #endif
 374       ecorr=energia(4)
 375       ecorr5=energia(5)
 376       ecorr6=energia(6)
 377       eel_loc=energia(7)
 378       eello_turn3=energia(8)
 379       eello_turn4=energia(9)
 380       eturn6=energia(10)
 381       ebe=energia(11)
 382       escloc=energia(12)
 383       etors=energia(13)
 384       etors_d=energia(14)
 385       ehpb=energia(15)
 386       edihcnstr=energia(19)
 387       estr=energia(17)
 388       Uconst=energia(20)
 389       esccor=energia(21)
 390 #ifdef SPLITELE
 391       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 392      & +wang*ebe+wtor*etors+wscloc*escloc
 393      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 394      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 395      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 396      & +wbond*estr+Uconst+wsccor*esccor
 397 #else
 398       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 399      & +wang*ebe+wtor*etors+wscloc*escloc
 400      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 401      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 402      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 403      & +wbond*estr+Uconst+wsccor*esccor
 404 #endif
 405       energia(0)=etot
 406 c detecting NaNQ
 407 #ifdef ISNAN
 408 #ifdef AIX
 409       if (isnan(etot).ne.0) energia(0)=1.0d+99
 410 #else
 411       if (isnan(etot)) energia(0)=1.0d+99
 412 #endif
 413 #else
 414       i=0
 415 #ifdef WINPGI
 416       idumm=proc_proc(etot,i)
 417 #else
 418       call proc_proc(etot,i)
 419 #endif
 420       if(i.eq.1)energia(0)=1.0d+99
 421 #endif
 422 #ifdef MPI
 423       endif
 424 #endif
 425       return
 426       end
 427 c-------------------------------------------------------------------------------
 428       subroutine sum_gradient
 429       implicit real*8 (a-h,o-z)
 430       include 'DIMENSIONS'
 431 #ifndef ISNAN
 432       external proc_proc
 433 #ifdef WINPGI
 434 cMS$ATTRIBUTES C ::  proc_proc
 435 #endif
 436 #endif
 437 #ifdef MPI
 438       include 'mpif.h'
 439       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 440      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 441 #endif
 442       include 'COMMON.SETUP'
 443       include 'COMMON.IOUNITS'
 444       include 'COMMON.FFIELD'
 445       include 'COMMON.DERIV'
 446       include 'COMMON.INTERACT'
 447       include 'COMMON.SBRIDGE'
 448       include 'COMMON.CHAIN'
 449       include 'COMMON.VAR'
 450       include 'COMMON.CONTROL'
 451       include 'COMMON.TIME1'
 452       include 'COMMON.MAXGRAD'
 453       include 'COMMON.SCCOR'
 454 #ifdef TIMING
 455       time01=MPI_Wtime()
 456 #endif
 457 #ifdef DEBUG
 458       write (iout,*) "sum_gradient gvdwc, gvdwx"
 459       do i=1,nres
 460         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 461      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 462       enddo
 463       call flush(iout)
 464 #endif
 465 #ifdef MPI
 466 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 467         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 468      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 469 #endif
 470 C
 471 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 472 C            in virtual-bond-vector coordinates
 473 C
 474 #ifdef DEBUG
 475 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 476 c      do i=1,nres-1
 477 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 478 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 479 c      enddo
 480 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 483 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 484 c      enddo
 485       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 486       do i=1,nres
 487         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 488      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 489      &   g_corr5_loc(i)
 490       enddo
 491       call flush(iout)
 492 #endif
 493 #ifdef SPLITELE
 494       do i=1,nct
 495         do j=1,3
 496           gradbufc(j,i)=wsc*gvdwc(j,i)+
 497      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 498      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 499      &                wel_loc*gel_loc_long(j,i)+
 500      &                wcorr*gradcorr_long(j,i)+
 501      &                wcorr5*gradcorr5_long(j,i)+
 502      &                wcorr6*gradcorr6_long(j,i)+
 503      &                wturn6*gcorr6_turn_long(j,i)+
 504      &                wstrain*ghpbc(j,i)
 505         enddo
 506       enddo
 507 #else
 508       do i=1,nct
 509         do j=1,3
 510           gradbufc(j,i)=wsc*gvdwc(j,i)+
 511      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 512      &                welec*gelc_long(j,i)+
 513      &                wbond*gradb(j,i)+
 514      &                wel_loc*gel_loc_long(j,i)+
 515      &                wcorr*gradcorr_long(j,i)+
 516      &                wcorr5*gradcorr5_long(j,i)+
 517      &                wcorr6*gradcorr6_long(j,i)+
 518      &                wturn6*gcorr6_turn_long(j,i)+
 519      &                wstrain*ghpbc(j,i)
 520         enddo
 521       enddo
 522 #endif
 523 #ifdef MPI
 524       if (nfgtasks.gt.1) then
 525       time00=MPI_Wtime()
 526 #ifdef DEBUG
 527       write (iout,*) "gradbufc before allreduce"
 528       do i=1,nres
 529         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 530       enddo
 531       call flush(iout)
 532 #endif
 533       do i=1,nres
 534         do j=1,3
 535           gradbufc_sum(j,i)=gradbufc(j,i)
 536         enddo
 537       enddo
 538 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 539 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 540 c      time_reduce=time_reduce+MPI_Wtime()-time00
 541 #ifdef DEBUG
 542 c      write (iout,*) "gradbufc_sum after allreduce"
 543 c      do i=1,nres
 544 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 545 c      enddo
 546 c      call flush(iout)
 547 #endif
 548 #ifdef TIMING
 549 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 550 #endif
 551       do i=nnt,nres
 552         do k=1,3
 553           gradbufc(k,i)=0.0d0
 554         enddo
 555       enddo
 556 #ifdef DEBUG
 557       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 558       write (iout,*) (i," jgrad_start",jgrad_start(i),
 559      &                  " jgrad_end  ",jgrad_end(i),
 560      &                  i=igrad_start,igrad_end)
 561 #endif
 562 c
 563 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 564 c do not parallelize this part.
 565 c
 566 c      do i=igrad_start,igrad_end
 567 c        do j=jgrad_start(i),jgrad_end(i)
 568 c          do k=1,3
 569 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 570 c          enddo
 571 c        enddo
 572 c      enddo
 573       do j=1,3
 574         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 575       enddo
 576       do i=nres-2,nnt,-1
 577         do j=1,3
 578           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 579         enddo
 580       enddo
 581 #ifdef DEBUG
 582       write (iout,*) "gradbufc after summing"
 583       do i=1,nres
 584         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 585       enddo
 586       call flush(iout)
 587 #endif
 588       else
 589 #endif
 590 #ifdef DEBUG
 591       write (iout,*) "gradbufc"
 592       do i=1,nres
 593         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 594       enddo
 595       call flush(iout)
 596 #endif
 597       do i=1,nres
 598         do j=1,3
 599           gradbufc_sum(j,i)=gradbufc(j,i)
 600           gradbufc(j,i)=0.0d0
 601         enddo
 602       enddo
 603       do j=1,3
 604         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 605       enddo
 606       do i=nres-2,nnt,-1
 607         do j=1,3
 608           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 609         enddo
 610       enddo
 611 c      do i=nnt,nres-1
 612 c        do k=1,3
 613 c          gradbufc(k,i)=0.0d0
 614 c        enddo
 615 c        do j=i+1,nres
 616 c          do k=1,3
 617 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 618 c          enddo
 619 c        enddo
 620 c      enddo
 621 #ifdef DEBUG
 622       write (iout,*) "gradbufc after summing"
 623       do i=1,nres
 624         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 625       enddo
 626       call flush(iout)
 627 #endif
 628 #ifdef MPI
 629       endif
 630 #endif
 631       do k=1,3
 632         gradbufc(k,nres)=0.0d0
 633       enddo
 634       do i=1,nct
 635         do j=1,3
 636 #ifdef SPLITELE
 637           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 638      &                wel_loc*gel_loc(j,i)+
 639      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 640      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 641      &                wel_loc*gel_loc_long(j,i)+
 642      &                wcorr*gradcorr_long(j,i)+
 643      &                wcorr5*gradcorr5_long(j,i)+
 644      &                wcorr6*gradcorr6_long(j,i)+
 645      &                wturn6*gcorr6_turn_long(j,i))+
 646      &                wbond*gradb(j,i)+
 647      &                wcorr*gradcorr(j,i)+
 648      &                wturn3*gcorr3_turn(j,i)+
 649      &                wturn4*gcorr4_turn(j,i)+
 650      &                wcorr5*gradcorr5(j,i)+
 651      &                wcorr6*gradcorr6(j,i)+
 652      &                wturn6*gcorr6_turn(j,i)+
 653      &                wsccor*gsccorc(j,i)
 654      &               +wscloc*gscloc(j,i)
 655 #else
 656           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 657      &                wel_loc*gel_loc(j,i)+
 658      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 659      &                welec*gelc_long(j,i)
 660      &                wel_loc*gel_loc_long(j,i)+
 661      &                wcorr*gcorr_long(j,i)+
 662      &                wcorr5*gradcorr5_long(j,i)+
 663      &                wcorr6*gradcorr6_long(j,i)+
 664      &                wturn6*gcorr6_turn_long(j,i))+
 665      &                wbond*gradb(j,i)+
 666      &                wcorr*gradcorr(j,i)+
 667      &                wturn3*gcorr3_turn(j,i)+
 668      &                wturn4*gcorr4_turn(j,i)+
 669      &                wcorr5*gradcorr5(j,i)+
 670      &                wcorr6*gradcorr6(j,i)+
 671      &                wturn6*gcorr6_turn(j,i)+
 672      &                wsccor*gsccorc(j,i)
 673      &               +wscloc*gscloc(j,i)
 674 #endif
 675           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 676      &                  wbond*gradbx(j,i)+
 677      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 678      &                  wsccor*gsccorx(j,i)
 679      &                 +wscloc*gsclocx(j,i)
 680         enddo
 681       enddo
 682 #ifdef DEBUG
 683       write (iout,*) "gloc before adding corr"
 684       do i=1,4*nres
 685         write (iout,*) i,gloc(i,icg)
 686       enddo
 687 #endif
 688       do i=1,nres-3
 689         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 690      &   +wcorr5*g_corr5_loc(i)
 691      &   +wcorr6*g_corr6_loc(i)
 692      &   +wturn4*gel_loc_turn4(i)
 693      &   +wturn3*gel_loc_turn3(i)
 694      &   +wturn6*gel_loc_turn6(i)
 695      &   +wel_loc*gel_loc_loc(i)
 696       enddo
 697 #ifdef DEBUG
 698       write (iout,*) "gloc after adding corr"
 699       do i=1,4*nres
 700         write (iout,*) i,gloc(i,icg)
 701       enddo
 702 #endif
 703 #ifdef MPI
 704       if (nfgtasks.gt.1) then
 705         do j=1,3
 706           do i=1,nres
 707             gradbufc(j,i)=gradc(j,i,icg)
 708             gradbufx(j,i)=gradx(j,i,icg)
 709           enddo
 710         enddo
 711         do i=1,4*nres
 712           glocbuf(i)=gloc(i,icg)
 713         enddo
 714 #define DEBUG
 715 #ifdef DEBUG
 716       write (iout,*) "gloc_sc before reduce"
 717       do i=1,nres
 718        do j=1,1
 719         write (iout,*) i,j,gloc_sc(j,i,icg)
 720        enddo
 721       enddo
 722 #endif
 723 #undef DEBUG
 724         do i=1,nres
 725          do j=1,3
 726           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 727          enddo
 728         enddo
 729         time00=MPI_Wtime()
 730         call MPI_Barrier(FG_COMM,IERR)
 731         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 732         time00=MPI_Wtime()
 733         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 734      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 735         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 736      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 737         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         time_reduce=time_reduce+MPI_Wtime()-time00
 740         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         time_reduce=time_reduce+MPI_Wtime()-time00
 743 #define DEBUG
 744 #ifdef DEBUG
 745       write (iout,*) "gloc_sc after reduce"
 746       do i=1,nres
 747        do j=1,1
 748         write (iout,*) i,j,gloc_sc(j,i,icg)
 749        enddo
 750       enddo
 751 #endif
 752 #undef DEBUG
 753 #ifdef DEBUG
 754       write (iout,*) "gloc after reduce"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       endif
 760 #endif
 761       if (gnorm_check) then
 762 c
 763 c Compute the maximum elements of the gradient
 764 c
 765       gvdwc_max=0.0d0
 766       gvdwc_scp_max=0.0d0
 767       gelc_max=0.0d0
 768       gvdwpp_max=0.0d0
 769       gradb_max=0.0d0
 770       ghpbc_max=0.0d0
 771       gradcorr_max=0.0d0
 772       gel_loc_max=0.0d0
 773       gcorr3_turn_max=0.0d0
 774       gcorr4_turn_max=0.0d0
 775       gradcorr5_max=0.0d0
 776       gradcorr6_max=0.0d0
 777       gcorr6_turn_max=0.0d0
 778       gsccorc_max=0.0d0
 779       gscloc_max=0.0d0
 780       gvdwx_max=0.0d0
 781       gradx_scp_max=0.0d0
 782       ghpbx_max=0.0d0
 783       gradxorr_max=0.0d0
 784       gsccorx_max=0.0d0
 785       gsclocx_max=0.0d0
 786       do i=1,nct
 787         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 788         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 789         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 790         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 791      &   gvdwc_scp_max=gvdwc_scp_norm
 792         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 793         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 794         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 795         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 796         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 797         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 798         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 799         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 800         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 801         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 802         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 803         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 804         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 805      &    gcorr3_turn(1,i)))
 806         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 807      &    gcorr3_turn_max=gcorr3_turn_norm
 808         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 809      &    gcorr4_turn(1,i)))
 810         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 811      &    gcorr4_turn_max=gcorr4_turn_norm
 812         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 813         if (gradcorr5_norm.gt.gradcorr5_max)
 814      &    gradcorr5_max=gradcorr5_norm
 815         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 816         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 817         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 818      &    gcorr6_turn(1,i)))
 819         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 820      &    gcorr6_turn_max=gcorr6_turn_norm
 821         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 822         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 823         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 824         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 825         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 826         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 827         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 828         if (gradx_scp_norm.gt.gradx_scp_max)
 829      &    gradx_scp_max=gradx_scp_norm
 830         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 831         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 832         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 833         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 834         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 835         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 836         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 837         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 838       enddo
 839       if (gradout) then
 840 #ifdef AIX
 841         open(istat,file=statname,position="append")
 842 #else
 843         open(istat,file=statname,access="append")
 844 #endif
 845         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 846      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 847      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 848      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 849      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 850      &     gsccorx_max,gsclocx_max
 851         close(istat)
 852         if (gvdwc_max.gt.1.0d4) then
 853           write (iout,*) "gvdwc gvdwx gradb gradbx"
 854           do i=nnt,nct
 855             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 856      &        gradb(j,i),gradbx(j,i),j=1,3)
 857           enddo
 858           call pdbout(0.0d0,'cipiszcze',iout)
 859           call flush(iout)
 860         endif
 861       endif
 862       endif
 863 #ifdef DEBUG
 864       write (iout,*) "gradc gradx gloc"
 865       do i=1,nres
 866         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 867      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 868       enddo
 869 #endif
 870 #ifdef TIMING
 871       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 872 #endif
 873       return
 874       end
 875 c-------------------------------------------------------------------------------
 876       subroutine rescale_weights(t_bath)
 877       implicit real*8 (a-h,o-z)
 878       include 'DIMENSIONS'
 879       include 'COMMON.IOUNITS'
 880       include 'COMMON.FFIELD'
 881       include 'COMMON.SBRIDGE'
 882       double precision kfac /2.4d0/
 883       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 884 c      facT=temp0/t_bath
 885 c      facT=2*temp0/(t_bath+temp0)
 886       if (rescale_mode.eq.0) then
 887         facT=1.0d0
 888         facT2=1.0d0
 889         facT3=1.0d0
 890         facT4=1.0d0
 891         facT5=1.0d0
 892       else if (rescale_mode.eq.1) then
 893         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 894         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 895         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 896         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 897         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 898       else if (rescale_mode.eq.2) then
 899         x=t_bath/temp0
 900         x2=x*x
 901         x3=x2*x
 902         x4=x3*x
 903         x5=x4*x
 904         facT=licznik/dlog(dexp(x)+dexp(-x))
 905         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 906         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 907         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 908         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 909       else
 910         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 911         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 912 #ifdef MPI
 913        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 914 #endif
 915        stop 555
 916       endif
 917       welec=weights(3)*fact
 918       wcorr=weights(4)*fact3
 919       wcorr5=weights(5)*fact4
 920       wcorr6=weights(6)*fact5
 921       wel_loc=weights(7)*fact2
 922       wturn3=weights(8)*fact2
 923       wturn4=weights(9)*fact3
 924       wturn6=weights(10)*fact5
 925       wtor=weights(13)*fact
 926       wtor_d=weights(14)*fact2
 927       wsccor=weights(21)*fact
 928
 929       return
 930       end
 931 C------------------------------------------------------------------------
 932       subroutine enerprint(energia)
 933       implicit real*8 (a-h,o-z)
 934       include 'DIMENSIONS'
 935       include 'COMMON.IOUNITS'
 936       include 'COMMON.FFIELD'
 937       include 'COMMON.SBRIDGE'
 938       include 'COMMON.MD'
 939       double precision energia(0:n_ene)
 940       etot=energia(0)
 941       evdw=energia(1)
 942       evdw2=energia(2)
 943 #ifdef SCP14
 944       evdw2=energia(2)+energia(18)
 945 #else
 946       evdw2=energia(2)
 947 #endif
 948       ees=energia(3)
 949 #ifdef SPLITELE
 950       evdw1=energia(16)
 951 #endif
 952       ecorr=energia(4)
 953       ecorr5=energia(5)
 954       ecorr6=energia(6)
 955       eel_loc=energia(7)
 956       eello_turn3=energia(8)
 957       eello_turn4=energia(9)
 958       eello_turn6=energia(10)
 959       ebe=energia(11)
 960       escloc=energia(12)
 961       etors=energia(13)
 962       etors_d=energia(14)
 963       ehpb=energia(15)
 964       edihcnstr=energia(19)
 965       estr=energia(17)
 966       Uconst=energia(20)
 967       esccor=energia(21)
 968 #ifdef SPLITELE
 969       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 970      &  estr,wbond,ebe,wang,
 971      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 972      &  ecorr,wcorr,
 973      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 974      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 975      &  edihcnstr,ebr*nss,
 976      &  Uconst,etot
 977    10 format (/'Virtual-chain energies:'//
 978      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 979      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 980      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 981      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 982      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 983      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 984      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 985      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 986      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 987      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 988      & ' (SS bridges & dist. cnstr.)'/
 989      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 993      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 994      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 995      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 996      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 997      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 998      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 999      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1000      & 'ETOT=  ',1pE16.6,' (total)')
1001 #else
1002       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1003      &  estr,wbond,ebe,wang,
1004      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1005      &  ecorr,wcorr,
1006      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1007      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1008      &  ebr*nss,Uconst,etot
1009    10 format (/'Virtual-chain energies:'//
1010      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1011      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1012      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1013      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1014      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1015      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1016      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1017      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1018      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1019      & ' (SS bridges & dist. cnstr.)'/
1020      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1023      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1024      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1025      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1026      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1027      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1028      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1029      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1030      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1031      & 'ETOT=  ',1pE16.6,' (total)')
1032 #endif
1033       return
1034       end
1035 C-----------------------------------------------------------------------
1036       subroutine elj(evdw)
1037 C
1038 C This subroutine calculates the interaction energy of nonbonded side chains
1039 C assuming the LJ potential of interaction.
1040 C
1041       implicit real*8 (a-h,o-z)
1042       include 'DIMENSIONS'
1043       parameter (accur=1.0d-10)
1044       include 'COMMON.GEO'
1045       include 'COMMON.VAR'
1046       include 'COMMON.LOCAL'
1047       include 'COMMON.CHAIN'
1048       include 'COMMON.DERIV'
1049       include 'COMMON.INTERACT'
1050       include 'COMMON.TORSION'
1051       include 'COMMON.SBRIDGE'
1052       include 'COMMON.NAMES'
1053       include 'COMMON.IOUNITS'
1054       include 'COMMON.CONTACTS'
1055       dimension gg(3)
1056 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1057       evdw=0.0D0
1058       do i=iatsc_s,iatsc_e
1059         itypi=iabs(itype(i))
1060         if (itypi.eq.ntyp1) cycle
1061         itypi1=iabs(itype(i+1))
1062         xi=c(1,nres+i)
1063         yi=c(2,nres+i)
1064         zi=c(3,nres+i)
1065 C Change 12/1/95
1066         num_conti=0
1067 C
1068 C Calculate SC interaction energy.
1069 C
1070         do iint=1,nint_gr(i)
1071 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1072 cd   &                  'iend=',iend(i,iint)
1073           do j=istart(i,iint),iend(i,iint)
1074             itypj=iabs(itype(j))
1075             if (itypj.eq.ntyp1) cycle
1076             xj=c(1,nres+j)-xi
1077             yj=c(2,nres+j)-yi
1078             zj=c(3,nres+j)-zi
1079 C Change 12/1/95 to calculate four-body interactions
1080             rij=xj*xj+yj*yj+zj*zj
1081             rrij=1.0D0/rij
1082 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1083             eps0ij=eps(itypi,itypj)
1084             fac=rrij**expon2
1085             e1=fac*fac*aa(itypi,itypj)
1086             e2=fac*bb(itypi,itypj)
1087             evdwij=e1+e2
1088 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1089 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1090 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1091 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1092 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1093 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1094             evdw=evdw+evdwij
1095 C
1096 C Calculate the components of the gradient in DC and X
1097 C
1098             fac=-rrij*(e1+evdwij)
1099             gg(1)=xj*fac
1100             gg(2)=yj*fac
1101             gg(3)=zj*fac
1102             do k=1,3
1103               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1104               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1105               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1106               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1107             enddo
1108 cgrad            do k=i,j-1
1109 cgrad              do l=1,3
1110 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1111 cgrad              enddo
1112 cgrad            enddo
1113 C
1114 C 12/1/95, revised on 5/20/97
1115 C
1116 C Calculate the contact function. The ith column of the array JCONT will
1117 C contain the numbers of atoms that make contacts with the atom I (of numbers
1118 C greater than I). The arrays FACONT and GACONT will contain the values of
1119 C the contact function and its derivative.
1120 C
1121 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1122 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1123 C Uncomment next line, if the correlation interactions are contact function only
1124             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1125               rij=dsqrt(rij)
1126               sigij=sigma(itypi,itypj)
1127               r0ij=rs0(itypi,itypj)
1128 C
1129 C Check whether the SC's are not too far to make a contact.
1130 C
1131               rcut=1.5d0*r0ij
1132               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1133 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1134 C
1135               if (fcont.gt.0.0D0) then
1136 C If the SC-SC distance if close to sigma, apply spline.
1137 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1138 cAdam &             fcont1,fprimcont1)
1139 cAdam           fcont1=1.0d0-fcont1
1140 cAdam           if (fcont1.gt.0.0d0) then
1141 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1142 cAdam             fcont=fcont*fcont1
1143 cAdam           endif
1144 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1145 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1146 cga             do k=1,3
1147 cga               gg(k)=gg(k)*eps0ij
1148 cga             enddo
1149 cga             eps0ij=-evdwij*eps0ij
1150 C Uncomment for AL's type of SC correlation interactions.
1151 cadam           eps0ij=-evdwij
1152                 num_conti=num_conti+1
1153                 jcont(num_conti,i)=j
1154                 facont(num_conti,i)=fcont*eps0ij
1155                 fprimcont=eps0ij*fprimcont/rij
1156                 fcont=expon*fcont
1157 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1158 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1159 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1160 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1161                 gacont(1,num_conti,i)=-fprimcont*xj
1162                 gacont(2,num_conti,i)=-fprimcont*yj
1163                 gacont(3,num_conti,i)=-fprimcont*zj
1164 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1165 cd              write (iout,'(2i3,3f10.5)')
1166 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1167               endif
1168             endif
1169           enddo      ! j
1170         enddo        ! iint
1171 C Change 12/1/95
1172         num_cont(i)=num_conti
1173       enddo          ! i
1174       do i=1,nct
1175         do j=1,3
1176           gvdwc(j,i)=expon*gvdwc(j,i)
1177           gvdwx(j,i)=expon*gvdwx(j,i)
1178         enddo
1179       enddo
1180 C******************************************************************************
1181 C
1182 C                              N O T E !!!
1183 C
1184 C To save time, the factor of EXPON has been extracted from ALL components
1185 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1186 C use!
1187 C
1188 C******************************************************************************
1189       return
1190       end
1191 C-----------------------------------------------------------------------------
1192       subroutine eljk(evdw)
1193 C
1194 C This subroutine calculates the interaction energy of nonbonded side chains
1195 C assuming the LJK potential of interaction.
1196 C
1197       implicit real*8 (a-h,o-z)
1198       include 'DIMENSIONS'
1199       include 'COMMON.GEO'
1200       include 'COMMON.VAR'
1201       include 'COMMON.LOCAL'
1202       include 'COMMON.CHAIN'
1203       include 'COMMON.DERIV'
1204       include 'COMMON.INTERACT'
1205       include 'COMMON.IOUNITS'
1206       include 'COMMON.NAMES'
1207       dimension gg(3)
1208       logical scheck
1209 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1210       evdw=0.0D0
1211       do i=iatsc_s,iatsc_e
1212         itypi=iabs(itype(i))
1213         if (itypi.eq.ntyp1) cycle
1214         itypi1=iabs(itype(i+1))
1215         xi=c(1,nres+i)
1216         yi=c(2,nres+i)
1217         zi=c(3,nres+i)
1218 C
1219 C Calculate SC interaction energy.
1220 C
1221         do iint=1,nint_gr(i)
1222           do j=istart(i,iint),iend(i,iint)
1223             itypj=iabs(itype(j))
1224             if (itypj.eq.ntyp1) cycle
1225             xj=c(1,nres+j)-xi
1226             yj=c(2,nres+j)-yi
1227             zj=c(3,nres+j)-zi
1228             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1229             fac_augm=rrij**expon
1230             e_augm=augm(itypi,itypj)*fac_augm
1231             r_inv_ij=dsqrt(rrij)
1232             rij=1.0D0/r_inv_ij
1233             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1234             fac=r_shift_inv**expon
1235             e1=fac*fac*aa(itypi,itypj)
1236             e2=fac*bb(itypi,itypj)
1237             evdwij=e_augm+e1+e2
1238 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1239 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1240 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1241 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1242 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1243 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1244 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1245             evdw=evdw+evdwij
1246 C
1247 C Calculate the components of the gradient in DC and X
1248 C
1249             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1250             gg(1)=xj*fac
1251             gg(2)=yj*fac
1252             gg(3)=zj*fac
1253             do k=1,3
1254               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1255               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1256               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1257               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1258             enddo
1259 cgrad            do k=i,j-1
1260 cgrad              do l=1,3
1261 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1262 cgrad              enddo
1263 cgrad            enddo
1264           enddo      ! j
1265         enddo        ! iint
1266       enddo          ! i
1267       do i=1,nct
1268         do j=1,3
1269           gvdwc(j,i)=expon*gvdwc(j,i)
1270           gvdwx(j,i)=expon*gvdwx(j,i)
1271         enddo
1272       enddo
1273       return
1274       end
1275 C-----------------------------------------------------------------------------
1276       subroutine ebp(evdw)
1277 C
1278 C This subroutine calculates the interaction energy of nonbonded side chains
1279 C assuming the Berne-Pechukas potential of interaction.
1280 C
1281       implicit real*8 (a-h,o-z)
1282       include 'DIMENSIONS'
1283       include 'COMMON.GEO'
1284       include 'COMMON.VAR'
1285       include 'COMMON.LOCAL'
1286       include 'COMMON.CHAIN'
1287       include 'COMMON.DERIV'
1288       include 'COMMON.NAMES'
1289       include 'COMMON.INTERACT'
1290       include 'COMMON.IOUNITS'
1291       include 'COMMON.CALC'
1292       common /srutu/ icall
1293 c     double precision rrsave(maxdim)
1294       logical lprn
1295       evdw=0.0D0
1296 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1297       evdw=0.0D0
1298 c     if (icall.eq.0) then
1299 c       lprn=.true.
1300 c     else
1301         lprn=.false.
1302 c     endif
1303       ind=0
1304       do i=iatsc_s,iatsc_e
1305         itypi=iabs(itype(i))
1306         if (itypi.eq.ntyp1) cycle
1307         itypi1=iabs(itype(i+1))
1308         xi=c(1,nres+i)
1309         yi=c(2,nres+i)
1310         zi=c(3,nres+i)
1311         dxi=dc_norm(1,nres+i)
1312         dyi=dc_norm(2,nres+i)
1313         dzi=dc_norm(3,nres+i)
1314 c        dsci_inv=dsc_inv(itypi)
1315         dsci_inv=vbld_inv(i+nres)
1316 C
1317 C Calculate SC interaction energy.
1318 C
1319         do iint=1,nint_gr(i)
1320           do j=istart(i,iint),iend(i,iint)
1321             ind=ind+1
1322             itypj=iabs(itype(j))
1323             if (itypj.eq.ntyp1) cycle
1324 c            dscj_inv=dsc_inv(itypj)
1325             dscj_inv=vbld_inv(j+nres)
1326             chi1=chi(itypi,itypj)
1327             chi2=chi(itypj,itypi)
1328             chi12=chi1*chi2
1329             chip1=chip(itypi)
1330             chip2=chip(itypj)
1331             chip12=chip1*chip2
1332             alf1=alp(itypi)
1333             alf2=alp(itypj)
1334             alf12=0.5D0*(alf1+alf2)
1335 C For diagnostics only!!!
1336 c           chi1=0.0D0
1337 c           chi2=0.0D0
1338 c           chi12=0.0D0
1339 c           chip1=0.0D0
1340 c           chip2=0.0D0
1341 c           chip12=0.0D0
1342 c           alf1=0.0D0
1343 c           alf2=0.0D0
1344 c           alf12=0.0D0
1345             xj=c(1,nres+j)-xi
1346             yj=c(2,nres+j)-yi
1347             zj=c(3,nres+j)-zi
1348             dxj=dc_norm(1,nres+j)
1349             dyj=dc_norm(2,nres+j)
1350             dzj=dc_norm(3,nres+j)
1351             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1352 cd          if (icall.eq.0) then
1353 cd            rrsave(ind)=rrij
1354 cd          else
1355 cd            rrij=rrsave(ind)
1356 cd          endif
1357             rij=dsqrt(rrij)
1358 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1359             call sc_angular
1360 C Calculate whole angle-dependent part of epsilon and contributions
1361 C to its derivatives
1362             fac=(rrij*sigsq)**expon2
1363             e1=fac*fac*aa(itypi,itypj)
1364             e2=fac*bb(itypi,itypj)
1365             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1366             eps2der=evdwij*eps3rt
1367             eps3der=evdwij*eps2rt
1368             evdwij=evdwij*eps2rt*eps3rt
1369             evdw=evdw+evdwij
1370             if (lprn) then
1371             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1372             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1373 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1374 cd     &        restyp(itypi),i,restyp(itypj),j,
1375 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1376 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1377 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1378 cd     &        evdwij
1379             endif
1380 C Calculate gradient components.
1381             e1=e1*eps1*eps2rt**2*eps3rt**2
1382             fac=-expon*(e1+evdwij)
1383             sigder=fac/sigsq
1384             fac=rrij*fac
1385 C Calculate radial part of the gradient
1386             gg(1)=xj*fac
1387             gg(2)=yj*fac
1388             gg(3)=zj*fac
1389 C Calculate the angular part of the gradient and sum add the contributions
1390 C to the appropriate components of the Cartesian gradient.
1391             call sc_grad
1392           enddo      ! j
1393         enddo        ! iint
1394       enddo          ! i
1395 c     stop
1396       return
1397       end
1398 C-----------------------------------------------------------------------------
1399       subroutine egb(evdw)
1400 C
1401 C This subroutine calculates the interaction energy of nonbonded side chains
1402 C assuming the Gay-Berne potential of interaction.
1403 C
1404       implicit real*8 (a-h,o-z)
1405       include 'DIMENSIONS'
1406       include 'COMMON.GEO'
1407       include 'COMMON.VAR'
1408       include 'COMMON.LOCAL'
1409       include 'COMMON.CHAIN'
1410       include 'COMMON.DERIV'
1411       include 'COMMON.NAMES'
1412       include 'COMMON.INTERACT'
1413       include 'COMMON.IOUNITS'
1414       include 'COMMON.CALC'
1415       include 'COMMON.CONTROL'
1416       include 'COMMON.SPLITELE'
1417       logical lprn
1418       integer xshift,yshift,zshift
1419       evdw=0.0D0
1420 ccccc      energy_dec=.false.
1421 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1422       evdw=0.0D0
1423       lprn=.false.
1424 c     if (icall.eq.0) lprn=.false.
1425       ind=0
1426 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1427 C we have the original box)
1428       do xshift=-1,1
1429       do yshift=-1,1
1430       do zshift=-1,1
1431       do i=iatsc_s,iatsc_e
1432         itypi=iabs(itype(i))
1433         if (itypi.eq.ntyp1) cycle
1434         itypi1=iabs(itype(i+1))
1435         xi=c(1,nres+i)
1436         yi=c(2,nres+i)
1437         zi=c(3,nres+i)
1438 C Return atom into box, boxxsize is size of box in x dimension
1439   134   continue
1440         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1441         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1442 C Condition for being inside the proper box
1443         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1444      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1445         go to 134
1446         endif
1447   135   continue
1448         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1449         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1450 C Condition for being inside the proper box
1451         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1452      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1453         go to 135
1454         endif
1455   136   continue
1456         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1457         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1458 C Condition for being inside the proper box
1459         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1460      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1461         go to 136
1462         endif
1463
1464         dxi=dc_norm(1,nres+i)
1465         dyi=dc_norm(2,nres+i)
1466         dzi=dc_norm(3,nres+i)
1467 c        dsci_inv=dsc_inv(itypi)
1468         dsci_inv=vbld_inv(i+nres)
1469 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1470 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1471 C
1472 C Calculate SC interaction energy.
1473 C
1474         do iint=1,nint_gr(i)
1475           do j=istart(i,iint),iend(i,iint)
1476             ind=ind+1
1477             itypj=iabs(itype(j))
1478             if (itypj.eq.ntyp1) cycle
1479 c            dscj_inv=dsc_inv(itypj)
1480             dscj_inv=vbld_inv(j+nres)
1481 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1482 c     &       1.0d0/vbld(j+nres)
1483 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1484             sig0ij=sigma(itypi,itypj)
1485             chi1=chi(itypi,itypj)
1486             chi2=chi(itypj,itypi)
1487             chi12=chi1*chi2
1488             chip1=chip(itypi)
1489             chip2=chip(itypj)
1490             chip12=chip1*chip2
1491             alf1=alp(itypi)
1492             alf2=alp(itypj)
1493             alf12=0.5D0*(alf1+alf2)
1494 C For diagnostics only!!!
1495 c           chi1=0.0D0
1496 c           chi2=0.0D0
1497 c           chi12=0.0D0
1498 c           chip1=0.0D0
1499 c           chip2=0.0D0
1500 c           chip12=0.0D0
1501 c           alf1=0.0D0
1502 c           alf2=0.0D0
1503 c           alf12=0.0D0
1504             xj=c(1,nres+j)
1505             yj=c(2,nres+j)
1506             zj=c(3,nres+j)
1507 C Return atom J into box the original box
1508   137   continue
1509         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1510         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1511 C Condition for being inside the proper box
1512         if ((xj.gt.((0.5d0)*boxxsize)).or.
1513      &       (xj.lt.((-0.5d0)*boxxsize))) then
1514         go to 137
1515         endif
1516   138   continue
1517         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1518         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1519 C Condition for being inside the proper box
1520         if ((yj.gt.((0.5d0)*boxysize)).or.
1521      &       (yj.lt.((-0.5d0)*boxysize))) then
1522         go to 138
1523         endif
1524   139   continue
1525         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1526         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1527 C Condition for being inside the proper box
1528         if ((zj.gt.((0.5d0)*boxzsize)).or.
1529      &       (zj.lt.((-0.5d0)*boxzsize))) then
1530         go to 139
1531         endif
1532
1533             dxj=dc_norm(1,nres+j)
1534             dyj=dc_norm(2,nres+j)
1535             dzj=dc_norm(3,nres+j)
1536             xj=xj-xi
1537             yj=yj-yi
1538             zj=zj-zi
1539 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1540 c            write (iout,*) "j",j," dc_norm",
1541 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1542             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1543             rij=dsqrt(rrij)
1544             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1545             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1546
1547 c            write (iout,'(a7,4f8.3)')
1548 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1549             if (sss.gt.0.0d0) then
1550 C Calculate angle-dependent terms of energy and contributions to their
1551 C derivatives.
1552             call sc_angular
1553             sigsq=1.0D0/sigsq
1554             sig=sig0ij*dsqrt(sigsq)
1555             rij_shift=1.0D0/rij-sig+sig0ij
1556 c for diagnostics; uncomment
1557 c            rij_shift=1.2*sig0ij
1558 C I hate to put IF's in the loops, but here don't have another choice!!!!
1559             if (rij_shift.le.0.0D0) then
1560               evdw=1.0D20
1561 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1562 cd     &        restyp(itypi),i,restyp(itypj),j,
1563 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1564               return
1565             endif
1566             sigder=-sig*sigsq
1567 c---------------------------------------------------------------
1568             rij_shift=1.0D0/rij_shift
1569             fac=rij_shift**expon
1570             e1=fac*fac*aa(itypi,itypj)
1571             e2=fac*bb(itypi,itypj)
1572             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1573             eps2der=evdwij*eps3rt
1574             eps3der=evdwij*eps2rt
1575 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1576 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1577             evdwij=evdwij*eps2rt*eps3rt
1578             evdw=evdw+evdwij*sss
1579             if (lprn) then
1580             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1581             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1582             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1583      &        restyp(itypi),i,restyp(itypj),j,
1584      &        epsi,sigm,chi1,chi2,chip1,chip2,
1585      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1586      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1587      &        evdwij
1588             endif
1589
1590             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1591      &                        'evdw',i,j,evdwij
1592
1593 C Calculate gradient components.
1594             e1=e1*eps1*eps2rt**2*eps3rt**2
1595             fac=-expon*(e1+evdwij)*rij_shift
1596             sigder=fac*sigder
1597             fac=rij*fac
1598 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1599 c     &      evdwij,fac,sigma(itypi,itypj),expon
1600             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1601 c            fac=0.0d0
1602 C Calculate the radial part of the gradient
1603             gg(1)=xj*fac
1604             gg(2)=yj*fac
1605             gg(3)=zj*fac
1606 C Calculate angular part of the gradient.
1607             call sc_grad
1608             endif
1609           enddo      ! j
1610         enddo        ! iint
1611       enddo          ! i
1612       enddo          ! zshift
1613       enddo          ! yshift
1614       enddo          ! xshift
1615 c      write (iout,*) "Number of loop steps in EGB:",ind
1616 cccc      energy_dec=.false.
1617       return
1618       end
1619 C-----------------------------------------------------------------------------
1620       subroutine egbv(evdw)
1621 C
1622 C This subroutine calculates the interaction energy of nonbonded side chains
1623 C assuming the Gay-Berne-Vorobjev potential of interaction.
1624 C
1625       implicit real*8 (a-h,o-z)
1626       include 'DIMENSIONS'
1627       include 'COMMON.GEO'
1628       include 'COMMON.VAR'
1629       include 'COMMON.LOCAL'
1630       include 'COMMON.CHAIN'
1631       include 'COMMON.DERIV'
1632       include 'COMMON.NAMES'
1633       include 'COMMON.INTERACT'
1634       include 'COMMON.IOUNITS'
1635       include 'COMMON.CALC'
1636       common /srutu/ icall
1637       logical lprn
1638       evdw=0.0D0
1639 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1640       evdw=0.0D0
1641       lprn=.false.
1642 c     if (icall.eq.0) lprn=.true.
1643       ind=0
1644       do i=iatsc_s,iatsc_e
1645         itypi=iabs(itype(i))
1646         if (itypi.eq.ntyp1) cycle
1647         itypi1=iabs(itype(i+1))
1648         xi=c(1,nres+i)
1649         yi=c(2,nres+i)
1650         zi=c(3,nres+i)
1651         dxi=dc_norm(1,nres+i)
1652         dyi=dc_norm(2,nres+i)
1653         dzi=dc_norm(3,nres+i)
1654 c        dsci_inv=dsc_inv(itypi)
1655         dsci_inv=vbld_inv(i+nres)
1656 C
1657 C Calculate SC interaction energy.
1658 C
1659         do iint=1,nint_gr(i)
1660           do j=istart(i,iint),iend(i,iint)
1661             ind=ind+1
1662             itypj=iabs(itype(j))
1663             if (itypj.eq.ntyp1) cycle
1664 c            dscj_inv=dsc_inv(itypj)
1665             dscj_inv=vbld_inv(j+nres)
1666             sig0ij=sigma(itypi,itypj)
1667             r0ij=r0(itypi,itypj)
1668             chi1=chi(itypi,itypj)
1669             chi2=chi(itypj,itypi)
1670             chi12=chi1*chi2
1671             chip1=chip(itypi)
1672             chip2=chip(itypj)
1673             chip12=chip1*chip2
1674             alf1=alp(itypi)
1675             alf2=alp(itypj)
1676             alf12=0.5D0*(alf1+alf2)
1677 C For diagnostics only!!!
1678 c           chi1=0.0D0
1679 c           chi2=0.0D0
1680 c           chi12=0.0D0
1681 c           chip1=0.0D0
1682 c           chip2=0.0D0
1683 c           chip12=0.0D0
1684 c           alf1=0.0D0
1685 c           alf2=0.0D0
1686 c           alf12=0.0D0
1687             xj=c(1,nres+j)-xi
1688             yj=c(2,nres+j)-yi
1689             zj=c(3,nres+j)-zi
1690             dxj=dc_norm(1,nres+j)
1691             dyj=dc_norm(2,nres+j)
1692             dzj=dc_norm(3,nres+j)
1693             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1694             rij=dsqrt(rrij)
1695 C Calculate angle-dependent terms of energy and contributions to their
1696 C derivatives.
1697             call sc_angular
1698             sigsq=1.0D0/sigsq
1699             sig=sig0ij*dsqrt(sigsq)
1700             rij_shift=1.0D0/rij-sig+r0ij
1701 C I hate to put IF's in the loops, but here don't have another choice!!!!
1702             if (rij_shift.le.0.0D0) then
1703               evdw=1.0D20
1704               return
1705             endif
1706             sigder=-sig*sigsq
1707 c---------------------------------------------------------------
1708             rij_shift=1.0D0/rij_shift
1709             fac=rij_shift**expon
1710             e1=fac*fac*aa(itypi,itypj)
1711             e2=fac*bb(itypi,itypj)
1712             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1713             eps2der=evdwij*eps3rt
1714             eps3der=evdwij*eps2rt
1715             fac_augm=rrij**expon
1716             e_augm=augm(itypi,itypj)*fac_augm
1717             evdwij=evdwij*eps2rt*eps3rt
1718             evdw=evdw+evdwij+e_augm
1719             if (lprn) then
1720             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1721             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1722             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1723      &        restyp(itypi),i,restyp(itypj),j,
1724      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1725      &        chi1,chi2,chip1,chip2,
1726      &        eps1,eps2rt**2,eps3rt**2,
1727      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1728      &        evdwij+e_augm
1729             endif
1730 C Calculate gradient components.
1731             e1=e1*eps1*eps2rt**2*eps3rt**2
1732             fac=-expon*(e1+evdwij)*rij_shift
1733             sigder=fac*sigder
1734             fac=rij*fac-2*expon*rrij*e_augm
1735 C Calculate the radial part of the gradient
1736             gg(1)=xj*fac
1737             gg(2)=yj*fac
1738             gg(3)=zj*fac
1739 C Calculate angular part of the gradient.
1740             call sc_grad
1741           enddo      ! j
1742         enddo        ! iint
1743       enddo          ! i
1744       end
1745 C-----------------------------------------------------------------------------
1746       subroutine sc_angular
1747 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1748 C om12. Called by ebp, egb, and egbv.
1749       implicit none
1750       include 'COMMON.CALC'
1751       include 'COMMON.IOUNITS'
1752       erij(1)=xj*rij
1753       erij(2)=yj*rij
1754       erij(3)=zj*rij
1755       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1756       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1757       om12=dxi*dxj+dyi*dyj+dzi*dzj
1758       chiom12=chi12*om12
1759 C Calculate eps1(om12) and its derivative in om12
1760       faceps1=1.0D0-om12*chiom12
1761       faceps1_inv=1.0D0/faceps1
1762       eps1=dsqrt(faceps1_inv)
1763 C Following variable is eps1*deps1/dom12
1764       eps1_om12=faceps1_inv*chiom12
1765 c diagnostics only
1766 c      faceps1_inv=om12
1767 c      eps1=om12
1768 c      eps1_om12=1.0d0
1769 c      write (iout,*) "om12",om12," eps1",eps1
1770 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1771 C and om12.
1772       om1om2=om1*om2
1773       chiom1=chi1*om1
1774       chiom2=chi2*om2
1775       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1776       sigsq=1.0D0-facsig*faceps1_inv
1777       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1778       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1779       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1780 c diagnostics only
1781 c      sigsq=1.0d0
1782 c      sigsq_om1=0.0d0
1783 c      sigsq_om2=0.0d0
1784 c      sigsq_om12=0.0d0
1785 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1786 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1787 c     &    " eps1",eps1
1788 C Calculate eps2 and its derivatives in om1, om2, and om12.
1789       chipom1=chip1*om1
1790       chipom2=chip2*om2
1791       chipom12=chip12*om12
1792       facp=1.0D0-om12*chipom12
1793       facp_inv=1.0D0/facp
1794       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1795 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1796 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1797 C Following variable is the square root of eps2
1798       eps2rt=1.0D0-facp1*facp_inv
1799 C Following three variables are the derivatives of the square root of eps
1800 C in om1, om2, and om12.
1801       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1802       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1803       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1804 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1805       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1806 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1807 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1808 c     &  " eps2rt_om12",eps2rt_om12
1809 C Calculate whole angle-dependent part of epsilon and contributions
1810 C to its derivatives
1811       return
1812       end
1813 C----------------------------------------------------------------------------
1814       subroutine sc_grad
1815       implicit real*8 (a-h,o-z)
1816       include 'DIMENSIONS'
1817       include 'COMMON.CHAIN'
1818       include 'COMMON.DERIV'
1819       include 'COMMON.CALC'
1820       include 'COMMON.IOUNITS'
1821       double precision dcosom1(3),dcosom2(3)
1822 cc      print *,'sss=',sss
1823       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1824       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1825       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1826      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1827 c diagnostics only
1828 c      eom1=0.0d0
1829 c      eom2=0.0d0
1830 c      eom12=evdwij*eps1_om12
1831 c end diagnostics
1832 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1833 c     &  " sigder",sigder
1834 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1835 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1836       do k=1,3
1837         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1838         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1839       enddo
1840       do k=1,3
1841         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1842       enddo
1843 c      write (iout,*) "gg",(gg(k),k=1,3)
1844       do k=1,3
1845         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1846      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1847      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1848         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1849      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1850      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1851 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1852 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1853 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1854 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1855       enddo
1856 C
1857 C Calculate the components of the gradient in DC and X
1858 C
1859 cgrad      do k=i,j-1
1860 cgrad        do l=1,3
1861 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1862 cgrad        enddo
1863 cgrad      enddo
1864       do l=1,3
1865         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1866         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1867       enddo
1868       return
1869       end
1870 C-----------------------------------------------------------------------
1871       subroutine e_softsphere(evdw)
1872 C
1873 C This subroutine calculates the interaction energy of nonbonded side chains
1874 C assuming the LJ potential of interaction.
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       parameter (accur=1.0d-10)
1879       include 'COMMON.GEO'
1880       include 'COMMON.VAR'
1881       include 'COMMON.LOCAL'
1882       include 'COMMON.CHAIN'
1883       include 'COMMON.DERIV'
1884       include 'COMMON.INTERACT'
1885       include 'COMMON.TORSION'
1886       include 'COMMON.SBRIDGE'
1887       include 'COMMON.NAMES'
1888       include 'COMMON.IOUNITS'
1889       include 'COMMON.CONTACTS'
1890       dimension gg(3)
1891 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1892       evdw=0.0D0
1893       do i=iatsc_s,iatsc_e
1894         itypi=iabs(itype(i))
1895         if (itypi.eq.ntyp1) cycle
1896         itypi1=iabs(itype(i+1))
1897         xi=c(1,nres+i)
1898         yi=c(2,nres+i)
1899         zi=c(3,nres+i)
1900 C
1901 C Calculate SC interaction energy.
1902 C
1903         do iint=1,nint_gr(i)
1904 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1905 cd   &                  'iend=',iend(i,iint)
1906           do j=istart(i,iint),iend(i,iint)
1907             itypj=iabs(itype(j))
1908             if (itypj.eq.ntyp1) cycle
1909             xj=c(1,nres+j)-xi
1910             yj=c(2,nres+j)-yi
1911             zj=c(3,nres+j)-zi
1912             rij=xj*xj+yj*yj+zj*zj
1913 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1914             r0ij=r0(itypi,itypj)
1915             r0ijsq=r0ij*r0ij
1916 c            print *,i,j,r0ij,dsqrt(rij)
1917             if (rij.lt.r0ijsq) then
1918               evdwij=0.25d0*(rij-r0ijsq)**2
1919               fac=rij-r0ijsq
1920             else
1921               evdwij=0.0d0
1922               fac=0.0d0
1923             endif
1924             evdw=evdw+evdwij
1925 C
1926 C Calculate the components of the gradient in DC and X
1927 C
1928             gg(1)=xj*fac
1929             gg(2)=yj*fac
1930             gg(3)=zj*fac
1931             do k=1,3
1932               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1933               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1934               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1935               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1936             enddo
1937 cgrad            do k=i,j-1
1938 cgrad              do l=1,3
1939 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1940 cgrad              enddo
1941 cgrad            enddo
1942           enddo ! j
1943         enddo ! iint
1944       enddo ! i
1945       return
1946       end
1947 C--------------------------------------------------------------------------
1948       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1949      &              eello_turn4)
1950 C
1951 C Soft-sphere potential of p-p interaction
1952 C
1953       implicit real*8 (a-h,o-z)
1954       include 'DIMENSIONS'
1955       include 'COMMON.CONTROL'
1956       include 'COMMON.IOUNITS'
1957       include 'COMMON.GEO'
1958       include 'COMMON.VAR'
1959       include 'COMMON.LOCAL'
1960       include 'COMMON.CHAIN'
1961       include 'COMMON.DERIV'
1962       include 'COMMON.INTERACT'
1963       include 'COMMON.CONTACTS'
1964       include 'COMMON.TORSION'
1965       include 'COMMON.VECTORS'
1966       include 'COMMON.FFIELD'
1967       dimension ggg(3)
1968 cd      write(iout,*) 'In EELEC_soft_sphere'
1969       ees=0.0D0
1970       evdw1=0.0D0
1971       eel_loc=0.0d0
1972       eello_turn3=0.0d0
1973       eello_turn4=0.0d0
1974       ind=0
1975       do i=iatel_s,iatel_e
1976         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1977         dxi=dc(1,i)
1978         dyi=dc(2,i)
1979         dzi=dc(3,i)
1980         xmedi=c(1,i)+0.5d0*dxi
1981         ymedi=c(2,i)+0.5d0*dyi
1982         zmedi=c(3,i)+0.5d0*dzi
1983         num_conti=0
1984 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1985         do j=ielstart(i),ielend(i)
1986           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1987           ind=ind+1
1988           iteli=itel(i)
1989           itelj=itel(j)
1990           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1991           r0ij=rpp(iteli,itelj)
1992           r0ijsq=r0ij*r0ij
1993           dxj=dc(1,j)
1994           dyj=dc(2,j)
1995           dzj=dc(3,j)
1996           xj=c(1,j)+0.5D0*dxj-xmedi
1997           yj=c(2,j)+0.5D0*dyj-ymedi
1998           zj=c(3,j)+0.5D0*dzj-zmedi
1999           rij=xj*xj+yj*yj+zj*zj
2000           if (rij.lt.r0ijsq) then
2001             evdw1ij=0.25d0*(rij-r0ijsq)**2
2002             fac=rij-r0ijsq
2003           else
2004             evdw1ij=0.0d0
2005             fac=0.0d0
2006           endif
2007           evdw1=evdw1+evdw1ij
2008 C
2009 C Calculate contributions to the Cartesian gradient.
2010 C
2011           ggg(1)=fac*xj
2012           ggg(2)=fac*yj
2013           ggg(3)=fac*zj
2014           do k=1,3
2015             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2016             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2017           enddo
2018 *
2019 * Loop over residues i+1 thru j-1.
2020 *
2021 cgrad          do k=i+1,j-1
2022 cgrad            do l=1,3
2023 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2024 cgrad            enddo
2025 cgrad          enddo
2026         enddo ! j
2027       enddo   ! i
2028 cgrad      do i=nnt,nct-1
2029 cgrad        do k=1,3
2030 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2031 cgrad        enddo
2032 cgrad        do j=i+1,nct-1
2033 cgrad          do k=1,3
2034 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2035 cgrad          enddo
2036 cgrad        enddo
2037 cgrad      enddo
2038       return
2039       end
2040 c------------------------------------------------------------------------------
2041       subroutine vec_and_deriv
2042       implicit real*8 (a-h,o-z)
2043       include 'DIMENSIONS'
2044 #ifdef MPI
2045       include 'mpif.h'
2046 #endif
2047       include 'COMMON.IOUNITS'
2048       include 'COMMON.GEO'
2049       include 'COMMON.VAR'
2050       include 'COMMON.LOCAL'
2051       include 'COMMON.CHAIN'
2052       include 'COMMON.VECTORS'
2053       include 'COMMON.SETUP'
2054       include 'COMMON.TIME1'
2055       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2056 C Compute the local reference systems. For reference system (i), the
2057 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2058 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2059 #ifdef PARVEC
2060       do i=ivec_start,ivec_end
2061 #else
2062       do i=1,nres-1
2063 #endif
2064           if (i.eq.nres-1) then
2065 C Case of the last full residue
2066 C Compute the Z-axis
2067             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2068             costh=dcos(pi-theta(nres))
2069             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2070             do k=1,3
2071               uz(k,i)=fac*uz(k,i)
2072             enddo
2073 C Compute the derivatives of uz
2074             uzder(1,1,1)= 0.0d0
2075             uzder(2,1,1)=-dc_norm(3,i-1)
2076             uzder(3,1,1)= dc_norm(2,i-1)
2077             uzder(1,2,1)= dc_norm(3,i-1)
2078             uzder(2,2,1)= 0.0d0
2079             uzder(3,2,1)=-dc_norm(1,i-1)
2080             uzder(1,3,1)=-dc_norm(2,i-1)
2081             uzder(2,3,1)= dc_norm(1,i-1)
2082             uzder(3,3,1)= 0.0d0
2083             uzder(1,1,2)= 0.0d0
2084             uzder(2,1,2)= dc_norm(3,i)
2085             uzder(3,1,2)=-dc_norm(2,i)
2086             uzder(1,2,2)=-dc_norm(3,i)
2087             uzder(2,2,2)= 0.0d0
2088             uzder(3,2,2)= dc_norm(1,i)
2089             uzder(1,3,2)= dc_norm(2,i)
2090             uzder(2,3,2)=-dc_norm(1,i)
2091             uzder(3,3,2)= 0.0d0
2092 C Compute the Y-axis
2093             facy=fac
2094             do k=1,3
2095               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2096             enddo
2097 C Compute the derivatives of uy
2098             do j=1,3
2099               do k=1,3
2100                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2101      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2102                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2103               enddo
2104               uyder(j,j,1)=uyder(j,j,1)-costh
2105               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2106             enddo
2107             do j=1,2
2108               do k=1,3
2109                 do l=1,3
2110                   uygrad(l,k,j,i)=uyder(l,k,j)
2111                   uzgrad(l,k,j,i)=uzder(l,k,j)
2112                 enddo
2113               enddo
2114             enddo
2115             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2116             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2117             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2118             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2119           else
2120 C Other residues
2121 C Compute the Z-axis
2122             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2123             costh=dcos(pi-theta(i+2))
2124             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2125             do k=1,3
2126               uz(k,i)=fac*uz(k,i)
2127             enddo
2128 C Compute the derivatives of uz
2129             uzder(1,1,1)= 0.0d0
2130             uzder(2,1,1)=-dc_norm(3,i+1)
2131             uzder(3,1,1)= dc_norm(2,i+1)
2132             uzder(1,2,1)= dc_norm(3,i+1)
2133             uzder(2,2,1)= 0.0d0
2134             uzder(3,2,1)=-dc_norm(1,i+1)
2135             uzder(1,3,1)=-dc_norm(2,i+1)
2136             uzder(2,3,1)= dc_norm(1,i+1)
2137             uzder(3,3,1)= 0.0d0
2138             uzder(1,1,2)= 0.0d0
2139             uzder(2,1,2)= dc_norm(3,i)
2140             uzder(3,1,2)=-dc_norm(2,i)
2141             uzder(1,2,2)=-dc_norm(3,i)
2142             uzder(2,2,2)= 0.0d0
2143             uzder(3,2,2)= dc_norm(1,i)
2144             uzder(1,3,2)= dc_norm(2,i)
2145             uzder(2,3,2)=-dc_norm(1,i)
2146             uzder(3,3,2)= 0.0d0
2147 C Compute the Y-axis
2148             facy=fac
2149             do k=1,3
2150               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2151             enddo
2152 C Compute the derivatives of uy
2153             do j=1,3
2154               do k=1,3
2155                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2156      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2157                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2158               enddo
2159               uyder(j,j,1)=uyder(j,j,1)-costh
2160               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2161             enddo
2162             do j=1,2
2163               do k=1,3
2164                 do l=1,3
2165                   uygrad(l,k,j,i)=uyder(l,k,j)
2166                   uzgrad(l,k,j,i)=uzder(l,k,j)
2167                 enddo
2168               enddo
2169             enddo
2170             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2171             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2172             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2173             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2174           endif
2175       enddo
2176       do i=1,nres-1
2177         vbld_inv_temp(1)=vbld_inv(i+1)
2178         if (i.lt.nres-1) then
2179           vbld_inv_temp(2)=vbld_inv(i+2)
2180           else
2181           vbld_inv_temp(2)=vbld_inv(i)
2182           endif
2183         do j=1,2
2184           do k=1,3
2185             do l=1,3
2186               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2187               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2188             enddo
2189           enddo
2190         enddo
2191       enddo
2192 #if defined(PARVEC) && defined(MPI)
2193       if (nfgtasks1.gt.1) then
2194         time00=MPI_Wtime()
2195 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2196 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2197 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2198         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2199      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2200      &   FG_COMM1,IERR)
2201         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2202      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2203      &   FG_COMM1,IERR)
2204         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2205      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2206      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2207         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2208      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2209      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2210         time_gather=time_gather+MPI_Wtime()-time00
2211       endif
2212 c      if (fg_rank.eq.0) then
2213 c        write (iout,*) "Arrays UY and UZ"
2214 c        do i=1,nres-1
2215 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2216 c     &     (uz(k,i),k=1,3)
2217 c        enddo
2218 c      endif
2219 #endif
2220       return
2221       end
2222 C-----------------------------------------------------------------------------
2223       subroutine check_vecgrad
2224       implicit real*8 (a-h,o-z)
2225       include 'DIMENSIONS'
2226       include 'COMMON.IOUNITS'
2227       include 'COMMON.GEO'
2228       include 'COMMON.VAR'
2229       include 'COMMON.LOCAL'
2230       include 'COMMON.CHAIN'
2231       include 'COMMON.VECTORS'
2232       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2233       dimension uyt(3,maxres),uzt(3,maxres)
2234       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2235       double precision delta /1.0d-7/
2236       call vec_and_deriv
2237 cd      do i=1,nres
2238 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2239 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2240 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2241 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2242 cd     &     (dc_norm(if90,i),if90=1,3)
2243 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2244 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2245 cd          write(iout,'(a)')
2246 cd      enddo
2247       do i=1,nres
2248         do j=1,2
2249           do k=1,3
2250             do l=1,3
2251               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2252               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2253             enddo
2254           enddo
2255         enddo
2256       enddo
2257       call vec_and_deriv
2258       do i=1,nres
2259         do j=1,3
2260           uyt(j,i)=uy(j,i)
2261           uzt(j,i)=uz(j,i)
2262         enddo
2263       enddo
2264       do i=1,nres
2265 cd        write (iout,*) 'i=',i
2266         do k=1,3
2267           erij(k)=dc_norm(k,i)
2268         enddo
2269         do j=1,3
2270           do k=1,3
2271             dc_norm(k,i)=erij(k)
2272           enddo
2273           dc_norm(j,i)=dc_norm(j,i)+delta
2274 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2275 c          do k=1,3
2276 c            dc_norm(k,i)=dc_norm(k,i)/fac
2277 c          enddo
2278 c          write (iout,*) (dc_norm(k,i),k=1,3)
2279 c          write (iout,*) (erij(k),k=1,3)
2280           call vec_and_deriv
2281           do k=1,3
2282             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2283             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2284             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2285             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2286           enddo
2287 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2288 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2289 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2290         enddo
2291         do k=1,3
2292           dc_norm(k,i)=erij(k)
2293         enddo
2294 cd        do k=1,3
2295 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2296 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2297 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2298 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2299 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2300 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2301 cd          write (iout,'(a)')
2302 cd        enddo
2303       enddo
2304       return
2305       end
2306 C--------------------------------------------------------------------------
2307       subroutine set_matrices
2308       implicit real*8 (a-h,o-z)
2309       include 'DIMENSIONS'
2310 #ifdef MPI
2311       include "mpif.h"
2312       include "COMMON.SETUP"
2313       integer IERR
2314       integer status(MPI_STATUS_SIZE)
2315 #endif
2316       include 'COMMON.IOUNITS'
2317       include 'COMMON.GEO'
2318       include 'COMMON.VAR'
2319       include 'COMMON.LOCAL'
2320       include 'COMMON.CHAIN'
2321       include 'COMMON.DERIV'
2322       include 'COMMON.INTERACT'
2323       include 'COMMON.CONTACTS'
2324       include 'COMMON.TORSION'
2325       include 'COMMON.VECTORS'
2326       include 'COMMON.FFIELD'
2327       double precision auxvec(2),auxmat(2,2)
2328 C
2329 C Compute the virtual-bond-torsional-angle dependent quantities needed
2330 C to calculate the el-loc multibody terms of various order.
2331 C
2332 #ifdef PARMAT
2333       do i=ivec_start+2,ivec_end+2
2334 #else
2335       do i=3,nres+1
2336 #endif
2337         if (i .lt. nres+1) then
2338           sin1=dsin(phi(i))
2339           cos1=dcos(phi(i))
2340           sintab(i-2)=sin1
2341           costab(i-2)=cos1
2342           obrot(1,i-2)=cos1
2343           obrot(2,i-2)=sin1
2344           sin2=dsin(2*phi(i))
2345           cos2=dcos(2*phi(i))
2346           sintab2(i-2)=sin2
2347           costab2(i-2)=cos2
2348           obrot2(1,i-2)=cos2
2349           obrot2(2,i-2)=sin2
2350           Ug(1,1,i-2)=-cos1
2351           Ug(1,2,i-2)=-sin1
2352           Ug(2,1,i-2)=-sin1
2353           Ug(2,2,i-2)= cos1
2354           Ug2(1,1,i-2)=-cos2
2355           Ug2(1,2,i-2)=-sin2
2356           Ug2(2,1,i-2)=-sin2
2357           Ug2(2,2,i-2)= cos2
2358         else
2359           costab(i-2)=1.0d0
2360           sintab(i-2)=0.0d0
2361           obrot(1,i-2)=1.0d0
2362           obrot(2,i-2)=0.0d0
2363           obrot2(1,i-2)=0.0d0
2364           obrot2(2,i-2)=0.0d0
2365           Ug(1,1,i-2)=1.0d0
2366           Ug(1,2,i-2)=0.0d0
2367           Ug(2,1,i-2)=0.0d0
2368           Ug(2,2,i-2)=1.0d0
2369           Ug2(1,1,i-2)=0.0d0
2370           Ug2(1,2,i-2)=0.0d0
2371           Ug2(2,1,i-2)=0.0d0
2372           Ug2(2,2,i-2)=0.0d0
2373         endif
2374         if (i .gt. 3 .and. i .lt. nres+1) then
2375           obrot_der(1,i-2)=-sin1
2376           obrot_der(2,i-2)= cos1
2377           Ugder(1,1,i-2)= sin1
2378           Ugder(1,2,i-2)=-cos1
2379           Ugder(2,1,i-2)=-cos1
2380           Ugder(2,2,i-2)=-sin1
2381           dwacos2=cos2+cos2
2382           dwasin2=sin2+sin2
2383           obrot2_der(1,i-2)=-dwasin2
2384           obrot2_der(2,i-2)= dwacos2
2385           Ug2der(1,1,i-2)= dwasin2
2386           Ug2der(1,2,i-2)=-dwacos2
2387           Ug2der(2,1,i-2)=-dwacos2
2388           Ug2der(2,2,i-2)=-dwasin2
2389         else
2390           obrot_der(1,i-2)=0.0d0
2391           obrot_der(2,i-2)=0.0d0
2392           Ugder(1,1,i-2)=0.0d0
2393           Ugder(1,2,i-2)=0.0d0
2394           Ugder(2,1,i-2)=0.0d0
2395           Ugder(2,2,i-2)=0.0d0
2396           obrot2_der(1,i-2)=0.0d0
2397           obrot2_der(2,i-2)=0.0d0
2398           Ug2der(1,1,i-2)=0.0d0
2399           Ug2der(1,2,i-2)=0.0d0
2400           Ug2der(2,1,i-2)=0.0d0
2401           Ug2der(2,2,i-2)=0.0d0
2402         endif
2403 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2404         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2405           iti = itortyp(itype(i-2))
2406         else
2407           iti=ntortyp+1
2408         endif
2409 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2410         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2411           iti1 = itortyp(itype(i-1))
2412         else
2413           iti1=ntortyp+1
2414         endif
2415 cd        write (iout,*) '*******i',i,' iti1',iti
2416 cd        write (iout,*) 'b1',b1(:,iti)
2417 cd        write (iout,*) 'b2',b2(:,iti)
2418 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2419 c        if (i .gt. iatel_s+2) then
2420         if (i .gt. nnt+2) then
2421           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2422           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2423           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2424      &    then
2425           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2426           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2427           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2428           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2429           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2430           endif
2431         else
2432           do k=1,2
2433             Ub2(k,i-2)=0.0d0
2434             Ctobr(k,i-2)=0.0d0
2435             Dtobr2(k,i-2)=0.0d0
2436             do l=1,2
2437               EUg(l,k,i-2)=0.0d0
2438               CUg(l,k,i-2)=0.0d0
2439               DUg(l,k,i-2)=0.0d0
2440               DtUg2(l,k,i-2)=0.0d0
2441             enddo
2442           enddo
2443         endif
2444         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2445         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2446         do k=1,2
2447           muder(k,i-2)=Ub2der(k,i-2)
2448         enddo
2449 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2450         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2451           if (itype(i-1).le.ntyp) then
2452             iti1 = itortyp(itype(i-1))
2453           else
2454             iti1=ntortyp+1
2455           endif
2456         else
2457           iti1=ntortyp+1
2458         endif
2459         do k=1,2
2460           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2461         enddo
2462 cd        write (iout,*) 'mu ',mu(:,i-2)
2463 cd        write (iout,*) 'mu1',mu1(:,i-2)
2464 cd        write (iout,*) 'mu2',mu2(:,i-2)
2465         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2466      &  then
2467         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2468         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2469         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2470         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2471         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2472 C Vectors and matrices dependent on a single virtual-bond dihedral.
2473         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2474         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2475         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2476         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2477         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2478         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2479         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2480         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2481         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2482         endif
2483       enddo
2484 C Matrices dependent on two consecutive virtual-bond dihedrals.
2485 C The order of matrices is from left to right.
2486       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2487      &then
2488 c      do i=max0(ivec_start,2),ivec_end
2489       do i=2,nres-1
2490         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2491         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2492         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2493         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2494         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2495         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2496         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2497         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2498       enddo
2499       endif
2500 #if defined(MPI) && defined(PARMAT)
2501 #ifdef DEBUG
2502 c      if (fg_rank.eq.0) then
2503         write (iout,*) "Arrays UG and UGDER before GATHER"
2504         do i=1,nres-1
2505           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2506      &     ((ug(l,k,i),l=1,2),k=1,2),
2507      &     ((ugder(l,k,i),l=1,2),k=1,2)
2508         enddo
2509         write (iout,*) "Arrays UG2 and UG2DER"
2510         do i=1,nres-1
2511           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2512      &     ((ug2(l,k,i),l=1,2),k=1,2),
2513      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2514         enddo
2515         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2516         do i=1,nres-1
2517           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2518      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2519      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2520         enddo
2521         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2522         do i=1,nres-1
2523           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2524      &     costab(i),sintab(i),costab2(i),sintab2(i)
2525         enddo
2526         write (iout,*) "Array MUDER"
2527         do i=1,nres-1
2528           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2529         enddo
2530 c      endif
2531 #endif
2532       if (nfgtasks.gt.1) then
2533         time00=MPI_Wtime()
2534 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2535 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2536 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2537 #ifdef MATGATHER
2538         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2548      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2549      &   FG_COMM1,IERR)
2550         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2552      &   FG_COMM1,IERR)
2553         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2555      &   FG_COMM1,IERR)
2556         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2557      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2558      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2559         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2560      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2561      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2562         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2563      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2564      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2565         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2566      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2567      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2568         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2569      &  then
2570         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2571      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2572      &   FG_COMM1,IERR)
2573         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2574      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2575      &   FG_COMM1,IERR)
2576         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2577      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2578      &   FG_COMM1,IERR)
2579        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2580      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2581      &   FG_COMM1,IERR)
2582         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2583      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2586      &   ivec_count(fg_rank1),
2587      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2593      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2594      &   FG_COMM1,IERR)
2595         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2596      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2597      &   FG_COMM1,IERR)
2598         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2599      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2600      &   FG_COMM1,IERR)
2601         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2602      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2603      &   FG_COMM1,IERR)
2604         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2605      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2606      &   FG_COMM1,IERR)
2607         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2608      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2609      &   FG_COMM1,IERR)
2610         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2611      &   ivec_count(fg_rank1),
2612      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2613      &   FG_COMM1,IERR)
2614         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2615      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2616      &   FG_COMM1,IERR)
2617        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2618      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2619      &   FG_COMM1,IERR)
2620         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2621      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2622      &   FG_COMM1,IERR)
2623        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2624      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2625      &   FG_COMM1,IERR)
2626         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2627      &   ivec_count(fg_rank1),
2628      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2629      &   FG_COMM1,IERR)
2630         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2631      &   ivec_count(fg_rank1),
2632      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2635      &   ivec_count(fg_rank1),
2636      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2637      &   MPI_MAT2,FG_COMM1,IERR)
2638         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2639      &   ivec_count(fg_rank1),
2640      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2641      &   MPI_MAT2,FG_COMM1,IERR)
2642         endif
2643 #else
2644 c Passes matrix info through the ring
2645       isend=fg_rank1
2646       irecv=fg_rank1-1
2647       if (irecv.lt.0) irecv=nfgtasks1-1
2648       iprev=irecv
2649       inext=fg_rank1+1
2650       if (inext.ge.nfgtasks1) inext=0
2651       do i=1,nfgtasks1-1
2652 c        write (iout,*) "isend",isend," irecv",irecv
2653 c        call flush(iout)
2654         lensend=lentyp(isend)
2655         lenrecv=lentyp(irecv)
2656 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2657 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2658 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2659 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2660 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2661 c        write (iout,*) "Gather ROTAT1"
2662 c        call flush(iout)
2663 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2664 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2665 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2666 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2667 c        write (iout,*) "Gather ROTAT2"
2668 c        call flush(iout)
2669         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2670      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2671      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2672      &   iprev,4400+irecv,FG_COMM,status,IERR)
2673 c        write (iout,*) "Gather ROTAT_OLD"
2674 c        call flush(iout)
2675         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2676      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2677      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2678      &   iprev,5500+irecv,FG_COMM,status,IERR)
2679 c        write (iout,*) "Gather PRECOMP11"
2680 c        call flush(iout)
2681         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2682      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2683      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2684      &   iprev,6600+irecv,FG_COMM,status,IERR)
2685 c        write (iout,*) "Gather PRECOMP12"
2686 c        call flush(iout)
2687         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2688      &  then
2689         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2690      &   MPI_ROTAT2(lensend),inext,7700+isend,
2691      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2692      &   iprev,7700+irecv,FG_COMM,status,IERR)
2693 c        write (iout,*) "Gather PRECOMP21"
2694 c        call flush(iout)
2695         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2696      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2697      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2698      &   iprev,8800+irecv,FG_COMM,status,IERR)
2699 c        write (iout,*) "Gather PRECOMP22"
2700 c        call flush(iout)
2701         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2702      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2703      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2704      &   MPI_PRECOMP23(lenrecv),
2705      &   iprev,9900+irecv,FG_COMM,status,IERR)
2706 c        write (iout,*) "Gather PRECOMP23"
2707 c        call flush(iout)
2708         endif
2709         isend=irecv
2710         irecv=irecv-1
2711         if (irecv.lt.0) irecv=nfgtasks1-1
2712       enddo
2713 #endif
2714         time_gather=time_gather+MPI_Wtime()-time00
2715       endif
2716 #ifdef DEBUG
2717 c      if (fg_rank.eq.0) then
2718         write (iout,*) "Arrays UG and UGDER"
2719         do i=1,nres-1
2720           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2721      &     ((ug(l,k,i),l=1,2),k=1,2),
2722      &     ((ugder(l,k,i),l=1,2),k=1,2)
2723         enddo
2724         write (iout,*) "Arrays UG2 and UG2DER"
2725         do i=1,nres-1
2726           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2727      &     ((ug2(l,k,i),l=1,2),k=1,2),
2728      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2729         enddo
2730         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2731         do i=1,nres-1
2732           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2733      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2734      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2735         enddo
2736         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2737         do i=1,nres-1
2738           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2739      &     costab(i),sintab(i),costab2(i),sintab2(i)
2740         enddo
2741         write (iout,*) "Array MUDER"
2742         do i=1,nres-1
2743           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2744         enddo
2745 c      endif
2746 #endif
2747 #endif
2748 cd      do i=1,nres
2749 cd        iti = itortyp(itype(i))
2750 cd        write (iout,*) i
2751 cd        do j=1,2
2752 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2753 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2754 cd        enddo
2755 cd      enddo
2756       return
2757       end
2758 C--------------------------------------------------------------------------
2759       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2760 C
2761 C This subroutine calculates the average interaction energy and its gradient
2762 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2763 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2764 C The potential depends both on the distance of peptide-group centers and on
2765 C the orientation of the CA-CA virtual bonds.
2766 C
2767       implicit real*8 (a-h,o-z)
2768 #ifdef MPI
2769       include 'mpif.h'
2770 #endif
2771       include 'DIMENSIONS'
2772       include 'COMMON.CONTROL'
2773       include 'COMMON.SETUP'
2774       include 'COMMON.IOUNITS'
2775       include 'COMMON.GEO'
2776       include 'COMMON.VAR'
2777       include 'COMMON.LOCAL'
2778       include 'COMMON.CHAIN'
2779       include 'COMMON.DERIV'
2780       include 'COMMON.INTERACT'
2781       include 'COMMON.CONTACTS'
2782       include 'COMMON.TORSION'
2783       include 'COMMON.VECTORS'
2784       include 'COMMON.FFIELD'
2785       include 'COMMON.TIME1'
2786       include 'COMMON.SPLITELE'
2787       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2788      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2789       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2790      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2791       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2792      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2793      &    num_conti,j1,j2
2794 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2795 #ifdef MOMENT
2796       double precision scal_el /1.0d0/
2797 #else
2798       double precision scal_el /0.5d0/
2799 #endif
2800 C 12/13/98
2801 C 13-go grudnia roku pamietnego...
2802       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2803      &                   0.0d0,1.0d0,0.0d0,
2804      &                   0.0d0,0.0d0,1.0d0/
2805 cd      write(iout,*) 'In EELEC'
2806 cd      do i=1,nloctyp
2807 cd        write(iout,*) 'Type',i
2808 cd        write(iout,*) 'B1',B1(:,i)
2809 cd        write(iout,*) 'B2',B2(:,i)
2810 cd        write(iout,*) 'CC',CC(:,:,i)
2811 cd        write(iout,*) 'DD',DD(:,:,i)
2812 cd        write(iout,*) 'EE',EE(:,:,i)
2813 cd      enddo
2814 cd      call check_vecgrad
2815 cd      stop
2816       if (icheckgrad.eq.1) then
2817         do i=1,nres-1
2818           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2819           do k=1,3
2820             dc_norm(k,i)=dc(k,i)*fac
2821           enddo
2822 c          write (iout,*) 'i',i,' fac',fac
2823         enddo
2824       endif
2825       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2826      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2827      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2828 c        call vec_and_deriv
2829 #ifdef TIMING
2830         time01=MPI_Wtime()
2831 #endif
2832         call set_matrices
2833 #ifdef TIMING
2834         time_mat=time_mat+MPI_Wtime()-time01
2835 #endif
2836       endif
2837 cd      do i=1,nres-1
2838 cd        write (iout,*) 'i=',i
2839 cd        do k=1,3
2840 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2841 cd        enddo
2842 cd        do k=1,3
2843 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2844 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2845 cd        enddo
2846 cd      enddo
2847       t_eelecij=0.0d0
2848       ees=0.0D0
2849       evdw1=0.0D0
2850       eel_loc=0.0d0
2851       eello_turn3=0.0d0
2852       eello_turn4=0.0d0
2853       ind=0
2854       do i=1,nres
2855         num_cont_hb(i)=0
2856       enddo
2857 cd      print '(a)','Enter EELEC'
2858 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2859       do i=1,nres
2860         gel_loc_loc(i)=0.0d0
2861         gcorr_loc(i)=0.0d0
2862       enddo
2863 c
2864 c
2865 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2866 C
2867 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2868 C
2869 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2870       do i=iturn3_start,iturn3_end
2871         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2872      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2873         dxi=dc(1,i)
2874         dyi=dc(2,i)
2875         dzi=dc(3,i)
2876         dx_normi=dc_norm(1,i)
2877         dy_normi=dc_norm(2,i)
2878         dz_normi=dc_norm(3,i)
2879         xmedi=c(1,i)+0.5d0*dxi
2880         ymedi=c(2,i)+0.5d0*dyi
2881         zmedi=c(3,i)+0.5d0*dzi
2882 C Return atom into box, boxxsize is size of box in x dimension
2883   184   continue
2884         if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2885         if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2886 C Condition for being inside the proper box
2887         if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2888      &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2889         go to 184
2890         endif
2891   185   continue
2892         if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2893         if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2894 C Condition for being inside the proper box
2895         if ((ymedi.gt.((0.5d0)*boxysize)).or.
2896      &       (ymedi.lt.((-0.5d0)*boxysize))) then
2897         go to 185
2898         endif
2899   186   continue
2900         if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2901         if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2902 C Condition for being inside the proper box
2903         if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2904      &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2905         go to 186
2906         endif
2907         num_conti=0
2908         call eelecij(i,i+2,ees,evdw1,eel_loc)
2909         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2910         num_cont_hb(i)=num_conti
2911       enddo
2912       do i=iturn4_start,iturn4_end
2913         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2914      &    .or. itype(i+3).eq.ntyp1
2915      &    .or. itype(i+4).eq.ntyp1) cycle
2916         dxi=dc(1,i)
2917         dyi=dc(2,i)
2918         dzi=dc(3,i)
2919         dx_normi=dc_norm(1,i)
2920         dy_normi=dc_norm(2,i)
2921         dz_normi=dc_norm(3,i)
2922         xmedi=c(1,i)+0.5d0*dxi
2923         ymedi=c(2,i)+0.5d0*dyi
2924         zmedi=c(3,i)+0.5d0*dzi
2925 C Return atom into box, boxxsize is size of box in x dimension
2926   194   continue
2927         if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2928         if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2929 C Condition for being inside the proper box
2930         if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2931      &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2932         go to 194
2933         endif
2934   195   continue
2935         if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2936         if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2937 C Condition for being inside the proper box
2938         if ((ymedi.gt.((0.5d0)*boxysize)).or.
2939      &       (ymedi.lt.((-0.5d0)*boxysize))) then
2940         go to 195
2941         endif
2942   196   continue
2943         if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2944         if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2945 C Condition for being inside the proper box
2946         if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2947      &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2948         go to 196
2949         endif
2950
2951         num_conti=num_cont_hb(i)
2952         call eelecij(i,i+3,ees,evdw1,eel_loc)
2953         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2954      &   call eturn4(i,eello_turn4)
2955         num_cont_hb(i)=num_conti
2956       enddo   ! i
2957 C Loop over all neighbouring boxes
2958       do xshift=-1,1
2959       do yshift=-1,1
2960       do zshift=-1,1
2961 c
2962 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2963 c
2964       do i=iatel_s,iatel_e
2965         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2966         dxi=dc(1,i)
2967         dyi=dc(2,i)
2968         dzi=dc(3,i)
2969         dx_normi=dc_norm(1,i)
2970         dy_normi=dc_norm(2,i)
2971         dz_normi=dc_norm(3,i)
2972         xmedi=c(1,i)+0.5d0*dxi
2973         ymedi=c(2,i)+0.5d0*dyi
2974         zmedi=c(3,i)+0.5d0*dzi
2975 C Return atom into box, boxxsize is size of box in x dimension
2976   164   continue
2977         if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2978         if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2979 C Condition for being inside the proper box
2980         if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2981      &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2982         go to 164
2983         endif
2984   165   continue
2985         if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2986         if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2987 C Condition for being inside the proper box
2988         if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2989      &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2990         go to 165
2991         endif
2992   166   continue
2993         if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2994         if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2995 C Condition for being inside the proper box
2996         if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2997      &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2998         go to 166
2999         endif
3000
3001 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3002         num_conti=num_cont_hb(i)
3003         do j=ielstart(i),ielend(i)
3004 c          write (iout,*) i,j,itype(i),itype(j)
3005           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
3006           call eelecij(i,j,ees,evdw1,eel_loc)
3007         enddo ! j
3008         num_cont_hb(i)=num_conti
3009       enddo   ! i
3010       enddo   ! zshift
3011       enddo   ! yshift
3012       enddo   ! xshift
3013
3014 c      write (iout,*) "Number of loop steps in EELEC:",ind
3015 cd      do i=1,nres
3016 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3017 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3018 cd      enddo
3019 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3020 ccc      eel_loc=eel_loc+eello_turn3
3021 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3022       return
3023       end
3024 C-------------------------------------------------------------------------------
3025       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3026       implicit real*8 (a-h,o-z)
3027       include 'DIMENSIONS'
3028 #ifdef MPI
3029       include "mpif.h"
3030 #endif
3031       include 'COMMON.CONTROL'
3032       include 'COMMON.IOUNITS'
3033       include 'COMMON.GEO'
3034       include 'COMMON.VAR'
3035       include 'COMMON.LOCAL'
3036       include 'COMMON.CHAIN'
3037       include 'COMMON.DERIV'
3038       include 'COMMON.INTERACT'
3039       include 'COMMON.CONTACTS'
3040       include 'COMMON.TORSION'
3041       include 'COMMON.VECTORS'
3042       include 'COMMON.FFIELD'
3043       include 'COMMON.TIME1'
3044       include 'COMMON.SPLITELE'
3045       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3046      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3047       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3048      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3049       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3050      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3051      &    num_conti,j1,j2
3052 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3053 #ifdef MOMENT
3054       double precision scal_el /1.0d0/
3055 #else
3056       double precision scal_el /0.5d0/
3057 #endif
3058 C 12/13/98
3059 C 13-go grudnia roku pamietnego...
3060       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3061      &                   0.0d0,1.0d0,0.0d0,
3062      &                   0.0d0,0.0d0,1.0d0/
3063 c          time00=MPI_Wtime()
3064 cd      write (iout,*) "eelecij",i,j
3065 c          ind=ind+1
3066           iteli=itel(i)
3067           itelj=itel(j)
3068           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3069           aaa=app(iteli,itelj)
3070           bbb=bpp(iteli,itelj)
3071           ael6i=ael6(iteli,itelj)
3072           ael3i=ael3(iteli,itelj)
3073           dxj=dc(1,j)
3074           dyj=dc(2,j)
3075           dzj=dc(3,j)
3076           dx_normj=dc_norm(1,j)
3077           dy_normj=dc_norm(2,j)
3078           dz_normj=dc_norm(3,j)
3079 C          xj=c(1,j)+0.5D0*dxj-xmedi
3080 C          yj=c(2,j)+0.5D0*dyj-ymedi
3081 C          zj=c(3,j)+0.5D0*dzj-zmedi
3082           xj=c(1,j)+0.5D0*dxj
3083           yj=c(2,j)+0.5D0*dyj
3084           zj=c(3,j)+0.5D0*dzj
3085 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3086   174   continue
3087         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3088         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3089 C Condition for being inside the proper box
3090         if ((xj.gt.((0.5d0)*boxxsize)).or.
3091      &       (xj.lt.((-0.5d0)*boxxsize))) then
3092         go to 174
3093         endif
3094   175   continue
3095         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3096         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3097 C Condition for being inside the proper box
3098         if ((yj.gt.((0.5d0)*boxysize)).or.
3099      &       (yj.lt.((-0.5d0)*boxysize))) then
3100         go to 175
3101         endif
3102   176   continue
3103         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3104         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3105 C Condition for being inside the proper box
3106         if ((zj.gt.((0.5d0)*boxzsize)).or.
3107      &       (zj.lt.((-0.5d0)*boxzsize))) then
3108         go to 176
3109         endif
3110 C        endif !endPBC condintion
3111         xj=xj-xmedi
3112         yj=yj-ymedi
3113         zj=zj-zmedi
3114           rij=xj*xj+yj*yj+zj*zj
3115
3116             sss=sscale(sqrt(rij))
3117             sssgrad=sscagrad(sqrt(rij))
3118 c            if (sss.gt.0.0d0) then
3119           rrmij=1.0D0/rij
3120           rij=dsqrt(rij)
3121           rmij=1.0D0/rij
3122           r3ij=rrmij*rmij
3123           r6ij=r3ij*r3ij
3124           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3125           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3126           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3127           fac=cosa-3.0D0*cosb*cosg
3128           ev1=aaa*r6ij*r6ij
3129 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3130           if (j.eq.i+2) ev1=scal_el*ev1
3131           ev2=bbb*r6ij
3132           fac3=ael6i*r6ij
3133           fac4=ael3i*r3ij
3134           evdwij=(ev1+ev2)
3135           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3136           el2=fac4*fac
3137 C MARYSIA
3138           eesij=(el1+el2)
3139 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3140           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3141           ees=ees+eesij
3142           evdw1=evdw1+evdwij*sss
3143 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3144 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3145 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3146 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3147
3148           if (energy_dec) then
3149               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3150      &'evdw1',i,j,evdwij
3151      &,iteli,itelj,aaa,evdw1
3152               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3153           endif
3154
3155 C
3156 C Calculate contributions to the Cartesian gradient.
3157 C
3158 #ifdef SPLITELE
3159           facvdw=-6*rrmij*(ev1+evdwij)*sss
3160           facel=-3*rrmij*(el1+eesij)
3161           fac1=fac
3162           erij(1)=xj*rmij
3163           erij(2)=yj*rmij
3164           erij(3)=zj*rmij
3165 *
3166 * Radial derivatives. First process both termini of the fragment (i,j)
3167 *
3168           ggg(1)=facel*xj
3169           ggg(2)=facel*yj
3170           ggg(3)=facel*zj
3171 c          do k=1,3
3172 c            ghalf=0.5D0*ggg(k)
3173 c            gelc(k,i)=gelc(k,i)+ghalf
3174 c            gelc(k,j)=gelc(k,j)+ghalf
3175 c          enddo
3176 c 9/28/08 AL Gradient compotents will be summed only at the end
3177           do k=1,3
3178             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3179             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3180           enddo
3181 *
3182 * Loop over residues i+1 thru j-1.
3183 *
3184 cgrad          do k=i+1,j-1
3185 cgrad            do l=1,3
3186 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3187 cgrad            enddo
3188 cgrad          enddo
3189           ggg(1)=facvdw*xj
3190           ggg(2)=facvdw*yj
3191           ggg(3)=facvdw*zj
3192 c          do k=1,3
3193 c            ghalf=0.5D0*ggg(k)
3194 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3195 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3196 c          enddo
3197 c 9/28/08 AL Gradient compotents will be summed only at the end
3198           do k=1,3
3199             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3200             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3201           enddo
3202 *
3203 * Loop over residues i+1 thru j-1.
3204 *
3205 cgrad          do k=i+1,j-1
3206 cgrad            do l=1,3
3207 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3208 cgrad            enddo
3209 cgrad          enddo
3210 #else
3211 C MARYSIA
3212           facvdw=(ev1+evdwij)*sss
3213           facel=(el1+eesij)
3214           fac1=fac
3215           fac=-3*rrmij*(facvdw+facvdw+facel)+sssgrad*rmij*evdwij
3216           erij(1)=xj*rmij
3217           erij(2)=yj*rmij
3218           erij(3)=zj*rmij
3219 *
3220 * Radial derivatives. First process both termini of the fragment (i,j)
3221 *
3222           ggg(1)=fac*xj
3223           ggg(2)=fac*yj
3224           ggg(3)=fac*zj
3225 c          do k=1,3
3226 c            ghalf=0.5D0*ggg(k)
3227 c            gelc(k,i)=gelc(k,i)+ghalf
3228 c            gelc(k,j)=gelc(k,j)+ghalf
3229 c          enddo
3230 c 9/28/08 AL Gradient compotents will be summed only at the end
3231           do k=1,3
3232             gelc_long(k,j)=gelc(k,j)+ggg(k)
3233             gelc_long(k,i)=gelc(k,i)-ggg(k)
3234           enddo
3235 *
3236 * Loop over residues i+1 thru j-1.
3237 *
3238 cgrad          do k=i+1,j-1
3239 cgrad            do l=1,3
3240 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3241 cgrad            enddo
3242 cgrad          enddo
3243 c 9/28/08 AL Gradient compotents will be summed only at the end
3244           ggg(1)=facvdw*xj*sss
3245           ggg(2)=facvdw*yj*sss
3246           ggg(3)=facvdw*zj*sss
3247           do k=1,3
3248             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3249             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3250           enddo
3251 #endif
3252 *
3253 * Angular part
3254 *
3255           ecosa=2.0D0*fac3*fac1+fac4
3256           fac4=-3.0D0*fac4
3257           fac3=-6.0D0*fac3
3258           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3259           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3260           do k=1,3
3261             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3262             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3263           enddo
3264 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3265 cd   &          (dcosg(k),k=1,3)
3266           do k=1,3
3267             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3268           enddo
3269 c          do k=1,3
3270 c            ghalf=0.5D0*ggg(k)
3271 c            gelc(k,i)=gelc(k,i)+ghalf
3272 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3273 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3274 c            gelc(k,j)=gelc(k,j)+ghalf
3275 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3276 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3277 c          enddo
3278 cgrad          do k=i+1,j-1
3279 cgrad            do l=1,3
3280 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3281 cgrad            enddo
3282 cgrad          enddo
3283           do k=1,3
3284             gelc(k,i)=gelc(k,i)
3285      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3286      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3287             gelc(k,j)=gelc(k,j)
3288      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3289      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3290             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3291             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3292           enddo
3293 C MARYSIA
3294 c          endif !sscale
3295           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3296      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3297      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3298 C
3299 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3300 C   energy of a peptide unit is assumed in the form of a second-order
3301 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3302 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3303 C   are computed for EVERY pair of non-contiguous peptide groups.
3304 C
3305           if (j.lt.nres-1) then
3306             j1=j+1
3307             j2=j-1
3308           else
3309             j1=j-1
3310             j2=j-2
3311           endif
3312           kkk=0
3313           do k=1,2
3314             do l=1,2
3315               kkk=kkk+1
3316               muij(kkk)=mu(k,i)*mu(l,j)
3317             enddo
3318           enddo
3319 cd         write (iout,*) 'EELEC: i',i,' j',j
3320 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3321 cd          write(iout,*) 'muij',muij
3322           ury=scalar(uy(1,i),erij)
3323           urz=scalar(uz(1,i),erij)
3324           vry=scalar(uy(1,j),erij)
3325           vrz=scalar(uz(1,j),erij)
3326           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3327           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3328           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3329           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3330           fac=dsqrt(-ael6i)*r3ij
3331           a22=a22*fac
3332           a23=a23*fac
3333           a32=a32*fac
3334           a33=a33*fac
3335 cd          write (iout,'(4i5,4f10.5)')
3336 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3337 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3338 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3339 cd     &      uy(:,j),uz(:,j)
3340 cd          write (iout,'(4f10.5)')
3341 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3342 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3343 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3344 cd           write (iout,'(9f10.5/)')
3345 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3346 C Derivatives of the elements of A in virtual-bond vectors
3347           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3348           do k=1,3
3349             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3350             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3351             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3352             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3353             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3354             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3355             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3356             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3357             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3358             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3359             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3360             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3361           enddo
3362 C Compute radial contributions to the gradient
3363           facr=-3.0d0*rrmij
3364           a22der=a22*facr
3365           a23der=a23*facr
3366           a32der=a32*facr
3367           a33der=a33*facr
3368           agg(1,1)=a22der*xj
3369           agg(2,1)=a22der*yj
3370           agg(3,1)=a22der*zj
3371           agg(1,2)=a23der*xj
3372           agg(2,2)=a23der*yj
3373           agg(3,2)=a23der*zj
3374           agg(1,3)=a32der*xj
3375           agg(2,3)=a32der*yj
3376           agg(3,3)=a32der*zj
3377           agg(1,4)=a33der*xj
3378           agg(2,4)=a33der*yj
3379           agg(3,4)=a33der*zj
3380 C Add the contributions coming from er
3381           fac3=-3.0d0*fac
3382           do k=1,3
3383             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3384             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3385             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3386             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3387           enddo
3388           do k=1,3
3389 C Derivatives in DC(i)
3390 cgrad            ghalf1=0.5d0*agg(k,1)
3391 cgrad            ghalf2=0.5d0*agg(k,2)
3392 cgrad            ghalf3=0.5d0*agg(k,3)
3393 cgrad            ghalf4=0.5d0*agg(k,4)
3394             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3395      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3396             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3397      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3398             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3399      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3400             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3401      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3402 C Derivatives in DC(i+1)
3403             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3404      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3405             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3406      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3407             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3408      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3409             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3410      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3411 C Derivatives in DC(j)
3412             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3413      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3414             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3415      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3416             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3417      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3418             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3419      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3420 C Derivatives in DC(j+1) or DC(nres-1)
3421             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3422      &      -3.0d0*vryg(k,3)*ury)
3423             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3424      &      -3.0d0*vrzg(k,3)*ury)
3425             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3426      &      -3.0d0*vryg(k,3)*urz)
3427             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3428      &      -3.0d0*vrzg(k,3)*urz)
3429 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3430 cgrad              do l=1,4
3431 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3432 cgrad              enddo
3433 cgrad            endif
3434           enddo
3435           acipa(1,1)=a22
3436           acipa(1,2)=a23
3437           acipa(2,1)=a32
3438           acipa(2,2)=a33
3439           a22=-a22
3440           a23=-a23
3441           do l=1,2
3442             do k=1,3
3443               agg(k,l)=-agg(k,l)
3444               aggi(k,l)=-aggi(k,l)
3445               aggi1(k,l)=-aggi1(k,l)
3446               aggj(k,l)=-aggj(k,l)
3447               aggj1(k,l)=-aggj1(k,l)
3448             enddo
3449           enddo
3450           if (j.lt.nres-1) then
3451             a22=-a22
3452             a32=-a32
3453             do l=1,3,2
3454               do k=1,3
3455                 agg(k,l)=-agg(k,l)
3456                 aggi(k,l)=-aggi(k,l)
3457                 aggi1(k,l)=-aggi1(k,l)
3458                 aggj(k,l)=-aggj(k,l)
3459                 aggj1(k,l)=-aggj1(k,l)
3460               enddo
3461             enddo
3462           else
3463             a22=-a22
3464             a23=-a23
3465             a32=-a32
3466             a33=-a33
3467             do l=1,4
3468               do k=1,3
3469                 agg(k,l)=-agg(k,l)
3470                 aggi(k,l)=-aggi(k,l)
3471                 aggi1(k,l)=-aggi1(k,l)
3472                 aggj(k,l)=-aggj(k,l)
3473                 aggj1(k,l)=-aggj1(k,l)
3474               enddo
3475             enddo
3476           endif
3477           ENDIF ! WCORR
3478           IF (wel_loc.gt.0.0d0) THEN
3479 C Contribution to the local-electrostatic energy coming from the i-j pair
3480           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3481      &     +a33*muij(4)
3482 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3483
3484           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3485      &            'eelloc',i,j,eel_loc_ij
3486 c           if (eel_loc_ij.ne.0)
3487 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3488 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3489
3490           eel_loc=eel_loc+eel_loc_ij
3491 C Partial derivatives in virtual-bond dihedral angles gamma
3492           if (i.gt.1)
3493      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3494      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3495      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3496           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3497      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3498      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3499 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3500           do l=1,3
3501             ggg(l)=agg(l,1)*muij(1)+
3502      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3503             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3504             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3505 cgrad            ghalf=0.5d0*ggg(l)
3506 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3507 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3508           enddo
3509 cgrad          do k=i+1,j2
3510 cgrad            do l=1,3
3511 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3512 cgrad            enddo
3513 cgrad          enddo
3514 C Remaining derivatives of eello
3515           do l=1,3
3516             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3517      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3518             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3519      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3520             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3521      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3522             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3523      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3524           enddo
3525           ENDIF
3526 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3527 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3528           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3529      &       .and. num_conti.le.maxconts) then
3530 c            write (iout,*) i,j," entered corr"
3531 C
3532 C Calculate the contact function. The ith column of the array JCONT will
3533 C contain the numbers of atoms that make contacts with the atom I (of numbers
3534 C greater than I). The arrays FACONT and GACONT will contain the values of
3535 C the contact function and its derivative.
3536 c           r0ij=1.02D0*rpp(iteli,itelj)
3537 c           r0ij=1.11D0*rpp(iteli,itelj)
3538             r0ij=2.20D0*rpp(iteli,itelj)
3539 c           r0ij=1.55D0*rpp(iteli,itelj)
3540             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3541             if (fcont.gt.0.0D0) then
3542               num_conti=num_conti+1
3543               if (num_conti.gt.maxconts) then
3544                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3545      &                         ' will skip next contacts for this conf.'
3546               else
3547                 jcont_hb(num_conti,i)=j
3548 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3549 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3550                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3551      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3552 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3553 C  terms.
3554                 d_cont(num_conti,i)=rij
3555 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3556 C     --- Electrostatic-interaction matrix ---
3557                 a_chuj(1,1,num_conti,i)=a22
3558                 a_chuj(1,2,num_conti,i)=a23
3559                 a_chuj(2,1,num_conti,i)=a32
3560                 a_chuj(2,2,num_conti,i)=a33
3561 C     --- Gradient of rij
3562                 do kkk=1,3
3563                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3564                 enddo
3565                 kkll=0
3566                 do k=1,2
3567                   do l=1,2
3568                     kkll=kkll+1
3569                     do m=1,3
3570                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3571                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3572                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3573                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3574                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3575                     enddo
3576                   enddo
3577                 enddo
3578                 ENDIF
3579                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3580 C Calculate contact energies
3581                 cosa4=4.0D0*cosa
3582                 wij=cosa-3.0D0*cosb*cosg
3583                 cosbg1=cosb+cosg
3584                 cosbg2=cosb-cosg
3585 c               fac3=dsqrt(-ael6i)/r0ij**3
3586                 fac3=dsqrt(-ael6i)*r3ij
3587 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3588                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3589                 if (ees0tmp.gt.0) then
3590                   ees0pij=dsqrt(ees0tmp)
3591                 else
3592                   ees0pij=0
3593                 endif
3594 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3595                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3596                 if (ees0tmp.gt.0) then
3597                   ees0mij=dsqrt(ees0tmp)
3598                 else
3599                   ees0mij=0
3600                 endif
3601 c               ees0mij=0.0D0
3602                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3603                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3604 C Diagnostics. Comment out or remove after debugging!
3605 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3606 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3607 c               ees0m(num_conti,i)=0.0D0
3608 C End diagnostics.
3609 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3610 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3611 C Angular derivatives of the contact function
3612                 ees0pij1=fac3/ees0pij
3613                 ees0mij1=fac3/ees0mij
3614                 fac3p=-3.0D0*fac3*rrmij
3615                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3616                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3617 c               ees0mij1=0.0D0
3618                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3619                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3620                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3621                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3622                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3623                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3624                 ecosap=ecosa1+ecosa2
3625                 ecosbp=ecosb1+ecosb2
3626                 ecosgp=ecosg1+ecosg2
3627                 ecosam=ecosa1-ecosa2
3628                 ecosbm=ecosb1-ecosb2
3629                 ecosgm=ecosg1-ecosg2
3630 C Diagnostics
3631 c               ecosap=ecosa1
3632 c               ecosbp=ecosb1
3633 c               ecosgp=ecosg1
3634 c               ecosam=0.0D0
3635 c               ecosbm=0.0D0
3636 c               ecosgm=0.0D0
3637 C End diagnostics
3638                 facont_hb(num_conti,i)=fcont
3639                 fprimcont=fprimcont/rij
3640 cd              facont_hb(num_conti,i)=1.0D0
3641 C Following line is for diagnostics.
3642 cd              fprimcont=0.0D0
3643                 do k=1,3
3644                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3645                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3646                 enddo
3647                 do k=1,3
3648                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3649                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3650                 enddo
3651                 gggp(1)=gggp(1)+ees0pijp*xj
3652                 gggp(2)=gggp(2)+ees0pijp*yj
3653                 gggp(3)=gggp(3)+ees0pijp*zj
3654                 gggm(1)=gggm(1)+ees0mijp*xj
3655                 gggm(2)=gggm(2)+ees0mijp*yj
3656                 gggm(3)=gggm(3)+ees0mijp*zj
3657 C Derivatives due to the contact function
3658                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3659                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3660                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3661                 do k=1,3
3662 c
3663 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3664 c          following the change of gradient-summation algorithm.
3665 c
3666 cgrad                  ghalfp=0.5D0*gggp(k)
3667 cgrad                  ghalfm=0.5D0*gggm(k)
3668                   gacontp_hb1(k,num_conti,i)=!ghalfp
3669      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3670      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3671                   gacontp_hb2(k,num_conti,i)=!ghalfp
3672      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3673      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3674                   gacontp_hb3(k,num_conti,i)=gggp(k)
3675                   gacontm_hb1(k,num_conti,i)=!ghalfm
3676      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3677      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3678                   gacontm_hb2(k,num_conti,i)=!ghalfm
3679      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3680      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3681                   gacontm_hb3(k,num_conti,i)=gggm(k)
3682                 enddo
3683 C Diagnostics. Comment out or remove after debugging!
3684 cdiag           do k=1,3
3685 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3686 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3687 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3688 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3689 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3690 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3691 cdiag           enddo
3692               ENDIF ! wcorr
3693               endif  ! num_conti.le.maxconts
3694             endif  ! fcont.gt.0
3695           endif    ! j.gt.i+1
3696           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3697             do k=1,4
3698               do l=1,3
3699                 ghalf=0.5d0*agg(l,k)
3700                 aggi(l,k)=aggi(l,k)+ghalf
3701                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3702                 aggj(l,k)=aggj(l,k)+ghalf
3703               enddo
3704             enddo
3705             if (j.eq.nres-1 .and. i.lt.j-2) then
3706               do k=1,4
3707                 do l=1,3
3708                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3709                 enddo
3710               enddo
3711             endif
3712           endif
3713 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3714       return
3715       end
3716 C-----------------------------------------------------------------------------
3717       subroutine eturn3(i,eello_turn3)
3718 C Third- and fourth-order contributions from turns
3719       implicit real*8 (a-h,o-z)
3720       include 'DIMENSIONS'
3721       include 'COMMON.IOUNITS'
3722       include 'COMMON.GEO'
3723       include 'COMMON.VAR'
3724       include 'COMMON.LOCAL'
3725       include 'COMMON.CHAIN'
3726       include 'COMMON.DERIV'
3727       include 'COMMON.INTERACT'
3728       include 'COMMON.CONTACTS'
3729       include 'COMMON.TORSION'
3730       include 'COMMON.VECTORS'
3731       include 'COMMON.FFIELD'
3732       include 'COMMON.CONTROL'
3733       dimension ggg(3)
3734       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3735      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3736      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3737       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3738      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3739       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3740      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3741      &    num_conti,j1,j2
3742       j=i+2
3743 c      write (iout,*) "eturn3",i,j,j1,j2
3744       a_temp(1,1)=a22
3745       a_temp(1,2)=a23
3746       a_temp(2,1)=a32
3747       a_temp(2,2)=a33
3748 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3749 C
3750 C               Third-order contributions
3751 C
3752 C                 (i+2)o----(i+3)
3753 C                      | |
3754 C                      | |
3755 C                 (i+1)o----i
3756 C
3757 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3758 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3759         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3760         call transpose2(auxmat(1,1),auxmat1(1,1))
3761         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3762         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3763         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3764      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3765 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3766 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3767 cd     &    ' eello_turn3_num',4*eello_turn3_num
3768 C Derivatives in gamma(i)
3769         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3770         call transpose2(auxmat2(1,1),auxmat3(1,1))
3771         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3772         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3773 C Derivatives in gamma(i+1)
3774         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3775         call transpose2(auxmat2(1,1),auxmat3(1,1))
3776         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3778      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3779 C Cartesian derivatives
3780         do l=1,3
3781 c            ghalf1=0.5d0*agg(l,1)
3782 c            ghalf2=0.5d0*agg(l,2)
3783 c            ghalf3=0.5d0*agg(l,3)
3784 c            ghalf4=0.5d0*agg(l,4)
3785           a_temp(1,1)=aggi(l,1)!+ghalf1
3786           a_temp(1,2)=aggi(l,2)!+ghalf2
3787           a_temp(2,1)=aggi(l,3)!+ghalf3
3788           a_temp(2,2)=aggi(l,4)!+ghalf4
3789           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3790           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3791      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3792           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3793           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3794           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3795           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3796           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3797           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3798      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3799           a_temp(1,1)=aggj(l,1)!+ghalf1
3800           a_temp(1,2)=aggj(l,2)!+ghalf2
3801           a_temp(2,1)=aggj(l,3)!+ghalf3
3802           a_temp(2,2)=aggj(l,4)!+ghalf4
3803           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3804           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3805      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3806           a_temp(1,1)=aggj1(l,1)
3807           a_temp(1,2)=aggj1(l,2)
3808           a_temp(2,1)=aggj1(l,3)
3809           a_temp(2,2)=aggj1(l,4)
3810           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3811           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3812      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3813         enddo
3814       return
3815       end
3816 C-------------------------------------------------------------------------------
3817       subroutine eturn4(i,eello_turn4)
3818 C Third- and fourth-order contributions from turns
3819       implicit real*8 (a-h,o-z)
3820       include 'DIMENSIONS'
3821       include 'COMMON.IOUNITS'
3822       include 'COMMON.GEO'
3823       include 'COMMON.VAR'
3824       include 'COMMON.LOCAL'
3825       include 'COMMON.CHAIN'
3826       include 'COMMON.DERIV'
3827       include 'COMMON.INTERACT'
3828       include 'COMMON.CONTACTS'
3829       include 'COMMON.TORSION'
3830       include 'COMMON.VECTORS'
3831       include 'COMMON.FFIELD'
3832       include 'COMMON.CONTROL'
3833       dimension ggg(3)
3834       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3835      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3836      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3837       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3838      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3839       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3840      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3841      &    num_conti,j1,j2
3842       j=i+3
3843 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3844 C
3845 C               Fourth-order contributions
3846 C
3847 C                 (i+3)o----(i+4)
3848 C                     /  |
3849 C               (i+2)o   |
3850 C                     \  |
3851 C                 (i+1)o----i
3852 C
3853 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3854 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3855 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3856         a_temp(1,1)=a22
3857         a_temp(1,2)=a23
3858         a_temp(2,1)=a32
3859         a_temp(2,2)=a33
3860         iti1=itortyp(itype(i+1))
3861         iti2=itortyp(itype(i+2))
3862         iti3=itortyp(itype(i+3))
3863 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3864         call transpose2(EUg(1,1,i+1),e1t(1,1))
3865         call transpose2(Eug(1,1,i+2),e2t(1,1))
3866         call transpose2(Eug(1,1,i+3),e3t(1,1))
3867         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3868         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3869         s1=scalar2(b1(1,iti2),auxvec(1))
3870         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3871         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3872         s2=scalar2(b1(1,iti1),auxvec(1))
3873         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3874         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3875         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3876         eello_turn4=eello_turn4-(s1+s2+s3)
3877 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3878         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3879      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3880 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3881 cd     &    ' eello_turn4_num',8*eello_turn4_num
3882 C Derivatives in gamma(i)
3883         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3884         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3885         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3886         s1=scalar2(b1(1,iti2),auxvec(1))
3887         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3888         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3889         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3890 C Derivatives in gamma(i+1)
3891         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3892         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3893         s2=scalar2(b1(1,iti1),auxvec(1))
3894         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3895         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3896         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3897         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3898 C Derivatives in gamma(i+2)
3899         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3900         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3901         s1=scalar2(b1(1,iti2),auxvec(1))
3902         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3903         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3904         s2=scalar2(b1(1,iti1),auxvec(1))
3905         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3906         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3907         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3908         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3909 C Cartesian derivatives
3910 C Derivatives of this turn contributions in DC(i+2)
3911         if (j.lt.nres-1) then
3912           do l=1,3
3913             a_temp(1,1)=agg(l,1)
3914             a_temp(1,2)=agg(l,2)
3915             a_temp(2,1)=agg(l,3)
3916             a_temp(2,2)=agg(l,4)
3917             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3918             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3919             s1=scalar2(b1(1,iti2),auxvec(1))
3920             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3921             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3922             s2=scalar2(b1(1,iti1),auxvec(1))
3923             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3924             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3925             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926             ggg(l)=-(s1+s2+s3)
3927             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3928           enddo
3929         endif
3930 C Remaining derivatives of this turn contribution
3931         do l=1,3
3932           a_temp(1,1)=aggi(l,1)
3933           a_temp(1,2)=aggi(l,2)
3934           a_temp(2,1)=aggi(l,3)
3935           a_temp(2,2)=aggi(l,4)
3936           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3937           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3938           s1=scalar2(b1(1,iti2),auxvec(1))
3939           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3940           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3941           s2=scalar2(b1(1,iti1),auxvec(1))
3942           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3943           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3944           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3945           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3946           a_temp(1,1)=aggi1(l,1)
3947           a_temp(1,2)=aggi1(l,2)
3948           a_temp(2,1)=aggi1(l,3)
3949           a_temp(2,2)=aggi1(l,4)
3950           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3951           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3952           s1=scalar2(b1(1,iti2),auxvec(1))
3953           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3954           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3955           s2=scalar2(b1(1,iti1),auxvec(1))
3956           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3957           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3958           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3959           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3960           a_temp(1,1)=aggj(l,1)
3961           a_temp(1,2)=aggj(l,2)
3962           a_temp(2,1)=aggj(l,3)
3963           a_temp(2,2)=aggj(l,4)
3964           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3965           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3966           s1=scalar2(b1(1,iti2),auxvec(1))
3967           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3968           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3969           s2=scalar2(b1(1,iti1),auxvec(1))
3970           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3971           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3972           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3973           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3974           a_temp(1,1)=aggj1(l,1)
3975           a_temp(1,2)=aggj1(l,2)
3976           a_temp(2,1)=aggj1(l,3)
3977           a_temp(2,2)=aggj1(l,4)
3978           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3979           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3980           s1=scalar2(b1(1,iti2),auxvec(1))
3981           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3982           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3983           s2=scalar2(b1(1,iti1),auxvec(1))
3984           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3985           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3986           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3987 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3988           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3989         enddo
3990       return
3991       end
3992 C-----------------------------------------------------------------------------
3993       subroutine vecpr(u,v,w)
3994       implicit real*8(a-h,o-z)
3995       dimension u(3),v(3),w(3)
3996       w(1)=u(2)*v(3)-u(3)*v(2)
3997       w(2)=-u(1)*v(3)+u(3)*v(1)
3998       w(3)=u(1)*v(2)-u(2)*v(1)
3999       return
4000       end
4001 C-----------------------------------------------------------------------------
4002       subroutine unormderiv(u,ugrad,unorm,ungrad)
4003 C This subroutine computes the derivatives of a normalized vector u, given
4004 C the derivatives computed without normalization conditions, ugrad. Returns
4005 C ungrad.
4006       implicit none
4007       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4008       double precision vec(3)
4009       double precision scalar
4010       integer i,j
4011 c      write (2,*) 'ugrad',ugrad
4012 c      write (2,*) 'u',u
4013       do i=1,3
4014         vec(i)=scalar(ugrad(1,i),u(1))
4015       enddo
4016 c      write (2,*) 'vec',vec
4017       do i=1,3
4018         do j=1,3
4019           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4020         enddo
4021       enddo
4022 c      write (2,*) 'ungrad',ungrad
4023       return
4024       end
4025 C-----------------------------------------------------------------------------
4026       subroutine escp_soft_sphere(evdw2,evdw2_14)
4027 C
4028 C This subroutine calculates the excluded-volume interaction energy between
4029 C peptide-group centers and side chains and its gradient in virtual-bond and
4030 C side-chain vectors.
4031 C
4032       implicit real*8 (a-h,o-z)
4033       include 'DIMENSIONS'
4034       include 'COMMON.GEO'
4035       include 'COMMON.VAR'
4036       include 'COMMON.LOCAL'
4037       include 'COMMON.CHAIN'
4038       include 'COMMON.DERIV'
4039       include 'COMMON.INTERACT'
4040       include 'COMMON.FFIELD'
4041       include 'COMMON.IOUNITS'
4042       include 'COMMON.CONTROL'
4043       dimension ggg(3)
4044       evdw2=0.0D0
4045       evdw2_14=0.0d0
4046       r0_scp=4.5d0
4047 cd    print '(a)','Enter ESCP'
4048 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4049       do xshift=-1,1
4050       do yshift=-1,1
4051       do zshift=-1,1
4052       do i=iatscp_s,iatscp_e
4053         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058 C Return atom into box, boxxsize is size of box in x dimension
4059   134   continue
4060         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4061         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4062 C Condition for being inside the proper box
4063         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4064      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4065         go to 134
4066         endif
4067   135   continue
4068         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4069         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4070 C Condition for being inside the proper box
4071         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4072      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4073         go to 135
4074         endif
4075   136   continue
4076         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4077         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4078 C Condition for being inside the proper box
4079         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4080      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4081         go to 136
4082         endif
4083         do iint=1,nscp_gr(i)
4084
4085         do j=iscpstart(i,iint),iscpend(i,iint)
4086           if (itype(j).eq.ntyp1) cycle
4087           itypj=iabs(itype(j))
4088 C Uncomment following three lines for SC-p interactions
4089 c         xj=c(1,nres+j)-xi
4090 c         yj=c(2,nres+j)-yi
4091 c         zj=c(3,nres+j)-zi
4092 C Uncomment following three lines for Ca-p interactions
4093           xj=c(1,j)
4094           yj=c(2,j)
4095           zj=c(3,j)
4096   174   continue
4097         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4098         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4099 C Condition for being inside the proper box
4100         if ((xj.gt.((0.5d0)*boxxsize)).or.
4101      &       (xj.lt.((-0.5d0)*boxxsize))) then
4102         go to 174
4103         endif
4104   175   continue
4105         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4106         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4107 C Condition for being inside the proper box
4108         if ((yj.gt.((0.5d0)*boxysize)).or.
4109      &       (yj.lt.((-0.5d0)*boxysize))) then
4110         go to 175
4111         endif
4112   176   continue
4113         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4114         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4115 C Condition for being inside the proper box
4116         if ((zj.gt.((0.5d0)*boxzsize)).or.
4117      &       (zj.lt.((-0.5d0)*boxzsize))) then
4118         go to 176
4119         endif
4120           xj=xj-xi
4121           yj=yj-yi
4122           zj=zj-zi
4123           rij=xj*xj+yj*yj+zj*zj
4124
4125           r0ij=r0_scp
4126           r0ijsq=r0ij*r0ij
4127           if (rij.lt.r0ijsq) then
4128             evdwij=0.25d0*(rij-r0ijsq)**2
4129             fac=rij-r0ijsq
4130           else
4131             evdwij=0.0d0
4132             fac=0.0d0
4133           endif
4134           evdw2=evdw2+evdwij
4135 C
4136 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4137 C
4138           ggg(1)=xj*fac
4139           ggg(2)=yj*fac
4140           ggg(3)=zj*fac
4141 cgrad          if (j.lt.i) then
4142 cd          write (iout,*) 'j<i'
4143 C Uncomment following three lines for SC-p interactions
4144 c           do k=1,3
4145 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4146 c           enddo
4147 cgrad          else
4148 cd          write (iout,*) 'j>i'
4149 cgrad            do k=1,3
4150 cgrad              ggg(k)=-ggg(k)
4151 C Uncomment following line for SC-p interactions
4152 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4153 cgrad            enddo
4154 cgrad          endif
4155 cgrad          do k=1,3
4156 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4157 cgrad          enddo
4158 cgrad          kstart=min0(i+1,j)
4159 cgrad          kend=max0(i-1,j-1)
4160 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4161 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4162 cgrad          do k=kstart,kend
4163 cgrad            do l=1,3
4164 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4165 cgrad            enddo
4166 cgrad          enddo
4167           do k=1,3
4168             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4169             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4170           enddo
4171         enddo
4172
4173         enddo ! iint
4174       enddo ! i
4175       enddo !zshift
4176       enddo !yshift
4177       enddo !xshift
4178       return
4179       end
4180 C-----------------------------------------------------------------------------
4181       subroutine escp(evdw2,evdw2_14)
4182 C
4183 C This subroutine calculates the excluded-volume interaction energy between
4184 C peptide-group centers and side chains and its gradient in virtual-bond and
4185 C side-chain vectors.
4186 C
4187       implicit real*8 (a-h,o-z)
4188       include 'DIMENSIONS'
4189       include 'COMMON.GEO'
4190       include 'COMMON.VAR'
4191       include 'COMMON.LOCAL'
4192       include 'COMMON.CHAIN'
4193       include 'COMMON.DERIV'
4194       include 'COMMON.INTERACT'
4195       include 'COMMON.FFIELD'
4196       include 'COMMON.IOUNITS'
4197       include 'COMMON.CONTROL'
4198       include 'COMMON.SPLITELE'
4199       dimension ggg(3)
4200       evdw2=0.0D0
4201       evdw2_14=0.0d0
4202 cd    print '(a)','Enter ESCP'
4203 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4204       do xshift=-1,1
4205       do yshift=-1,1
4206       do zshift=-1,1
4207       do i=iatscp_s,iatscp_e
4208         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4209         iteli=itel(i)
4210         xi=0.5D0*(c(1,i)+c(1,i+1))
4211         yi=0.5D0*(c(2,i)+c(2,i+1))
4212         zi=0.5D0*(c(3,i)+c(3,i+1))
4213 C Return atom into box, boxxsize is size of box in x dimension
4214   134   continue
4215         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4216         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4217 C Condition for being inside the proper box
4218         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4219      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4220         go to 134
4221         endif
4222   135   continue
4223         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4224         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4225 C Condition for being inside the proper box
4226         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4227      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4228         go to 135
4229         endif
4230   136   continue
4231         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4232         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4233 C Condition for being inside the proper box
4234         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4235      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4236         go to 136
4237         endif
4238         do iint=1,nscp_gr(i)
4239
4240         do j=iscpstart(i,iint),iscpend(i,iint)
4241           itypj=iabs(itype(j))
4242           if (itypj.eq.ntyp1) cycle
4243 C Uncomment following three lines for SC-p interactions
4244 c         xj=c(1,nres+j)-xi
4245 c         yj=c(2,nres+j)-yi
4246 c         zj=c(3,nres+j)-zi
4247 C Uncomment following three lines for Ca-p interactions
4248           xj=c(1,j)
4249           yj=c(2,j)
4250           zj=c(3,j)
4251   174   continue
4252         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4253         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4254 C Condition for being inside the proper box
4255         if ((xj.gt.((0.5d0)*boxxsize)).or.
4256      &       (xj.lt.((-0.5d0)*boxxsize))) then
4257         go to 174
4258         endif
4259   175   continue
4260         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4261         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4262 C Condition for being inside the proper box
4263         if ((yj.gt.((0.5d0)*boxysize)).or.
4264      &       (yj.lt.((-0.5d0)*boxysize))) then
4265         go to 175
4266         endif
4267   176   continue
4268         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4269         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4270 C Condition for being inside the proper box
4271         if ((zj.gt.((0.5d0)*boxzsize)).or.
4272      &       (zj.lt.((-0.5d0)*boxzsize))) then
4273         go to 176
4274         endif
4275           xj=xj-xi
4276           yj=yj-yi
4277           zj=zj-zi
4278           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4279           sss=sscale(1.0d0/(dsqrt(rrij)))
4280           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4281           if (sss.gt.0.0d0) then
4282           fac=rrij**expon2
4283           e1=fac*fac*aad(itypj,iteli)
4284           e2=fac*bad(itypj,iteli)
4285           if (iabs(j-i) .le. 2) then
4286             e1=scal14*e1
4287             e2=scal14*e2
4288             evdw2_14=evdw2_14+(e1+e2)*sss
4289           endif
4290           evdwij=e1+e2
4291           evdw2=evdw2+evdwij*sss
4292           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4293      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4294      &       bad(itypj,iteli)
4295 C
4296 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4297 C
4298           fac=-(evdwij+e1)*rrij*sss
4299           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4300           ggg(1)=xj*fac
4301           ggg(2)=yj*fac
4302           ggg(3)=zj*fac
4303 cgrad          if (j.lt.i) then
4304 cd          write (iout,*) 'j<i'
4305 C Uncomment following three lines for SC-p interactions
4306 c           do k=1,3
4307 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4308 c           enddo
4309 cgrad          else
4310 cd          write (iout,*) 'j>i'
4311 cgrad            do k=1,3
4312 cgrad              ggg(k)=-ggg(k)
4313 C Uncomment following line for SC-p interactions
4314 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4315 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4316 cgrad            enddo
4317 cgrad          endif
4318 cgrad          do k=1,3
4319 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4320 cgrad          enddo
4321 cgrad          kstart=min0(i+1,j)
4322 cgrad          kend=max0(i-1,j-1)
4323 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4324 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4325 cgrad          do k=kstart,kend
4326 cgrad            do l=1,3
4327 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4328 cgrad            enddo
4329 cgrad          enddo
4330           do k=1,3
4331             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4332             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4333           enddo
4334         endif !endif for sscale cutoff
4335         enddo ! j
4336
4337         enddo ! iint
4338       enddo ! i
4339       enddo !zshift
4340       enddo !yshift
4341       enddo !xshift
4342       do i=1,nct
4343         do j=1,3
4344           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4345           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4346           gradx_scp(j,i)=expon*gradx_scp(j,i)
4347         enddo
4348       enddo
4349 C******************************************************************************
4350 C
4351 C                              N O T E !!!
4352 C
4353 C To save time the factor EXPON has been extracted from ALL components
4354 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4355 C use!
4356 C
4357 C******************************************************************************
4358       return
4359       end
4360 C--------------------------------------------------------------------------
4361       subroutine edis(ehpb)
4362 C
4363 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4364 C
4365       implicit real*8 (a-h,o-z)
4366       include 'DIMENSIONS'
4367       include 'COMMON.SBRIDGE'
4368       include 'COMMON.CHAIN'
4369       include 'COMMON.DERIV'
4370       include 'COMMON.VAR'
4371       include 'COMMON.INTERACT'
4372       include 'COMMON.IOUNITS'
4373       dimension ggg(3)
4374       ehpb=0.0D0
4375 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4376 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4377       if (link_end.eq.0) return
4378       do i=link_start,link_end
4379 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4380 C CA-CA distance used in regularization of structure.
4381         ii=ihpb(i)
4382         jj=jhpb(i)
4383 C iii and jjj point to the residues for which the distance is assigned.
4384         if (ii.gt.nres) then
4385           iii=ii-nres
4386           jjj=jj-nres
4387         else
4388           iii=ii
4389           jjj=jj
4390         endif
4391 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4392 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4393 C    distance and angle dependent SS bond potential.
4394         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4395      & iabs(itype(jjj)).eq.1) then
4396           call ssbond_ene(iii,jjj,eij)
4397           ehpb=ehpb+2*eij
4398 cd          write (iout,*) "eij",eij
4399         else
4400 C Calculate the distance between the two points and its difference from the
4401 C target distance.
4402         dd=dist(ii,jj)
4403         rdis=dd-dhpb(i)
4404 C Get the force constant corresponding to this distance.
4405         waga=forcon(i)
4406 C Calculate the contribution to energy.
4407         ehpb=ehpb+waga*rdis*rdis
4408 C
4409 C Evaluate gradient.
4410 C
4411         fac=waga*rdis/dd
4412 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4413 cd   &   ' waga=',waga,' fac=',fac
4414         do j=1,3
4415           ggg(j)=fac*(c(j,jj)-c(j,ii))
4416         enddo
4417 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4418 C If this is a SC-SC distance, we need to calculate the contributions to the
4419 C Cartesian gradient in the SC vectors (ghpbx).
4420         if (iii.lt.ii) then
4421           do j=1,3
4422             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4423             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4424           enddo
4425         endif
4426 cgrad        do j=iii,jjj-1
4427 cgrad          do k=1,3
4428 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4429 cgrad          enddo
4430 cgrad        enddo
4431         do k=1,3
4432           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4433           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4434         enddo
4435         endif
4436       enddo
4437       ehpb=0.5D0*ehpb
4438       return
4439       end
4440 C--------------------------------------------------------------------------
4441       subroutine ssbond_ene(i,j,eij)
4442 C
4443 C Calculate the distance and angle dependent SS-bond potential energy
4444 C using a free-energy function derived based on RHF/6-31G** ab initio
4445 C calculations of diethyl disulfide.
4446 C
4447 C A. Liwo and U. Kozlowska, 11/24/03
4448 C
4449       implicit real*8 (a-h,o-z)
4450       include 'DIMENSIONS'
4451       include 'COMMON.SBRIDGE'
4452       include 'COMMON.CHAIN'
4453       include 'COMMON.DERIV'
4454       include 'COMMON.LOCAL'
4455       include 'COMMON.INTERACT'
4456       include 'COMMON.VAR'
4457       include 'COMMON.IOUNITS'
4458       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4459       itypi=iabs(itype(i))
4460       xi=c(1,nres+i)
4461       yi=c(2,nres+i)
4462       zi=c(3,nres+i)
4463       dxi=dc_norm(1,nres+i)
4464       dyi=dc_norm(2,nres+i)
4465       dzi=dc_norm(3,nres+i)
4466 c      dsci_inv=dsc_inv(itypi)
4467       dsci_inv=vbld_inv(nres+i)
4468       itypj=iabs(itype(j))
4469 c      dscj_inv=dsc_inv(itypj)
4470       dscj_inv=vbld_inv(nres+j)
4471       xj=c(1,nres+j)-xi
4472       yj=c(2,nres+j)-yi
4473       zj=c(3,nres+j)-zi
4474       dxj=dc_norm(1,nres+j)
4475       dyj=dc_norm(2,nres+j)
4476       dzj=dc_norm(3,nres+j)
4477       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4478       rij=dsqrt(rrij)
4479       erij(1)=xj*rij
4480       erij(2)=yj*rij
4481       erij(3)=zj*rij
4482       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4483       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4484       om12=dxi*dxj+dyi*dyj+dzi*dzj
4485       do k=1,3
4486         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4487         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4488       enddo
4489       rij=1.0d0/rij
4490       deltad=rij-d0cm
4491       deltat1=1.0d0-om1
4492       deltat2=1.0d0+om2
4493       deltat12=om2-om1+2.0d0
4494       cosphi=om12-om1*om2
4495       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4496      &  +akct*deltad*deltat12
4497      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4498 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4499 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4500 c     &  " deltat12",deltat12," eij",eij
4501       ed=2*akcm*deltad+akct*deltat12
4502       pom1=akct*deltad
4503       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4504       eom1=-2*akth*deltat1-pom1-om2*pom2
4505       eom2= 2*akth*deltat2+pom1-om1*pom2
4506       eom12=pom2
4507       do k=1,3
4508         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4509         ghpbx(k,i)=ghpbx(k,i)-ggk
4510      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4511      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4512         ghpbx(k,j)=ghpbx(k,j)+ggk
4513      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4514      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4515         ghpbc(k,i)=ghpbc(k,i)-ggk
4516         ghpbc(k,j)=ghpbc(k,j)+ggk
4517       enddo
4518 C
4519 C Calculate the components of the gradient in DC and X
4520 C
4521 cgrad      do k=i,j-1
4522 cgrad        do l=1,3
4523 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4524 cgrad        enddo
4525 cgrad      enddo
4526       return
4527       end
4528 C--------------------------------------------------------------------------
4529       subroutine ebond(estr)
4530 c
4531 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4532 c
4533       implicit real*8 (a-h,o-z)
4534       include 'DIMENSIONS'
4535       include 'COMMON.LOCAL'
4536       include 'COMMON.GEO'
4537       include 'COMMON.INTERACT'
4538       include 'COMMON.DERIV'
4539       include 'COMMON.VAR'
4540       include 'COMMON.CHAIN'
4541       include 'COMMON.IOUNITS'
4542       include 'COMMON.NAMES'
4543       include 'COMMON.FFIELD'
4544       include 'COMMON.CONTROL'
4545       include 'COMMON.SETUP'
4546       double precision u(3),ud(3)
4547       estr=0.0d0
4548       estr1=0.0d0
4549       do i=ibondp_start,ibondp_end
4550         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4551 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4552 c          do j=1,3
4553 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4554 c     &      *dc(j,i-1)/vbld(i)
4555 c          enddo
4556 c          if (energy_dec) write(iout,*)
4557 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4558 c        else
4559 C       Checking if it involves dummy (NH3+ or COO-) group
4560          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4561 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4562         diff = vbld(i)-vbldpDUM
4563          else
4564 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4565         diff = vbld(i)-vbldp0
4566          endif
4567         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4568      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4569         estr=estr+diff*diff
4570         do j=1,3
4571           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4572         enddo
4573 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4574 c        endif
4575       enddo
4576       estr=0.5d0*AKP*estr+estr1
4577 c
4578 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4579 c
4580       do i=ibond_start,ibond_end
4581         iti=iabs(itype(i))
4582         if (iti.ne.10 .and. iti.ne.ntyp1) then
4583           nbi=nbondterm(iti)
4584           if (nbi.eq.1) then
4585             diff=vbld(i+nres)-vbldsc0(1,iti)
4586             if (energy_dec) write (iout,*)
4587      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4588      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4589             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4590             do j=1,3
4591               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4592             enddo
4593           else
4594             do j=1,nbi
4595               diff=vbld(i+nres)-vbldsc0(j,iti)
4596               ud(j)=aksc(j,iti)*diff
4597               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4598             enddo
4599             uprod=u(1)
4600             do j=2,nbi
4601               uprod=uprod*u(j)
4602             enddo
4603             usum=0.0d0
4604             usumsqder=0.0d0
4605             do j=1,nbi
4606               uprod1=1.0d0
4607               uprod2=1.0d0
4608               do k=1,nbi
4609                 if (k.ne.j) then
4610                   uprod1=uprod1*u(k)
4611                   uprod2=uprod2*u(k)*u(k)
4612                 endif
4613               enddo
4614               usum=usum+uprod1
4615               usumsqder=usumsqder+ud(j)*uprod2
4616             enddo
4617             estr=estr+uprod/usum
4618             do j=1,3
4619              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4620             enddo
4621           endif
4622         endif
4623       enddo
4624       return
4625       end
4626 #ifdef CRYST_THETA
4627 C--------------------------------------------------------------------------
4628       subroutine ebend(etheta)
4629 C
4630 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4631 C angles gamma and its derivatives in consecutive thetas and gammas.
4632 C
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.GEO'
4637       include 'COMMON.INTERACT'
4638       include 'COMMON.DERIV'
4639       include 'COMMON.VAR'
4640       include 'COMMON.CHAIN'
4641       include 'COMMON.IOUNITS'
4642       include 'COMMON.NAMES'
4643       include 'COMMON.FFIELD'
4644       include 'COMMON.CONTROL'
4645       common /calcthet/ term1,term2,termm,diffak,ratak,
4646      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4647      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4648       double precision y(2),z(2)
4649       delta=0.02d0*pi
4650 c      time11=dexp(-2*time)
4651 c      time12=1.0d0
4652       etheta=0.0D0
4653 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4654       do i=ithet_start,ithet_end
4655         print *,i,itype(i-1),itype(i),itype(i-2)
4656         if (itype(i-1).eq.ntyp1) cycle
4657         print *,'wchodze',itype(i-1)
4658 C Zero the energy function and its derivative at 0 or pi.
4659         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4660         it=itype(i-1)
4661         ichir1=isign(1,itype(i-2))
4662         ichir2=isign(1,itype(i))
4663          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4664          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4665          if (itype(i-1).eq.10) then
4666           itype1=isign(10,itype(i-2))
4667           ichir11=isign(1,itype(i-2))
4668           ichir12=isign(1,itype(i-2))
4669           itype2=isign(10,itype(i))
4670           ichir21=isign(1,itype(i))
4671           ichir22=isign(1,itype(i))
4672          endif
4673
4674         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4675 #ifdef OSF
4676           phii=phi(i)
4677           if (phii.ne.phii) phii=150.0
4678 #else
4679           phii=phi(i)
4680 #endif
4681           y(1)=dcos(phii)
4682           y(2)=dsin(phii)
4683         else
4684           y(1)=0.0D0
4685           y(2)=0.0D0
4686         endif
4687         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4688 #ifdef OSF
4689           phii1=phi(i+1)
4690           if (phii1.ne.phii1) phii1=150.0
4691           phii1=pinorm(phii1)
4692           z(1)=cos(phii1)
4693 #else
4694           phii1=phi(i+1)
4695           z(1)=dcos(phii1)
4696 #endif
4697           z(2)=dsin(phii1)
4698         else
4699           z(1)=0.0D0
4700           z(2)=0.0D0
4701         endif
4702 C Calculate the "mean" value of theta from the part of the distribution
4703 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4704 C In following comments this theta will be referred to as t_c.
4705         thet_pred_mean=0.0d0
4706         do k=1,2
4707             athetk=athet(k,it,ichir1,ichir2)
4708             bthetk=bthet(k,it,ichir1,ichir2)
4709           if (it.eq.10) then
4710              athetk=athet(k,itype1,ichir11,ichir12)
4711              bthetk=bthet(k,itype2,ichir21,ichir22)
4712           endif
4713          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4714 c         write(iout,*) 'chuj tu', y(k),z(k)
4715         enddo
4716         dthett=thet_pred_mean*ssd
4717         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4718 C Derivatives of the "mean" values in gamma1 and gamma2.
4719         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4720      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4721          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4722      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4723          if (it.eq.10) then
4724       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4725      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4726         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4727      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4728          endif
4729         if (theta(i).gt.pi-delta) then
4730           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4731      &         E_tc0)
4732           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4733           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4734           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4735      &        E_theta)
4736           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4737      &        E_tc)
4738         else if (theta(i).lt.delta) then
4739           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4740           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4741           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4742      &        E_theta)
4743           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4744           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4745      &        E_tc)
4746         else
4747           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4748      &        E_theta,E_tc)
4749         endif
4750         etheta=etheta+ethetai
4751         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4752      &      'ebend',i,ethetai,theta(i),itype(i)
4753         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4754         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4755         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4756       enddo
4757 C Ufff.... We've done all this!!!
4758       return
4759       end
4760 C---------------------------------------------------------------------------
4761       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4762      &     E_tc)
4763       implicit real*8 (a-h,o-z)
4764       include 'DIMENSIONS'
4765       include 'COMMON.LOCAL'
4766       include 'COMMON.IOUNITS'
4767       common /calcthet/ term1,term2,termm,diffak,ratak,
4768      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4769      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4770 C Calculate the contributions to both Gaussian lobes.
4771 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4772 C The "polynomial part" of the "standard deviation" of this part of
4773 C the distributioni.
4774 ccc        write (iout,*) thetai,thet_pred_mean
4775         sig=polthet(3,it)
4776         do j=2,0,-1
4777           sig=sig*thet_pred_mean+polthet(j,it)
4778         enddo
4779 C Derivative of the "interior part" of the "standard deviation of the"
4780 C gamma-dependent Gaussian lobe in t_c.
4781         sigtc=3*polthet(3,it)
4782         do j=2,1,-1
4783           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4784         enddo
4785         sigtc=sig*sigtc
4786 C Set the parameters of both Gaussian lobes of the distribution.
4787 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4788         fac=sig*sig+sigc0(it)
4789         sigcsq=fac+fac
4790         sigc=1.0D0/sigcsq
4791 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4792         sigsqtc=-4.0D0*sigcsq*sigtc
4793 c       print *,i,sig,sigtc,sigsqtc
4794 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4795         sigtc=-sigtc/(fac*fac)
4796 C Following variable is sigma(t_c)**(-2)
4797         sigcsq=sigcsq*sigcsq
4798         sig0i=sig0(it)
4799         sig0inv=1.0D0/sig0i**2
4800         delthec=thetai-thet_pred_mean
4801         delthe0=thetai-theta0i
4802         term1=-0.5D0*sigcsq*delthec*delthec
4803         term2=-0.5D0*sig0inv*delthe0*delthe0
4804 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
4805 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4806 C NaNs in taking the logarithm. We extract the largest exponent which is added
4807 C to the energy (this being the log of the distribution) at the end of energy
4808 C term evaluation for this virtual-bond angle.
4809         if (term1.gt.term2) then
4810           termm=term1
4811           term2=dexp(term2-termm)
4812           term1=1.0d0
4813         else
4814           termm=term2
4815           term1=dexp(term1-termm)
4816           term2=1.0d0
4817         endif
4818 C The ratio between the gamma-independent and gamma-dependent lobes of
4819 C the distribution is a Gaussian function of thet_pred_mean too.
4820         diffak=gthet(2,it)-thet_pred_mean
4821         ratak=diffak/gthet(3,it)**2
4822         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4823 C Let's differentiate it in thet_pred_mean NOW.
4824         aktc=ak*ratak
4825 C Now put together the distribution terms to make complete distribution.
4826         termexp=term1+ak*term2
4827         termpre=sigc+ak*sig0i
4828 C Contribution of the bending energy from this theta is just the -log of
4829 C the sum of the contributions from the two lobes and the pre-exponential
4830 C factor. Simple enough, isn't it?
4831         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4832 C       write (iout,*) 'termexp',termexp,termm,termpre,i
4833 C NOW the derivatives!!!
4834 C 6/6/97 Take into account the deformation.
4835         E_theta=(delthec*sigcsq*term1
4836      &       +ak*delthe0*sig0inv*term2)/termexp
4837         E_tc=((sigtc+aktc*sig0i)/termpre
4838      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4839      &       aktc*term2)/termexp)
4840       return
4841       end
4842 c-----------------------------------------------------------------------------
4843       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4844       implicit real*8 (a-h,o-z)
4845       include 'DIMENSIONS'
4846       include 'COMMON.LOCAL'
4847       include 'COMMON.IOUNITS'
4848       common /calcthet/ term1,term2,termm,diffak,ratak,
4849      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4850      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4851       delthec=thetai-thet_pred_mean
4852       delthe0=thetai-theta0i
4853 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4854       t3 = thetai-thet_pred_mean
4855       t6 = t3**2
4856       t9 = term1
4857       t12 = t3*sigcsq
4858       t14 = t12+t6*sigsqtc
4859       t16 = 1.0d0
4860       t21 = thetai-theta0i
4861       t23 = t21**2
4862       t26 = term2
4863       t27 = t21*t26
4864       t32 = termexp
4865       t40 = t32**2
4866       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4867      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4868      & *(-t12*t9-ak*sig0inv*t27)
4869       return
4870       end
4871 #else
4872 C--------------------------------------------------------------------------
4873       subroutine ebend(etheta)
4874 C
4875 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4876 C angles gamma and its derivatives in consecutive thetas and gammas.
4877 C ab initio-derived potentials from
4878 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4879 C
4880       implicit real*8 (a-h,o-z)
4881       include 'DIMENSIONS'
4882       include 'COMMON.LOCAL'
4883       include 'COMMON.GEO'
4884       include 'COMMON.INTERACT'
4885       include 'COMMON.DERIV'
4886       include 'COMMON.VAR'
4887       include 'COMMON.CHAIN'
4888       include 'COMMON.IOUNITS'
4889       include 'COMMON.NAMES'
4890       include 'COMMON.FFIELD'
4891       include 'COMMON.CONTROL'
4892       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4893      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4894      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4895      & sinph1ph2(maxdouble,maxdouble)
4896       logical lprn /.false./, lprn1 /.false./
4897       etheta=0.0D0
4898       do i=ithet_start,ithet_end
4899 c        print *,i,itype(i-1),itype(i),itype(i-2)
4900         if ((itype(i-1).eq.ntyp1)) cycle
4901         if (iabs(itype(i+1)).eq.20) iblock=2
4902         if (iabs(itype(i+1)).ne.20) iblock=1
4903         dethetai=0.0d0
4904         dephii=0.0d0
4905         dephii1=0.0d0
4906         theti2=0.5d0*theta(i)
4907         ityp2=ithetyp((itype(i-1)))
4908         do k=1,nntheterm
4909           coskt(k)=dcos(k*theti2)
4910           sinkt(k)=dsin(k*theti2)
4911         enddo
4912         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4913 #ifdef OSF
4914           phii=phi(i)
4915           if (phii.ne.phii) phii=150.0
4916 #else
4917           phii=phi(i)
4918 #endif
4919           ityp1=ithetyp((itype(i-2)))
4920 C propagation of chirality for glycine type
4921           do k=1,nsingle
4922             cosph1(k)=dcos(k*phii)
4923             sinph1(k)=dsin(k*phii)
4924           enddo
4925         else
4926           phii=0.0d0
4927           ityp1=nthetyp+1
4928           do k=1,nsingle
4929             cosph1(k)=0.0d0
4930             sinph1(k)=0.0d0
4931           enddo
4932         endif
4933         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4934 #ifdef OSF
4935           phii1=phi(i+1)
4936           if (phii1.ne.phii1) phii1=150.0
4937           phii1=pinorm(phii1)
4938 #else
4939           phii1=phi(i+1)
4940 #endif
4941           ityp3=ithetyp((itype(i)))
4942           do k=1,nsingle
4943             cosph2(k)=dcos(k*phii1)
4944             sinph2(k)=dsin(k*phii1)
4945           enddo
4946         else
4947           phii1=0.0d0
4948           ityp3=nthetyp+1
4949           do k=1,nsingle
4950             cosph2(k)=0.0d0
4951             sinph2(k)=0.0d0
4952           enddo
4953         endif
4954         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4955         do k=1,ndouble
4956           do l=1,k-1
4957             ccl=cosph1(l)*cosph2(k-l)
4958             ssl=sinph1(l)*sinph2(k-l)
4959             scl=sinph1(l)*cosph2(k-l)
4960             csl=cosph1(l)*sinph2(k-l)
4961             cosph1ph2(l,k)=ccl-ssl
4962             cosph1ph2(k,l)=ccl+ssl
4963             sinph1ph2(l,k)=scl+csl
4964             sinph1ph2(k,l)=scl-csl
4965           enddo
4966         enddo
4967         if (lprn) then
4968         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4969      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4970         write (iout,*) "coskt and sinkt"
4971         do k=1,nntheterm
4972           write (iout,*) k,coskt(k),sinkt(k)
4973         enddo
4974         endif
4975         do k=1,ntheterm
4976           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4977           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4978      &      *coskt(k)
4979           if (lprn)
4980      &    write (iout,*) "k",k,"
4981      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4982      &     " ethetai",ethetai
4983         enddo
4984         if (lprn) then
4985         write (iout,*) "cosph and sinph"
4986         do k=1,nsingle
4987           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4988         enddo
4989         write (iout,*) "cosph1ph2 and sinph2ph2"
4990         do k=2,ndouble
4991           do l=1,k-1
4992             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4993      &         sinph1ph2(l,k),sinph1ph2(k,l)
4994           enddo
4995         enddo
4996         write(iout,*) "ethetai",ethetai
4997         endif
4998         do m=1,ntheterm2
4999           do k=1,nsingle
5000             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5001      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5002      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5003      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5004             ethetai=ethetai+sinkt(m)*aux
5005             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5006             dephii=dephii+k*sinkt(m)*(
5007      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5008      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5009             dephii1=dephii1+k*sinkt(m)*(
5010      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5011      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5012             if (lprn)
5013      &      write (iout,*) "m",m," k",k," bbthet",
5014      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5015      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5016      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5017      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5018           enddo
5019         enddo
5020         if (lprn)
5021      &  write(iout,*) "ethetai",ethetai
5022         do m=1,ntheterm3
5023           do k=2,ndouble
5024             do l=1,k-1
5025               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5026      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5027      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5028      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5029               ethetai=ethetai+sinkt(m)*aux
5030               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5031               dephii=dephii+l*sinkt(m)*(
5032      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5033      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5034      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5035      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5036               dephii1=dephii1+(k-l)*sinkt(m)*(
5037      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5038      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5039      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5040      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5041               if (lprn) then
5042               write (iout,*) "m",m," k",k," l",l," ffthet",
5043      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5044      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5045      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5046      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5047      &            " ethetai",ethetai
5048               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5049      &            cosph1ph2(k,l)*sinkt(m),
5050      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5051               endif
5052             enddo
5053           enddo
5054         enddo
5055 10      continue
5056 c        lprn1=.true.
5057         if (lprn1)
5058      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5059      &   i,theta(i)*rad2deg,phii*rad2deg,
5060      &   phii1*rad2deg,ethetai
5061 c        lprn1=.false.
5062         etheta=etheta+ethetai
5063         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5064         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5065         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5066       enddo
5067       return
5068       end
5069 #endif
5070 #ifdef CRYST_SC
5071 c-----------------------------------------------------------------------------
5072       subroutine esc(escloc)
5073 C Calculate the local energy of a side chain and its derivatives in the
5074 C corresponding virtual-bond valence angles THETA and the spherical angles
5075 C ALPHA and OMEGA.
5076       implicit real*8 (a-h,o-z)
5077       include 'DIMENSIONS'
5078       include 'COMMON.GEO'
5079       include 'COMMON.LOCAL'
5080       include 'COMMON.VAR'
5081       include 'COMMON.INTERACT'
5082       include 'COMMON.DERIV'
5083       include 'COMMON.CHAIN'
5084       include 'COMMON.IOUNITS'
5085       include 'COMMON.NAMES'
5086       include 'COMMON.FFIELD'
5087       include 'COMMON.CONTROL'
5088       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5089      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5090       common /sccalc/ time11,time12,time112,theti,it,nlobit
5091       delta=0.02d0*pi
5092       escloc=0.0D0
5093 c     write (iout,'(a)') 'ESC'
5094       do i=loc_start,loc_end
5095         it=itype(i)
5096         if (it.eq.ntyp1) cycle
5097         if (it.eq.10) goto 1
5098         nlobit=nlob(iabs(it))
5099 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5100 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5101         theti=theta(i+1)-pipol
5102         x(1)=dtan(theti)
5103         x(2)=alph(i)
5104         x(3)=omeg(i)
5105
5106         if (x(2).gt.pi-delta) then
5107           xtemp(1)=x(1)
5108           xtemp(2)=pi-delta
5109           xtemp(3)=x(3)
5110           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5111           xtemp(2)=pi
5112           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5113           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5114      &        escloci,dersc(2))
5115           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5116      &        ddersc0(1),dersc(1))
5117           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5118      &        ddersc0(3),dersc(3))
5119           xtemp(2)=pi-delta
5120           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5121           xtemp(2)=pi
5122           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5123           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5124      &            dersc0(2),esclocbi,dersc02)
5125           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5126      &            dersc12,dersc01)
5127           call splinthet(x(2),0.5d0*delta,ss,ssd)
5128           dersc0(1)=dersc01
5129           dersc0(2)=dersc02
5130           dersc0(3)=0.0d0
5131           do k=1,3
5132             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5133           enddo
5134           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5135 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5136 c    &             esclocbi,ss,ssd
5137           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5138 c         escloci=esclocbi
5139 c         write (iout,*) escloci
5140         else if (x(2).lt.delta) then
5141           xtemp(1)=x(1)
5142           xtemp(2)=delta
5143           xtemp(3)=x(3)
5144           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5145           xtemp(2)=0.0d0
5146           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5147           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5148      &        escloci,dersc(2))
5149           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5150      &        ddersc0(1),dersc(1))
5151           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5152      &        ddersc0(3),dersc(3))
5153           xtemp(2)=delta
5154           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5155           xtemp(2)=0.0d0
5156           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5157           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5158      &            dersc0(2),esclocbi,dersc02)
5159           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5160      &            dersc12,dersc01)
5161           dersc0(1)=dersc01
5162           dersc0(2)=dersc02
5163           dersc0(3)=0.0d0
5164           call splinthet(x(2),0.5d0*delta,ss,ssd)
5165           do k=1,3
5166             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5167           enddo
5168           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5169 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5170 c    &             esclocbi,ss,ssd
5171           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5172 c         write (iout,*) escloci
5173         else
5174           call enesc(x,escloci,dersc,ddummy,.false.)
5175         endif
5176
5177         escloc=escloc+escloci
5178         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5179      &     'escloc',i,escloci
5180 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5181
5182         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5183      &   wscloc*dersc(1)
5184         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5185         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5186     1   continue
5187       enddo
5188       return
5189       end
5190 C---------------------------------------------------------------------------
5191       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5192       implicit real*8 (a-h,o-z)
5193       include 'DIMENSIONS'
5194       include 'COMMON.GEO'
5195       include 'COMMON.LOCAL'
5196       include 'COMMON.IOUNITS'
5197       common /sccalc/ time11,time12,time112,theti,it,nlobit
5198       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5199       double precision contr(maxlob,-1:1)
5200       logical mixed
5201 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5202         escloc_i=0.0D0
5203         do j=1,3
5204           dersc(j)=0.0D0
5205           if (mixed) ddersc(j)=0.0d0
5206         enddo
5207         x3=x(3)
5208
5209 C Because of periodicity of the dependence of the SC energy in omega we have
5210 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5211 C To avoid underflows, first compute & store the exponents.
5212
5213         do iii=-1,1
5214
5215           x(3)=x3+iii*dwapi
5216
5217           do j=1,nlobit
5218             do k=1,3
5219               z(k)=x(k)-censc(k,j,it)
5220             enddo
5221             do k=1,3
5222               Axk=0.0D0
5223               do l=1,3
5224                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5225               enddo
5226               Ax(k,j,iii)=Axk
5227             enddo
5228             expfac=0.0D0
5229             do k=1,3
5230               expfac=expfac+Ax(k,j,iii)*z(k)
5231             enddo
5232             contr(j,iii)=expfac
5233           enddo ! j
5234
5235         enddo ! iii
5236
5237         x(3)=x3
5238 C As in the case of ebend, we want to avoid underflows in exponentiation and
5239 C subsequent NaNs and INFs in energy calculation.
5240 C Find the largest exponent
5241         emin=contr(1,-1)
5242         do iii=-1,1
5243           do j=1,nlobit
5244             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5245           enddo
5246         enddo
5247         emin=0.5D0*emin
5248 cd      print *,'it=',it,' emin=',emin
5249
5250 C Compute the contribution to SC energy and derivatives
5251         do iii=-1,1
5252
5253           do j=1,nlobit
5254 #ifdef OSF
5255             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5256             if(adexp.ne.adexp) adexp=1.0
5257             expfac=dexp(adexp)
5258 #else
5259             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5260 #endif
5261 cd          print *,'j=',j,' expfac=',expfac
5262             escloc_i=escloc_i+expfac
5263             do k=1,3
5264               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5265             enddo
5266             if (mixed) then
5267               do k=1,3,2
5268                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5269      &            +gaussc(k,2,j,it))*expfac
5270               enddo
5271             endif
5272           enddo
5273
5274         enddo ! iii
5275
5276         dersc(1)=dersc(1)/cos(theti)**2
5277         ddersc(1)=ddersc(1)/cos(theti)**2
5278         ddersc(3)=ddersc(3)
5279
5280         escloci=-(dlog(escloc_i)-emin)
5281         do j=1,3
5282           dersc(j)=dersc(j)/escloc_i
5283         enddo
5284         if (mixed) then
5285           do j=1,3,2
5286             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5287           enddo
5288         endif
5289       return
5290       end
5291 C------------------------------------------------------------------------------
5292       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5293       implicit real*8 (a-h,o-z)
5294       include 'DIMENSIONS'
5295       include 'COMMON.GEO'
5296       include 'COMMON.LOCAL'
5297       include 'COMMON.IOUNITS'
5298       common /sccalc/ time11,time12,time112,theti,it,nlobit
5299       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5300       double precision contr(maxlob)
5301       logical mixed
5302
5303       escloc_i=0.0D0
5304
5305       do j=1,3
5306         dersc(j)=0.0D0
5307       enddo
5308
5309       do j=1,nlobit
5310         do k=1,2
5311           z(k)=x(k)-censc(k,j,it)
5312         enddo
5313         z(3)=dwapi
5314         do k=1,3
5315           Axk=0.0D0
5316           do l=1,3
5317             Axk=Axk+gaussc(l,k,j,it)*z(l)
5318           enddo
5319           Ax(k,j)=Axk
5320         enddo
5321         expfac=0.0D0
5322         do k=1,3
5323           expfac=expfac+Ax(k,j)*z(k)
5324         enddo
5325         contr(j)=expfac
5326       enddo ! j
5327
5328 C As in the case of ebend, we want to avoid underflows in exponentiation and
5329 C subsequent NaNs and INFs in energy calculation.
5330 C Find the largest exponent
5331       emin=contr(1)
5332       do j=1,nlobit
5333         if (emin.gt.contr(j)) emin=contr(j)
5334       enddo
5335       emin=0.5D0*emin
5336
5337 C Compute the contribution to SC energy and derivatives
5338
5339       dersc12=0.0d0
5340       do j=1,nlobit
5341         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5342         escloc_i=escloc_i+expfac
5343         do k=1,2
5344           dersc(k)=dersc(k)+Ax(k,j)*expfac
5345         enddo
5346         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5347      &            +gaussc(1,2,j,it))*expfac
5348         dersc(3)=0.0d0
5349       enddo
5350
5351       dersc(1)=dersc(1)/cos(theti)**2
5352       dersc12=dersc12/cos(theti)**2
5353       escloci=-(dlog(escloc_i)-emin)
5354       do j=1,2
5355         dersc(j)=dersc(j)/escloc_i
5356       enddo
5357       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5358       return
5359       end
5360 #else
5361 c----------------------------------------------------------------------------------
5362       subroutine esc(escloc)
5363 C Calculate the local energy of a side chain and its derivatives in the
5364 C corresponding virtual-bond valence angles THETA and the spherical angles
5365 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5366 C added by Urszula Kozlowska. 07/11/2007
5367 C
5368       implicit real*8 (a-h,o-z)
5369       include 'DIMENSIONS'
5370       include 'COMMON.GEO'
5371       include 'COMMON.LOCAL'
5372       include 'COMMON.VAR'
5373       include 'COMMON.SCROT'
5374       include 'COMMON.INTERACT'
5375       include 'COMMON.DERIV'
5376       include 'COMMON.CHAIN'
5377       include 'COMMON.IOUNITS'
5378       include 'COMMON.NAMES'
5379       include 'COMMON.FFIELD'
5380       include 'COMMON.CONTROL'
5381       include 'COMMON.VECTORS'
5382       double precision x_prime(3),y_prime(3),z_prime(3)
5383      &    , sumene,dsc_i,dp2_i,x(65),
5384      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5385      &    de_dxx,de_dyy,de_dzz,de_dt
5386       double precision s1_t,s1_6_t,s2_t,s2_6_t
5387       double precision
5388      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5389      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5390      & dt_dCi(3),dt_dCi1(3)
5391       common /sccalc/ time11,time12,time112,theti,it,nlobit
5392       delta=0.02d0*pi
5393       escloc=0.0D0
5394       do i=loc_start,loc_end
5395         if (itype(i).eq.ntyp1) cycle
5396         costtab(i+1) =dcos(theta(i+1))
5397         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5398         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5399         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5400         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5401         cosfac=dsqrt(cosfac2)
5402         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5403         sinfac=dsqrt(sinfac2)
5404         it=iabs(itype(i))
5405         if (it.eq.10) goto 1
5406 c
5407 C  Compute the axes of tghe local cartesian coordinates system; store in
5408 c   x_prime, y_prime and z_prime
5409 c
5410         do j=1,3
5411           x_prime(j) = 0.00
5412           y_prime(j) = 0.00
5413           z_prime(j) = 0.00
5414         enddo
5415 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5416 C     &   dc_norm(3,i+nres)
5417         do j = 1,3
5418           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5419           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5420         enddo
5421         do j = 1,3
5422           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5423         enddo
5424 c       write (2,*) "i",i
5425 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5426 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5427 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5428 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5429 c      & " xy",scalar(x_prime(1),y_prime(1)),
5430 c      & " xz",scalar(x_prime(1),z_prime(1)),
5431 c      & " yy",scalar(y_prime(1),y_prime(1)),
5432 c      & " yz",scalar(y_prime(1),z_prime(1)),
5433 c      & " zz",scalar(z_prime(1),z_prime(1))
5434 c
5435 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5436 C to local coordinate system. Store in xx, yy, zz.
5437 c
5438         xx=0.0d0
5439         yy=0.0d0
5440         zz=0.0d0
5441         do j = 1,3
5442           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5443           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5444           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5445         enddo
5446
5447         xxtab(i)=xx
5448         yytab(i)=yy
5449         zztab(i)=zz
5450 C
5451 C Compute the energy of the ith side cbain
5452 C
5453 c        write (2,*) "xx",xx," yy",yy," zz",zz
5454         it=iabs(itype(i))
5455         do j = 1,65
5456           x(j) = sc_parmin(j,it)
5457         enddo
5458 #ifdef CHECK_COORD
5459 Cc diagnostics - remove later
5460         xx1 = dcos(alph(2))
5461         yy1 = dsin(alph(2))*dcos(omeg(2))
5462         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5463         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5464      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5465      &    xx1,yy1,zz1
5466 C,"  --- ", xx_w,yy_w,zz_w
5467 c end diagnostics
5468 #endif
5469         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5470      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5471      &   + x(10)*yy*zz
5472         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5473      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5474      & + x(20)*yy*zz
5475         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5476      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5477      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5478      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5479      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5480      &  +x(40)*xx*yy*zz
5481         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5482      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5483      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5484      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5485      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5486      &  +x(60)*xx*yy*zz
5487         dsc_i   = 0.743d0+x(61)
5488         dp2_i   = 1.9d0+x(62)
5489         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5490      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5491         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5492      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5493         s1=(1+x(63))/(0.1d0 + dscp1)
5494         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5495         s2=(1+x(65))/(0.1d0 + dscp2)
5496         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5497         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5498      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5499 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5500 c     &   sumene4,
5501 c     &   dscp1,dscp2,sumene
5502 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5503         escloc = escloc + sumene
5504 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5505 c     & ,zz,xx,yy
5506 c#define DEBUG
5507 #ifdef DEBUG
5508 C
5509 C This section to check the numerical derivatives of the energy of ith side
5510 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5511 C #define DEBUG in the code to turn it on.
5512 C
5513         write (2,*) "sumene               =",sumene
5514         aincr=1.0d-7
5515         xxsave=xx
5516         xx=xx+aincr
5517         write (2,*) xx,yy,zz
5518         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5519         de_dxx_num=(sumenep-sumene)/aincr
5520         xx=xxsave
5521         write (2,*) "xx+ sumene from enesc=",sumenep
5522         yysave=yy
5523         yy=yy+aincr
5524         write (2,*) xx,yy,zz
5525         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5526         de_dyy_num=(sumenep-sumene)/aincr
5527         yy=yysave
5528         write (2,*) "yy+ sumene from enesc=",sumenep
5529         zzsave=zz
5530         zz=zz+aincr
5531         write (2,*) xx,yy,zz
5532         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5533         de_dzz_num=(sumenep-sumene)/aincr
5534         zz=zzsave
5535         write (2,*) "zz+ sumene from enesc=",sumenep
5536         costsave=cost2tab(i+1)
5537         sintsave=sint2tab(i+1)
5538         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5539         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5540         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5541         de_dt_num=(sumenep-sumene)/aincr
5542         write (2,*) " t+ sumene from enesc=",sumenep
5543         cost2tab(i+1)=costsave
5544         sint2tab(i+1)=sintsave
5545 C End of diagnostics section.
5546 #endif
5547 C
5548 C Compute the gradient of esc
5549 C
5550 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5551         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5552         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5553         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5554         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5555         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5556         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5557         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5558         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5559         pom1=(sumene3*sint2tab(i+1)+sumene1)
5560      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5561         pom2=(sumene4*cost2tab(i+1)+sumene2)
5562      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5563         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5564         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5565      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5566      &  +x(40)*yy*zz
5567         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5568         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5569      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5570      &  +x(60)*yy*zz
5571         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5572      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5573      &        +(pom1+pom2)*pom_dx
5574 #ifdef DEBUG
5575         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5576 #endif
5577 C
5578         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5579         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5580      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5581      &  +x(40)*xx*zz
5582         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5583         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5584      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5585      &  +x(59)*zz**2 +x(60)*xx*zz
5586         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5587      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5588      &        +(pom1-pom2)*pom_dy
5589 #ifdef DEBUG
5590         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5591 #endif
5592 C
5593         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5594      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5595      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5596      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5597      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5598      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5599      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5600      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5601 #ifdef DEBUG
5602         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5603 #endif
5604 C
5605         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5606      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5607      &  +pom1*pom_dt1+pom2*pom_dt2
5608 #ifdef DEBUG
5609         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5610 #endif
5611 c#undef DEBUG
5612 c
5613 C
5614        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5615        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5616        cosfac2xx=cosfac2*xx
5617        sinfac2yy=sinfac2*yy
5618        do k = 1,3
5619          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5620      &      vbld_inv(i+1)
5621          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5622      &      vbld_inv(i)
5623          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5624          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5625 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5626 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5627 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5628 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5629          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5630          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5631          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5632          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5633          dZZ_Ci1(k)=0.0d0
5634          dZZ_Ci(k)=0.0d0
5635          do j=1,3
5636            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5637      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5638            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5639      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5640          enddo
5641
5642          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5643          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5644          dZZ_XYZ(k)=vbld_inv(i+nres)*
5645      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5646 c
5647          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5648          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5649        enddo
5650
5651        do k=1,3
5652          dXX_Ctab(k,i)=dXX_Ci(k)
5653          dXX_C1tab(k,i)=dXX_Ci1(k)
5654          dYY_Ctab(k,i)=dYY_Ci(k)
5655          dYY_C1tab(k,i)=dYY_Ci1(k)
5656          dZZ_Ctab(k,i)=dZZ_Ci(k)
5657          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5658          dXX_XYZtab(k,i)=dXX_XYZ(k)
5659          dYY_XYZtab(k,i)=dYY_XYZ(k)
5660          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5661        enddo
5662
5663        do k = 1,3
5664 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5665 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5666 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5667 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5668 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5669 c     &    dt_dci(k)
5670 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5671 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5672          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5673      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5674          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5675      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5676          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5677      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5678        enddo
5679 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5680 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5681
5682 C to check gradient call subroutine check_grad
5683
5684     1 continue
5685       enddo
5686       return
5687       end
5688 c------------------------------------------------------------------------------
5689       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5690       implicit none
5691       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5692      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5693       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5694      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5695      &   + x(10)*yy*zz
5696       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5697      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5698      & + x(20)*yy*zz
5699       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5700      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5701      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5702      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5703      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5704      &  +x(40)*xx*yy*zz
5705       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5706      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5707      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5708      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5709      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5710      &  +x(60)*xx*yy*zz
5711       dsc_i   = 0.743d0+x(61)
5712       dp2_i   = 1.9d0+x(62)
5713       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5714      &          *(xx*cost2+yy*sint2))
5715       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5716      &          *(xx*cost2-yy*sint2))
5717       s1=(1+x(63))/(0.1d0 + dscp1)
5718       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5719       s2=(1+x(65))/(0.1d0 + dscp2)
5720       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5721       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5722      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5723       enesc=sumene
5724       return
5725       end
5726 #endif
5727 c------------------------------------------------------------------------------
5728       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5729 C
5730 C This procedure calculates two-body contact function g(rij) and its derivative:
5731 C
5732 C           eps0ij                                     !       x < -1
5733 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5734 C            0                                         !       x > 1
5735 C
5736 C where x=(rij-r0ij)/delta
5737 C
5738 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5739 C
5740       implicit none
5741       double precision rij,r0ij,eps0ij,fcont,fprimcont
5742       double precision x,x2,x4,delta
5743 c     delta=0.02D0*r0ij
5744 c      delta=0.2D0*r0ij
5745       x=(rij-r0ij)/delta
5746       if (x.lt.-1.0D0) then
5747         fcont=eps0ij
5748         fprimcont=0.0D0
5749       else if (x.le.1.0D0) then
5750         x2=x*x
5751         x4=x2*x2
5752         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5753         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5754       else
5755         fcont=0.0D0
5756         fprimcont=0.0D0
5757       endif
5758       return
5759       end
5760 c------------------------------------------------------------------------------
5761       subroutine splinthet(theti,delta,ss,ssder)
5762       implicit real*8 (a-h,o-z)
5763       include 'DIMENSIONS'
5764       include 'COMMON.VAR'
5765       include 'COMMON.GEO'
5766       thetup=pi-delta
5767       thetlow=delta
5768       if (theti.gt.pipol) then
5769         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5770       else
5771         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5772         ssder=-ssder
5773       endif
5774       return
5775       end
5776 c------------------------------------------------------------------------------
5777       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5778       implicit none
5779       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5780       double precision ksi,ksi2,ksi3,a1,a2,a3
5781       a1=fprim0*delta/(f1-f0)
5782       a2=3.0d0-2.0d0*a1
5783       a3=a1-2.0d0
5784       ksi=(x-x0)/delta
5785       ksi2=ksi*ksi
5786       ksi3=ksi2*ksi
5787       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5788       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5789       return
5790       end
5791 c------------------------------------------------------------------------------
5792       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5793       implicit none
5794       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5795       double precision ksi,ksi2,ksi3,a1,a2,a3
5796       ksi=(x-x0)/delta
5797       ksi2=ksi*ksi
5798       ksi3=ksi2*ksi
5799       a1=fprim0x*delta
5800       a2=3*(f1x-f0x)-2*fprim0x*delta
5801       a3=fprim0x*delta-2*(f1x-f0x)
5802       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5803       return
5804       end
5805 C-----------------------------------------------------------------------------
5806 #ifdef CRYST_TOR
5807 C-----------------------------------------------------------------------------
5808       subroutine etor(etors,edihcnstr)
5809       implicit real*8 (a-h,o-z)
5810       include 'DIMENSIONS'
5811       include 'COMMON.VAR'
5812       include 'COMMON.GEO'
5813       include 'COMMON.LOCAL'
5814       include 'COMMON.TORSION'
5815       include 'COMMON.INTERACT'
5816       include 'COMMON.DERIV'
5817       include 'COMMON.CHAIN'
5818       include 'COMMON.NAMES'
5819       include 'COMMON.IOUNITS'
5820       include 'COMMON.FFIELD'
5821       include 'COMMON.TORCNSTR'
5822       include 'COMMON.CONTROL'
5823       logical lprn
5824 C Set lprn=.true. for debugging
5825       lprn=.false.
5826 c      lprn=.true.
5827       etors=0.0D0
5828       do i=iphi_start,iphi_end
5829       etors_ii=0.0D0
5830         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5831      &      .or. itype(i).eq.ntyp1) cycle
5832         itori=itortyp(itype(i-2))
5833         itori1=itortyp(itype(i-1))
5834         phii=phi(i)
5835         gloci=0.0D0
5836 C Proline-Proline pair is a special case...
5837         if (itori.eq.3 .and. itori1.eq.3) then
5838           if (phii.gt.-dwapi3) then
5839             cosphi=dcos(3*phii)
5840             fac=1.0D0/(1.0D0-cosphi)
5841             etorsi=v1(1,3,3)*fac
5842             etorsi=etorsi+etorsi
5843             etors=etors+etorsi-v1(1,3,3)
5844             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5845             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5846           endif
5847           do j=1,3
5848             v1ij=v1(j+1,itori,itori1)
5849             v2ij=v2(j+1,itori,itori1)
5850             cosphi=dcos(j*phii)
5851             sinphi=dsin(j*phii)
5852             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5853             if (energy_dec) etors_ii=etors_ii+
5854      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5855             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5856           enddo
5857         else
5858           do j=1,nterm_old
5859             v1ij=v1(j,itori,itori1)
5860             v2ij=v2(j,itori,itori1)
5861             cosphi=dcos(j*phii)
5862             sinphi=dsin(j*phii)
5863             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5864             if (energy_dec) etors_ii=etors_ii+
5865      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5866             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5867           enddo
5868         endif
5869         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5870              'etor',i,etors_ii
5871         if (lprn)
5872      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5873      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5874      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5875         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5876 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5877       enddo
5878 ! 6/20/98 - dihedral angle constraints
5879       edihcnstr=0.0d0
5880       do i=1,ndih_constr
5881         itori=idih_constr(i)
5882         phii=phi(itori)
5883         difi=phii-phi0(i)
5884         if (difi.gt.drange(i)) then
5885           difi=difi-drange(i)
5886           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5887           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5888         else if (difi.lt.-drange(i)) then
5889           difi=difi+drange(i)
5890           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5891           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5892         endif
5893 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5894 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5895       enddo
5896 !      write (iout,*) 'edihcnstr',edihcnstr
5897       return
5898       end
5899 c------------------------------------------------------------------------------
5900       subroutine etor_d(etors_d)
5901       etors_d=0.0d0
5902       return
5903       end
5904 c----------------------------------------------------------------------------
5905 #else
5906       subroutine etor(etors,edihcnstr)
5907       implicit real*8 (a-h,o-z)
5908       include 'DIMENSIONS'
5909       include 'COMMON.VAR'
5910       include 'COMMON.GEO'
5911       include 'COMMON.LOCAL'
5912       include 'COMMON.TORSION'
5913       include 'COMMON.INTERACT'
5914       include 'COMMON.DERIV'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.NAMES'
5917       include 'COMMON.IOUNITS'
5918       include 'COMMON.FFIELD'
5919       include 'COMMON.TORCNSTR'
5920       include 'COMMON.CONTROL'
5921       logical lprn
5922 C Set lprn=.true. for debugging
5923       lprn=.false.
5924 c     lprn=.true.
5925       etors=0.0D0
5926       do i=iphi_start,iphi_end
5927 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5928 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5929 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5930 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5931          if ((itype(i-3).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5932      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
5933 C For introducing the NH3+ and COO- group please check the etor_d for reference
5934 C and guidance
5935         etors_ii=0.0D0
5936          if (iabs(itype(i)).eq.20) then
5937          iblock=2
5938          else
5939          iblock=1
5940          endif
5941         itori=itortyp(itype(i-2))
5942         itori1=itortyp(itype(i-1))
5943         phii=phi(i)
5944         gloci=0.0D0
5945 C Regular cosine and sine terms
5946         do j=1,nterm(itori,itori1,iblock)
5947           v1ij=v1(j,itori,itori1,iblock)
5948           v2ij=v2(j,itori,itori1,iblock)
5949           cosphi=dcos(j*phii)
5950           sinphi=dsin(j*phii)
5951           etors=etors+v1ij*cosphi+v2ij*sinphi
5952           if (energy_dec) etors_ii=etors_ii+
5953      &                v1ij*cosphi+v2ij*sinphi
5954           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5955         enddo
5956 C Lorentz terms
5957 C                         v1
5958 C  E = SUM ----------------------------------- - v1
5959 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5960 C
5961         cosphi=dcos(0.5d0*phii)
5962         sinphi=dsin(0.5d0*phii)
5963         do j=1,nlor(itori,itori1,iblock)
5964           vl1ij=vlor1(j,itori,itori1)
5965           vl2ij=vlor2(j,itori,itori1)
5966           vl3ij=vlor3(j,itori,itori1)
5967           pom=vl2ij*cosphi+vl3ij*sinphi
5968           pom1=1.0d0/(pom*pom+1.0d0)
5969           etors=etors+vl1ij*pom1
5970           if (energy_dec) etors_ii=etors_ii+
5971      &                vl1ij*pom1
5972           pom=-pom*pom1*pom1
5973           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5974         enddo
5975 C Subtract the constant term
5976         etors=etors-v0(itori,itori1,iblock)
5977           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5978      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5979         if (lprn)
5980      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5981      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5982      &  (v1(j,itori,itori1,iblock),j=1,6),
5983      &  (v2(j,itori,itori1,iblock),j=1,6)
5984         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5985 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5986       enddo
5987 ! 6/20/98 - dihedral angle constraints
5988       edihcnstr=0.0d0
5989 c      do i=1,ndih_constr
5990       do i=idihconstr_start,idihconstr_end
5991         itori=idih_constr(i)
5992         phii=phi(itori)
5993         difi=pinorm(phii-phi0(i))
5994         if (difi.gt.drange(i)) then
5995           difi=difi-drange(i)
5996           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5997           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5998         else if (difi.lt.-drange(i)) then
5999           difi=difi+drange(i)
6000           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6001           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6002         else
6003           difi=0.0
6004         endif
6005 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6006 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6007 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6008       enddo
6009 cd       write (iout,*) 'edihcnstr',edihcnstr
6010       return
6011       end
6012 c----------------------------------------------------------------------------
6013       subroutine etor_d(etors_d)
6014 C 6/23/01 Compute double torsional energy
6015       implicit real*8 (a-h,o-z)
6016       include 'DIMENSIONS'
6017       include 'COMMON.VAR'
6018       include 'COMMON.GEO'
6019       include 'COMMON.LOCAL'
6020       include 'COMMON.TORSION'
6021       include 'COMMON.INTERACT'
6022       include 'COMMON.DERIV'
6023       include 'COMMON.CHAIN'
6024       include 'COMMON.NAMES'
6025       include 'COMMON.IOUNITS'
6026       include 'COMMON.FFIELD'
6027       include 'COMMON.TORCNSTR'
6028       logical lprn
6029 C Set lprn=.true. for debugging
6030       lprn=.false.
6031 c     lprn=.true.
6032       etors_d=0.0D0
6033 c      write(iout,*) "a tu??"
6034       do i=iphid_start,iphid_end
6035 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6036         if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6037      &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6038      &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6039      &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6040         itori=itortyp(itype(i-2))
6041         itori1=itortyp(itype(i-1))
6042         itori2=itortyp(itype(i))
6043         phii=phi(i)
6044         phii1=phi(i+1)
6045         gloci1=0.0D0
6046         gloci2=0.0D0
6047         iblock=1
6048         if (iabs(itype(i+1)).eq.20) iblock=2
6049 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6050 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6051 C        if (itype(i+1).eq.ntyp1) iblock=3
6052 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6053 C IS or IS NOT need for this
6054 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6055 C        is (itype(i-3).eq.ntyp1) ntblock=2
6056 C        ntblock is N-terminal blocking group
6057
6058 C Regular cosine and sine terms
6059         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6060 C Example of changes for NH3+ blocking group
6061 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6062 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6063           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6064           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6065           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6066           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6067           cosphi1=dcos(j*phii)
6068           sinphi1=dsin(j*phii)
6069           cosphi2=dcos(j*phii1)
6070           sinphi2=dsin(j*phii1)
6071           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6072      &     v2cij*cosphi2+v2sij*sinphi2
6073           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6074           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6075         enddo
6076         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6077           do l=1,k-1
6078             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6079             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6080             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6081             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6082             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6083             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6084             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6085             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6086             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6087      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6088             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6089      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6090             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6091      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6092           enddo
6093         enddo
6094         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6095         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6096       enddo
6097       return
6098       end
6099 #endif
6100 c------------------------------------------------------------------------------
6101       subroutine eback_sc_corr(esccor)
6102 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6103 c        conformational states; temporarily implemented as differences
6104 c        between UNRES torsional potentials (dependent on three types of
6105 c        residues) and the torsional potentials dependent on all 20 types
6106 c        of residues computed from AM1  energy surfaces of terminally-blocked
6107 c        amino-acid residues.
6108       implicit real*8 (a-h,o-z)
6109       include 'DIMENSIONS'
6110       include 'COMMON.VAR'
6111       include 'COMMON.GEO'
6112       include 'COMMON.LOCAL'
6113       include 'COMMON.TORSION'
6114       include 'COMMON.SCCOR'
6115       include 'COMMON.INTERACT'
6116       include 'COMMON.DERIV'
6117       include 'COMMON.CHAIN'
6118       include 'COMMON.NAMES'
6119       include 'COMMON.IOUNITS'
6120       include 'COMMON.FFIELD'
6121       include 'COMMON.CONTROL'
6122       logical lprn
6123 C Set lprn=.true. for debugging
6124       lprn=.false.
6125 c      lprn=.true.
6126 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6127       esccor=0.0D0
6128       do i=itau_start,itau_end
6129         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6130         esccor_ii=0.0D0
6131         isccori=isccortyp(itype(i-2))
6132         isccori1=isccortyp(itype(i-1))
6133 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6134         phii=phi(i)
6135         do intertyp=1,3 !intertyp
6136 cc Added 09 May 2012 (Adasko)
6137 cc  Intertyp means interaction type of backbone mainchain correlation:
6138 c   1 = SC...Ca...Ca...Ca
6139 c   2 = Ca...Ca...Ca...SC
6140 c   3 = SC...Ca...Ca...SCi
6141         gloci=0.0D0
6142         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6143      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6144      &      (itype(i-1).eq.ntyp1)))
6145      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6146      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6147      &     .or.(itype(i).eq.ntyp1)))
6148      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6149      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6150      &      (itype(i-3).eq.ntyp1)))) cycle
6151         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6152         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6153      & cycle
6154        do j=1,nterm_sccor(isccori,isccori1)
6155           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6156           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6157           cosphi=dcos(j*tauangle(intertyp,i))
6158           sinphi=dsin(j*tauangle(intertyp,i))
6159           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6160           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6161         enddo
6162 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6163         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6164         if (lprn)
6165      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6166      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6167      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6168      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6169         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6170        enddo !intertyp
6171       enddo
6172
6173       return
6174       end
6175 c----------------------------------------------------------------------------
6176       subroutine multibody(ecorr)
6177 C This subroutine calculates multi-body contributions to energy following
6178 C the idea of Skolnick et al. If side chains I and J make a contact and
6179 C at the same time side chains I+1 and J+1 make a contact, an extra
6180 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6181       implicit real*8 (a-h,o-z)
6182       include 'DIMENSIONS'
6183       include 'COMMON.IOUNITS'
6184       include 'COMMON.DERIV'
6185       include 'COMMON.INTERACT'
6186       include 'COMMON.CONTACTS'
6187       double precision gx(3),gx1(3)
6188       logical lprn
6189
6190 C Set lprn=.true. for debugging
6191       lprn=.false.
6192
6193       if (lprn) then
6194         write (iout,'(a)') 'Contact function values:'
6195         do i=nnt,nct-2
6196           write (iout,'(i2,20(1x,i2,f10.5))')
6197      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6198         enddo
6199       endif
6200       ecorr=0.0D0
6201       do i=nnt,nct
6202         do j=1,3
6203           gradcorr(j,i)=0.0D0
6204           gradxorr(j,i)=0.0D0
6205         enddo
6206       enddo
6207       do i=nnt,nct-2
6208
6209         DO ISHIFT = 3,4
6210
6211         i1=i+ishift
6212         num_conti=num_cont(i)
6213         num_conti1=num_cont(i1)
6214         do jj=1,num_conti
6215           j=jcont(jj,i)
6216           do kk=1,num_conti1
6217             j1=jcont(kk,i1)
6218             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6219 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6220 cd   &                   ' ishift=',ishift
6221 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6222 C The system gains extra energy.
6223               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6224             endif   ! j1==j+-ishift
6225           enddo     ! kk
6226         enddo       ! jj
6227
6228         ENDDO ! ISHIFT
6229
6230       enddo         ! i
6231       return
6232       end
6233 c------------------------------------------------------------------------------
6234       double precision function esccorr(i,j,k,l,jj,kk)
6235       implicit real*8 (a-h,o-z)
6236       include 'DIMENSIONS'
6237       include 'COMMON.IOUNITS'
6238       include 'COMMON.DERIV'
6239       include 'COMMON.INTERACT'
6240       include 'COMMON.CONTACTS'
6241       double precision gx(3),gx1(3)
6242       logical lprn
6243       lprn=.false.
6244       eij=facont(jj,i)
6245       ekl=facont(kk,k)
6246 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6247 C Calculate the multi-body contribution to energy.
6248 C Calculate multi-body contributions to the gradient.
6249 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6250 cd   & k,l,(gacont(m,kk,k),m=1,3)
6251       do m=1,3
6252         gx(m) =ekl*gacont(m,jj,i)
6253         gx1(m)=eij*gacont(m,kk,k)
6254         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6255         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6256         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6257         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6258       enddo
6259       do m=i,j-1
6260         do ll=1,3
6261           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6262         enddo
6263       enddo
6264       do m=k,l-1
6265         do ll=1,3
6266           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6267         enddo
6268       enddo
6269       esccorr=-eij*ekl
6270       return
6271       end
6272 c------------------------------------------------------------------------------
6273       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6274 C This subroutine calculates multi-body contributions to hydrogen-bonding
6275       implicit real*8 (a-h,o-z)
6276       include 'DIMENSIONS'
6277       include 'COMMON.IOUNITS'
6278 #ifdef MPI
6279       include "mpif.h"
6280       parameter (max_cont=maxconts)
6281       parameter (max_dim=26)
6282       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6283       double precision zapas(max_dim,maxconts,max_fg_procs),
6284      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6285       common /przechowalnia/ zapas
6286       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6287      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6288 #endif
6289       include 'COMMON.SETUP'
6290       include 'COMMON.FFIELD'
6291       include 'COMMON.DERIV'
6292       include 'COMMON.INTERACT'
6293       include 'COMMON.CONTACTS'
6294       include 'COMMON.CONTROL'
6295       include 'COMMON.LOCAL'
6296       double precision gx(3),gx1(3),time00
6297       logical lprn,ldone
6298
6299 C Set lprn=.true. for debugging
6300       lprn=.false.
6301 #ifdef MPI
6302       n_corr=0
6303       n_corr1=0
6304       if (nfgtasks.le.1) goto 30
6305       if (lprn) then
6306         write (iout,'(a)') 'Contact function values before RECEIVE:'
6307         do i=nnt,nct-2
6308           write (iout,'(2i3,50(1x,i2,f5.2))')
6309      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6310      &    j=1,num_cont_hb(i))
6311         enddo
6312       endif
6313       call flush(iout)
6314       do i=1,ntask_cont_from
6315         ncont_recv(i)=0
6316       enddo
6317       do i=1,ntask_cont_to
6318         ncont_sent(i)=0
6319       enddo
6320 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6321 c     & ntask_cont_to
6322 C Make the list of contacts to send to send to other procesors
6323 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6324 c      call flush(iout)
6325       do i=iturn3_start,iturn3_end
6326 c        write (iout,*) "make contact list turn3",i," num_cont",
6327 c     &    num_cont_hb(i)
6328         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6329       enddo
6330       do i=iturn4_start,iturn4_end
6331 c        write (iout,*) "make contact list turn4",i," num_cont",
6332 c     &   num_cont_hb(i)
6333         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6334       enddo
6335       do ii=1,nat_sent
6336         i=iat_sent(ii)
6337 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6338 c     &    num_cont_hb(i)
6339         do j=1,num_cont_hb(i)
6340         do k=1,4
6341           jjc=jcont_hb(j,i)
6342           iproc=iint_sent_local(k,jjc,ii)
6343 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6344           if (iproc.gt.0) then
6345             ncont_sent(iproc)=ncont_sent(iproc)+1
6346             nn=ncont_sent(iproc)
6347             zapas(1,nn,iproc)=i
6348             zapas(2,nn,iproc)=jjc
6349             zapas(3,nn,iproc)=facont_hb(j,i)
6350             zapas(4,nn,iproc)=ees0p(j,i)
6351             zapas(5,nn,iproc)=ees0m(j,i)
6352             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6353             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6354             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6355             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6356             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6357             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6358             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6359             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6360             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6361             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6362             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6363             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6364             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6365             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6366             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6367             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6368             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6369             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6370             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6371             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6372             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6373           endif
6374         enddo
6375         enddo
6376       enddo
6377       if (lprn) then
6378       write (iout,*)
6379      &  "Numbers of contacts to be sent to other processors",
6380      &  (ncont_sent(i),i=1,ntask_cont_to)
6381       write (iout,*) "Contacts sent"
6382       do ii=1,ntask_cont_to
6383         nn=ncont_sent(ii)
6384         iproc=itask_cont_to(ii)
6385         write (iout,*) nn," contacts to processor",iproc,
6386      &   " of CONT_TO_COMM group"
6387         do i=1,nn
6388           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6389         enddo
6390       enddo
6391       call flush(iout)
6392       endif
6393       CorrelType=477
6394       CorrelID=fg_rank+1
6395       CorrelType1=478
6396       CorrelID1=nfgtasks+fg_rank+1
6397       ireq=0
6398 C Receive the numbers of needed contacts from other processors
6399       do ii=1,ntask_cont_from
6400         iproc=itask_cont_from(ii)
6401         ireq=ireq+1
6402         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6403      &    FG_COMM,req(ireq),IERR)
6404       enddo
6405 c      write (iout,*) "IRECV ended"
6406 c      call flush(iout)
6407 C Send the number of contacts needed by other processors
6408       do ii=1,ntask_cont_to
6409         iproc=itask_cont_to(ii)
6410         ireq=ireq+1
6411         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6412      &    FG_COMM,req(ireq),IERR)
6413       enddo
6414 c      write (iout,*) "ISEND ended"
6415 c      write (iout,*) "number of requests (nn)",ireq
6416       call flush(iout)
6417       if (ireq.gt.0)
6418      &  call MPI_Waitall(ireq,req,status_array,ierr)
6419 c      write (iout,*)
6420 c     &  "Numbers of contacts to be received from other processors",
6421 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6422 c      call flush(iout)
6423 C Receive contacts
6424       ireq=0
6425       do ii=1,ntask_cont_from
6426         iproc=itask_cont_from(ii)
6427         nn=ncont_recv(ii)
6428 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6429 c     &   " of CONT_TO_COMM group"
6430         call flush(iout)
6431         if (nn.gt.0) then
6432           ireq=ireq+1
6433           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6434      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6435 c          write (iout,*) "ireq,req",ireq,req(ireq)
6436         endif
6437       enddo
6438 C Send the contacts to processors that need them
6439       do ii=1,ntask_cont_to
6440         iproc=itask_cont_to(ii)
6441         nn=ncont_sent(ii)
6442 c        write (iout,*) nn," contacts to processor",iproc,
6443 c     &   " of CONT_TO_COMM group"
6444         if (nn.gt.0) then
6445           ireq=ireq+1
6446           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6447      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6448 c          write (iout,*) "ireq,req",ireq,req(ireq)
6449 c          do i=1,nn
6450 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6451 c          enddo
6452         endif
6453       enddo
6454 c      write (iout,*) "number of requests (contacts)",ireq
6455 c      write (iout,*) "req",(req(i),i=1,4)
6456 c      call flush(iout)
6457       if (ireq.gt.0)
6458      & call MPI_Waitall(ireq,req,status_array,ierr)
6459       do iii=1,ntask_cont_from
6460         iproc=itask_cont_from(iii)
6461         nn=ncont_recv(iii)
6462         if (lprn) then
6463         write (iout,*) "Received",nn," contacts from processor",iproc,
6464      &   " of CONT_FROM_COMM group"
6465         call flush(iout)
6466         do i=1,nn
6467           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6468         enddo
6469         call flush(iout)
6470         endif
6471         do i=1,nn
6472           ii=zapas_recv(1,i,iii)
6473 c Flag the received contacts to prevent double-counting
6474           jj=-zapas_recv(2,i,iii)
6475 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6476 c          call flush(iout)
6477           nnn=num_cont_hb(ii)+1
6478           num_cont_hb(ii)=nnn
6479           jcont_hb(nnn,ii)=jj
6480           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6481           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6482           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6483           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6484           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6485           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6486           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6487           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6488           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6489           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6490           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6491           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6492           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6493           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6494           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6495           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6496           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6497           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6498           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6499           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6500           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6501           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6502           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6503           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6504         enddo
6505       enddo
6506       call flush(iout)
6507       if (lprn) then
6508         write (iout,'(a)') 'Contact function values after receive:'
6509         do i=nnt,nct-2
6510           write (iout,'(2i3,50(1x,i3,f5.2))')
6511      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6512      &    j=1,num_cont_hb(i))
6513         enddo
6514         call flush(iout)
6515       endif
6516    30 continue
6517 #endif
6518       if (lprn) then
6519         write (iout,'(a)') 'Contact function values:'
6520         do i=nnt,nct-2
6521           write (iout,'(2i3,50(1x,i3,f5.2))')
6522      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6523      &    j=1,num_cont_hb(i))
6524         enddo
6525       endif
6526       ecorr=0.0D0
6527 C Remove the loop below after debugging !!!
6528       do i=nnt,nct
6529         do j=1,3
6530           gradcorr(j,i)=0.0D0
6531           gradxorr(j,i)=0.0D0
6532         enddo
6533       enddo
6534 C Calculate the local-electrostatic correlation terms
6535       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6536         i1=i+1
6537         num_conti=num_cont_hb(i)
6538         num_conti1=num_cont_hb(i+1)
6539         do jj=1,num_conti
6540           j=jcont_hb(jj,i)
6541           jp=iabs(j)
6542           do kk=1,num_conti1
6543             j1=jcont_hb(kk,i1)
6544             jp1=iabs(j1)
6545 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6546 c     &         ' jj=',jj,' kk=',kk
6547             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6548      &          .or. j.lt.0 .and. j1.gt.0) .and.
6549      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6550 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6551 C The system gains extra energy.
6552               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6553               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6554      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6555               n_corr=n_corr+1
6556             else if (j1.eq.j) then
6557 C Contacts I-J and I-(J+1) occur simultaneously.
6558 C The system loses extra energy.
6559 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6560             endif
6561           enddo ! kk
6562           do kk=1,num_conti
6563             j1=jcont_hb(kk,i)
6564 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6565 c    &         ' jj=',jj,' kk=',kk
6566             if (j1.eq.j+1) then
6567 C Contacts I-J and (I+1)-J occur simultaneously.
6568 C The system loses extra energy.
6569 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6570             endif ! j1==j+1
6571           enddo ! kk
6572         enddo ! jj
6573       enddo ! i
6574       return
6575       end
6576 c------------------------------------------------------------------------------
6577       subroutine add_hb_contact(ii,jj,itask)
6578       implicit real*8 (a-h,o-z)
6579       include "DIMENSIONS"
6580       include "COMMON.IOUNITS"
6581       integer max_cont
6582       integer max_dim
6583       parameter (max_cont=maxconts)
6584       parameter (max_dim=26)
6585       include "COMMON.CONTACTS"
6586       double precision zapas(max_dim,maxconts,max_fg_procs),
6587      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6588       common /przechowalnia/ zapas
6589       integer i,j,ii,jj,iproc,itask(4),nn
6590 c      write (iout,*) "itask",itask
6591       do i=1,2
6592         iproc=itask(i)
6593         if (iproc.gt.0) then
6594           do j=1,num_cont_hb(ii)
6595             jjc=jcont_hb(j,ii)
6596 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6597             if (jjc.eq.jj) then
6598               ncont_sent(iproc)=ncont_sent(iproc)+1
6599               nn=ncont_sent(iproc)
6600               zapas(1,nn,iproc)=ii
6601               zapas(2,nn,iproc)=jjc
6602               zapas(3,nn,iproc)=facont_hb(j,ii)
6603               zapas(4,nn,iproc)=ees0p(j,ii)
6604               zapas(5,nn,iproc)=ees0m(j,ii)
6605               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6606               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6607               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6608               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6609               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6610               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6611               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6612               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6613               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6614               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6615               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6616               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6617               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6618               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6619               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6620               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6621               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6622               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6623               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6624               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6625               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6626               exit
6627             endif
6628           enddo
6629         endif
6630       enddo
6631       return
6632       end
6633 c------------------------------------------------------------------------------
6634       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6635      &  n_corr1)
6636 C This subroutine calculates multi-body contributions to hydrogen-bonding
6637       implicit real*8 (a-h,o-z)
6638       include 'DIMENSIONS'
6639       include 'COMMON.IOUNITS'
6640 #ifdef MPI
6641       include "mpif.h"
6642       parameter (max_cont=maxconts)
6643       parameter (max_dim=70)
6644       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6645       double precision zapas(max_dim,maxconts,max_fg_procs),
6646      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6647       common /przechowalnia/ zapas
6648       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6649      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6650 #endif
6651       include 'COMMON.SETUP'
6652       include 'COMMON.FFIELD'
6653       include 'COMMON.DERIV'
6654       include 'COMMON.LOCAL'
6655       include 'COMMON.INTERACT'
6656       include 'COMMON.CONTACTS'
6657       include 'COMMON.CHAIN'
6658       include 'COMMON.CONTROL'
6659       double precision gx(3),gx1(3)
6660       integer num_cont_hb_old(maxres)
6661       logical lprn,ldone
6662       double precision eello4,eello5,eelo6,eello_turn6
6663       external eello4,eello5,eello6,eello_turn6
6664 C Set lprn=.true. for debugging
6665       lprn=.false.
6666       eturn6=0.0d0
6667 #ifdef MPI
6668       do i=1,nres
6669         num_cont_hb_old(i)=num_cont_hb(i)
6670       enddo
6671       n_corr=0
6672       n_corr1=0
6673       if (nfgtasks.le.1) goto 30
6674       if (lprn) then
6675         write (iout,'(a)') 'Contact function values before RECEIVE:'
6676         do i=nnt,nct-2
6677           write (iout,'(2i3,50(1x,i2,f5.2))')
6678      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6679      &    j=1,num_cont_hb(i))
6680         enddo
6681       endif
6682       call flush(iout)
6683       do i=1,ntask_cont_from
6684         ncont_recv(i)=0
6685       enddo
6686       do i=1,ntask_cont_to
6687         ncont_sent(i)=0
6688       enddo
6689 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6690 c     & ntask_cont_to
6691 C Make the list of contacts to send to send to other procesors
6692       do i=iturn3_start,iturn3_end
6693 c        write (iout,*) "make contact list turn3",i," num_cont",
6694 c     &    num_cont_hb(i)
6695         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6696       enddo
6697       do i=iturn4_start,iturn4_end
6698 c        write (iout,*) "make contact list turn4",i," num_cont",
6699 c     &   num_cont_hb(i)
6700         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6701       enddo
6702       do ii=1,nat_sent
6703         i=iat_sent(ii)
6704 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6705 c     &    num_cont_hb(i)
6706         do j=1,num_cont_hb(i)
6707         do k=1,4
6708           jjc=jcont_hb(j,i)
6709           iproc=iint_sent_local(k,jjc,ii)
6710 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6711           if (iproc.ne.0) then
6712             ncont_sent(iproc)=ncont_sent(iproc)+1
6713             nn=ncont_sent(iproc)
6714             zapas(1,nn,iproc)=i
6715             zapas(2,nn,iproc)=jjc
6716             zapas(3,nn,iproc)=d_cont(j,i)
6717             ind=3
6718             do kk=1,3
6719               ind=ind+1
6720               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6721             enddo
6722             do kk=1,2
6723               do ll=1,2
6724                 ind=ind+1
6725                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6726               enddo
6727             enddo
6728             do jj=1,5
6729               do kk=1,3
6730                 do ll=1,2
6731                   do mm=1,2
6732                     ind=ind+1
6733                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6734                   enddo
6735                 enddo
6736               enddo
6737             enddo
6738           endif
6739         enddo
6740         enddo
6741       enddo
6742       if (lprn) then
6743       write (iout,*)
6744      &  "Numbers of contacts to be sent to other processors",
6745      &  (ncont_sent(i),i=1,ntask_cont_to)
6746       write (iout,*) "Contacts sent"
6747       do ii=1,ntask_cont_to
6748         nn=ncont_sent(ii)
6749         iproc=itask_cont_to(ii)
6750         write (iout,*) nn," contacts to processor",iproc,
6751      &   " of CONT_TO_COMM group"
6752         do i=1,nn
6753           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6754         enddo
6755       enddo
6756       call flush(iout)
6757       endif
6758       CorrelType=477
6759       CorrelID=fg_rank+1
6760       CorrelType1=478
6761       CorrelID1=nfgtasks+fg_rank+1
6762       ireq=0
6763 C Receive the numbers of needed contacts from other processors
6764       do ii=1,ntask_cont_from
6765         iproc=itask_cont_from(ii)
6766         ireq=ireq+1
6767         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6768      &    FG_COMM,req(ireq),IERR)
6769       enddo
6770 c      write (iout,*) "IRECV ended"
6771 c      call flush(iout)
6772 C Send the number of contacts needed by other processors
6773       do ii=1,ntask_cont_to
6774         iproc=itask_cont_to(ii)
6775         ireq=ireq+1
6776         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6777      &    FG_COMM,req(ireq),IERR)
6778       enddo
6779 c      write (iout,*) "ISEND ended"
6780 c      write (iout,*) "number of requests (nn)",ireq
6781       call flush(iout)
6782       if (ireq.gt.0)
6783      &  call MPI_Waitall(ireq,req,status_array,ierr)
6784 c      write (iout,*)
6785 c     &  "Numbers of contacts to be received from other processors",
6786 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6787 c      call flush(iout)
6788 C Receive contacts
6789       ireq=0
6790       do ii=1,ntask_cont_from
6791         iproc=itask_cont_from(ii)
6792         nn=ncont_recv(ii)
6793 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6794 c     &   " of CONT_TO_COMM group"
6795         call flush(iout)
6796         if (nn.gt.0) then
6797           ireq=ireq+1
6798           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6799      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6800 c          write (iout,*) "ireq,req",ireq,req(ireq)
6801         endif
6802       enddo
6803 C Send the contacts to processors that need them
6804       do ii=1,ntask_cont_to
6805         iproc=itask_cont_to(ii)
6806         nn=ncont_sent(ii)
6807 c        write (iout,*) nn," contacts to processor",iproc,
6808 c     &   " of CONT_TO_COMM group"
6809         if (nn.gt.0) then
6810           ireq=ireq+1
6811           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6812      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6813 c          write (iout,*) "ireq,req",ireq,req(ireq)
6814 c          do i=1,nn
6815 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6816 c          enddo
6817         endif
6818       enddo
6819 c      write (iout,*) "number of requests (contacts)",ireq
6820 c      write (iout,*) "req",(req(i),i=1,4)
6821 c      call flush(iout)
6822       if (ireq.gt.0)
6823      & call MPI_Waitall(ireq,req,status_array,ierr)
6824       do iii=1,ntask_cont_from
6825         iproc=itask_cont_from(iii)
6826         nn=ncont_recv(iii)
6827         if (lprn) then
6828         write (iout,*) "Received",nn," contacts from processor",iproc,
6829      &   " of CONT_FROM_COMM group"
6830         call flush(iout)
6831         do i=1,nn
6832           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6833         enddo
6834         call flush(iout)
6835         endif
6836         do i=1,nn
6837           ii=zapas_recv(1,i,iii)
6838 c Flag the received contacts to prevent double-counting
6839           jj=-zapas_recv(2,i,iii)
6840 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6841 c          call flush(iout)
6842           nnn=num_cont_hb(ii)+1
6843           num_cont_hb(ii)=nnn
6844           jcont_hb(nnn,ii)=jj
6845           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6846           ind=3
6847           do kk=1,3
6848             ind=ind+1
6849             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6850           enddo
6851           do kk=1,2
6852             do ll=1,2
6853               ind=ind+1
6854               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6855             enddo
6856           enddo
6857           do jj=1,5
6858             do kk=1,3
6859               do ll=1,2
6860                 do mm=1,2
6861                   ind=ind+1
6862                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6863                 enddo
6864               enddo
6865             enddo
6866           enddo
6867         enddo
6868       enddo
6869       call flush(iout)
6870       if (lprn) then
6871         write (iout,'(a)') 'Contact function values after receive:'
6872         do i=nnt,nct-2
6873           write (iout,'(2i3,50(1x,i3,5f6.3))')
6874      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6875      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6876         enddo
6877         call flush(iout)
6878       endif
6879    30 continue
6880 #endif
6881       if (lprn) then
6882         write (iout,'(a)') 'Contact function values:'
6883         do i=nnt,nct-2
6884           write (iout,'(2i3,50(1x,i2,5f6.3))')
6885      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6886      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6887         enddo
6888       endif
6889       ecorr=0.0D0
6890       ecorr5=0.0d0
6891       ecorr6=0.0d0
6892 C Remove the loop below after debugging !!!
6893       do i=nnt,nct
6894         do j=1,3
6895           gradcorr(j,i)=0.0D0
6896           gradxorr(j,i)=0.0D0
6897         enddo
6898       enddo
6899 C Calculate the dipole-dipole interaction energies
6900       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6901       do i=iatel_s,iatel_e+1
6902         num_conti=num_cont_hb(i)
6903         do jj=1,num_conti
6904           j=jcont_hb(jj,i)
6905 #ifdef MOMENT
6906           call dipole(i,j,jj)
6907 #endif
6908         enddo
6909       enddo
6910       endif
6911 C Calculate the local-electrostatic correlation terms
6912 c                write (iout,*) "gradcorr5 in eello5 before loop"
6913 c                do iii=1,nres
6914 c                  write (iout,'(i5,3f10.5)')
6915 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6916 c                enddo
6917       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6918 c        write (iout,*) "corr loop i",i
6919         i1=i+1
6920         num_conti=num_cont_hb(i)
6921         num_conti1=num_cont_hb(i+1)
6922         do jj=1,num_conti
6923           j=jcont_hb(jj,i)
6924           jp=iabs(j)
6925           do kk=1,num_conti1
6926             j1=jcont_hb(kk,i1)
6927             jp1=iabs(j1)
6928 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6929 c     &         ' jj=',jj,' kk=',kk
6930 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6931             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6932      &          .or. j.lt.0 .and. j1.gt.0) .and.
6933      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6934 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6935 C The system gains extra energy.
6936               n_corr=n_corr+1
6937               sqd1=dsqrt(d_cont(jj,i))
6938               sqd2=dsqrt(d_cont(kk,i1))
6939               sred_geom = sqd1*sqd2
6940               IF (sred_geom.lt.cutoff_corr) THEN
6941                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6942      &            ekont,fprimcont)
6943 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6944 cd     &         ' jj=',jj,' kk=',kk
6945                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6946                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6947                 do l=1,3
6948                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6949                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6950                 enddo
6951                 n_corr1=n_corr1+1
6952 cd               write (iout,*) 'sred_geom=',sred_geom,
6953 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6954 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6955 cd               write (iout,*) "g_contij",g_contij
6956 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6957 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6958                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6959                 if (wcorr4.gt.0.0d0)
6960      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6961                   if (energy_dec.and.wcorr4.gt.0.0d0)
6962      1                 write (iout,'(a6,4i5,0pf7.3)')
6963      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6964 c                write (iout,*) "gradcorr5 before eello5"
6965 c                do iii=1,nres
6966 c                  write (iout,'(i5,3f10.5)')
6967 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6968 c                enddo
6969                 if (wcorr5.gt.0.0d0)
6970      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6971 c                write (iout,*) "gradcorr5 after eello5"
6972 c                do iii=1,nres
6973 c                  write (iout,'(i5,3f10.5)')
6974 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6975 c                enddo
6976                   if (energy_dec.and.wcorr5.gt.0.0d0)
6977      1                 write (iout,'(a6,4i5,0pf7.3)')
6978      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6979 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6980 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6981                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6982      &               .or. wturn6.eq.0.0d0))then
6983 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6984                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6985                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6986      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6987 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6988 cd     &            'ecorr6=',ecorr6
6989 cd                write (iout,'(4e15.5)') sred_geom,
6990 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6991 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6992 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6993                 else if (wturn6.gt.0.0d0
6994      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6995 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6996                   eturn6=eturn6+eello_turn6(i,jj,kk)
6997                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6998      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6999 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7000                 endif
7001               ENDIF
7002 1111          continue
7003             endif
7004           enddo ! kk
7005         enddo ! jj
7006       enddo ! i
7007       do i=1,nres
7008         num_cont_hb(i)=num_cont_hb_old(i)
7009       enddo
7010 c                write (iout,*) "gradcorr5 in eello5"
7011 c                do iii=1,nres
7012 c                  write (iout,'(i5,3f10.5)')
7013 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7014 c                enddo
7015       return
7016       end
7017 c------------------------------------------------------------------------------
7018       subroutine add_hb_contact_eello(ii,jj,itask)
7019       implicit real*8 (a-h,o-z)
7020       include "DIMENSIONS"
7021       include "COMMON.IOUNITS"
7022       integer max_cont
7023       integer max_dim
7024       parameter (max_cont=maxconts)
7025       parameter (max_dim=70)
7026       include "COMMON.CONTACTS"
7027       double precision zapas(max_dim,maxconts,max_fg_procs),
7028      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7029       common /przechowalnia/ zapas
7030       integer i,j,ii,jj,iproc,itask(4),nn
7031 c      write (iout,*) "itask",itask
7032       do i=1,2
7033         iproc=itask(i)
7034         if (iproc.gt.0) then
7035           do j=1,num_cont_hb(ii)
7036             jjc=jcont_hb(j,ii)
7037 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7038             if (jjc.eq.jj) then
7039               ncont_sent(iproc)=ncont_sent(iproc)+1
7040               nn=ncont_sent(iproc)
7041               zapas(1,nn,iproc)=ii
7042               zapas(2,nn,iproc)=jjc
7043               zapas(3,nn,iproc)=d_cont(j,ii)
7044               ind=3
7045               do kk=1,3
7046                 ind=ind+1
7047                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7048               enddo
7049               do kk=1,2
7050                 do ll=1,2
7051                   ind=ind+1
7052                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7053                 enddo
7054               enddo
7055               do jj=1,5
7056                 do kk=1,3
7057                   do ll=1,2
7058                     do mm=1,2
7059                       ind=ind+1
7060                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7061                     enddo
7062                   enddo
7063                 enddo
7064               enddo
7065               exit
7066             endif
7067           enddo
7068         endif
7069       enddo
7070       return
7071       end
7072 c------------------------------------------------------------------------------
7073       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7074       implicit real*8 (a-h,o-z)
7075       include 'DIMENSIONS'
7076       include 'COMMON.IOUNITS'
7077       include 'COMMON.DERIV'
7078       include 'COMMON.INTERACT'
7079       include 'COMMON.CONTACTS'
7080       double precision gx(3),gx1(3)
7081       logical lprn
7082       lprn=.false.
7083       eij=facont_hb(jj,i)
7084       ekl=facont_hb(kk,k)
7085       ees0pij=ees0p(jj,i)
7086       ees0pkl=ees0p(kk,k)
7087       ees0mij=ees0m(jj,i)
7088       ees0mkl=ees0m(kk,k)
7089       ekont=eij*ekl
7090       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7091 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7092 C Following 4 lines for diagnostics.
7093 cd    ees0pkl=0.0D0
7094 cd    ees0pij=1.0D0
7095 cd    ees0mkl=0.0D0
7096 cd    ees0mij=1.0D0
7097 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7098 c     & 'Contacts ',i,j,
7099 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7100 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7101 c     & 'gradcorr_long'
7102 C Calculate the multi-body contribution to energy.
7103 c      ecorr=ecorr+ekont*ees
7104 C Calculate multi-body contributions to the gradient.
7105       coeffpees0pij=coeffp*ees0pij
7106       coeffmees0mij=coeffm*ees0mij
7107       coeffpees0pkl=coeffp*ees0pkl
7108       coeffmees0mkl=coeffm*ees0mkl
7109       do ll=1,3
7110 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7111         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7112      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7113      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7114         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7115      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7116      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7117 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7118         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7119      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7120      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7121         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7122      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7123      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7124         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7125      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7126      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7127         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7128         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7129         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7130      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7131      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7132         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7133         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7134 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7135       enddo
7136 c      write (iout,*)
7137 cgrad      do m=i+1,j-1
7138 cgrad        do ll=1,3
7139 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7140 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7141 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7142 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7143 cgrad        enddo
7144 cgrad      enddo
7145 cgrad      do m=k+1,l-1
7146 cgrad        do ll=1,3
7147 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7148 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7149 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7150 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7151 cgrad        enddo
7152 cgrad      enddo
7153 c      write (iout,*) "ehbcorr",ekont*ees
7154       ehbcorr=ekont*ees
7155       return
7156       end
7157 #ifdef MOMENT
7158 C---------------------------------------------------------------------------
7159       subroutine dipole(i,j,jj)
7160       implicit real*8 (a-h,o-z)
7161       include 'DIMENSIONS'
7162       include 'COMMON.IOUNITS'
7163       include 'COMMON.CHAIN'
7164       include 'COMMON.FFIELD'
7165       include 'COMMON.DERIV'
7166       include 'COMMON.INTERACT'
7167       include 'COMMON.CONTACTS'
7168       include 'COMMON.TORSION'
7169       include 'COMMON.VAR'
7170       include 'COMMON.GEO'
7171       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7172      &  auxmat(2,2)
7173       iti1 = itortyp(itype(i+1))
7174       if (j.lt.nres-1) then
7175         itj1 = itortyp(itype(j+1))
7176       else
7177         itj1=ntortyp+1
7178       endif
7179       do iii=1,2
7180         dipi(iii,1)=Ub2(iii,i)
7181         dipderi(iii)=Ub2der(iii,i)
7182         dipi(iii,2)=b1(iii,iti1)
7183         dipj(iii,1)=Ub2(iii,j)
7184         dipderj(iii)=Ub2der(iii,j)
7185         dipj(iii,2)=b1(iii,itj1)
7186       enddo
7187       kkk=0
7188       do iii=1,2
7189         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7190         do jjj=1,2
7191           kkk=kkk+1
7192           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7193         enddo
7194       enddo
7195       do kkk=1,5
7196         do lll=1,3
7197           mmm=0
7198           do iii=1,2
7199             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7200      &        auxvec(1))
7201             do jjj=1,2
7202               mmm=mmm+1
7203               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7204             enddo
7205           enddo
7206         enddo
7207       enddo
7208       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7209       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7210       do iii=1,2
7211         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7212       enddo
7213       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7214       do iii=1,2
7215         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7216       enddo
7217       return
7218       end
7219 #endif
7220 C---------------------------------------------------------------------------
7221       subroutine calc_eello(i,j,k,l,jj,kk)
7222 C
7223 C This subroutine computes matrices and vectors needed to calculate
7224 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7225 C
7226       implicit real*8 (a-h,o-z)
7227       include 'DIMENSIONS'
7228       include 'COMMON.IOUNITS'
7229       include 'COMMON.CHAIN'
7230       include 'COMMON.DERIV'
7231       include 'COMMON.INTERACT'
7232       include 'COMMON.CONTACTS'
7233       include 'COMMON.TORSION'
7234       include 'COMMON.VAR'
7235       include 'COMMON.GEO'
7236       include 'COMMON.FFIELD'
7237       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7238      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7239       logical lprn
7240       common /kutas/ lprn
7241 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7242 cd     & ' jj=',jj,' kk=',kk
7243 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7244 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7245 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7246       do iii=1,2
7247         do jjj=1,2
7248           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7249           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7250         enddo
7251       enddo
7252       call transpose2(aa1(1,1),aa1t(1,1))
7253       call transpose2(aa2(1,1),aa2t(1,1))
7254       do kkk=1,5
7255         do lll=1,3
7256           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7257      &      aa1tder(1,1,lll,kkk))
7258           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7259      &      aa2tder(1,1,lll,kkk))
7260         enddo
7261       enddo
7262       if (l.eq.j+1) then
7263 C parallel orientation of the two CA-CA-CA frames.
7264         if (i.gt.1) then
7265           iti=itortyp(itype(i))
7266         else
7267           iti=ntortyp+1
7268         endif
7269         itk1=itortyp(itype(k+1))
7270         itj=itortyp(itype(j))
7271         if (l.lt.nres-1) then
7272           itl1=itortyp(itype(l+1))
7273         else
7274           itl1=ntortyp+1
7275         endif
7276 C A1 kernel(j+1) A2T
7277 cd        do iii=1,2
7278 cd          write (iout,'(3f10.5,5x,3f10.5)')
7279 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7280 cd        enddo
7281         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7282      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7283      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7284 C Following matrices are needed only for 6-th order cumulants
7285         IF (wcorr6.gt.0.0d0) THEN
7286         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7287      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7288      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7289         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7290      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7291      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7292      &   ADtEAderx(1,1,1,1,1,1))
7293         lprn=.false.
7294         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7295      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7296      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7297      &   ADtEA1derx(1,1,1,1,1,1))
7298         ENDIF
7299 C End 6-th order cumulants
7300 cd        lprn=.false.
7301 cd        if (lprn) then
7302 cd        write (2,*) 'In calc_eello6'
7303 cd        do iii=1,2
7304 cd          write (2,*) 'iii=',iii
7305 cd          do kkk=1,5
7306 cd            write (2,*) 'kkk=',kkk
7307 cd            do jjj=1,2
7308 cd              write (2,'(3(2f10.5),5x)')
7309 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7310 cd            enddo
7311 cd          enddo
7312 cd        enddo
7313 cd        endif
7314         call transpose2(EUgder(1,1,k),auxmat(1,1))
7315         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7316         call transpose2(EUg(1,1,k),auxmat(1,1))
7317         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7318         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7319         do iii=1,2
7320           do kkk=1,5
7321             do lll=1,3
7322               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7323      &          EAEAderx(1,1,lll,kkk,iii,1))
7324             enddo
7325           enddo
7326         enddo
7327 C A1T kernel(i+1) A2
7328         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7329      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7330      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7331 C Following matrices are needed only for 6-th order cumulants
7332         IF (wcorr6.gt.0.0d0) THEN
7333         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7334      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7335      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7336         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7337      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7338      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7339      &   ADtEAderx(1,1,1,1,1,2))
7340         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7341      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7342      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7343      &   ADtEA1derx(1,1,1,1,1,2))
7344         ENDIF
7345 C End 6-th order cumulants
7346         call transpose2(EUgder(1,1,l),auxmat(1,1))
7347         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7348         call transpose2(EUg(1,1,l),auxmat(1,1))
7349         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7350         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7351         do iii=1,2
7352           do kkk=1,5
7353             do lll=1,3
7354               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7355      &          EAEAderx(1,1,lll,kkk,iii,2))
7356             enddo
7357           enddo
7358         enddo
7359 C AEAb1 and AEAb2
7360 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7361 C They are needed only when the fifth- or the sixth-order cumulants are
7362 C indluded.
7363         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7364         call transpose2(AEA(1,1,1),auxmat(1,1))
7365         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7366         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7367         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7368         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7369         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7370         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7371         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7372         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7373         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7374         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7375         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7376         call transpose2(AEA(1,1,2),auxmat(1,1))
7377         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7378         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7379         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7380         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7381         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7382         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7383         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7384         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7385         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7386         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7387         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7388 C Calculate the Cartesian derivatives of the vectors.
7389         do iii=1,2
7390           do kkk=1,5
7391             do lll=1,3
7392               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7393               call matvec2(auxmat(1,1),b1(1,iti),
7394      &          AEAb1derx(1,lll,kkk,iii,1,1))
7395               call matvec2(auxmat(1,1),Ub2(1,i),
7396      &          AEAb2derx(1,lll,kkk,iii,1,1))
7397               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7398      &          AEAb1derx(1,lll,kkk,iii,2,1))
7399               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7400      &          AEAb2derx(1,lll,kkk,iii,2,1))
7401               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7402               call matvec2(auxmat(1,1),b1(1,itj),
7403      &          AEAb1derx(1,lll,kkk,iii,1,2))
7404               call matvec2(auxmat(1,1),Ub2(1,j),
7405      &          AEAb2derx(1,lll,kkk,iii,1,2))
7406               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7407      &          AEAb1derx(1,lll,kkk,iii,2,2))
7408               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7409      &          AEAb2derx(1,lll,kkk,iii,2,2))
7410             enddo
7411           enddo
7412         enddo
7413         ENDIF
7414 C End vectors
7415       else
7416 C Antiparallel orientation of the two CA-CA-CA frames.
7417         if (i.gt.1) then
7418           iti=itortyp(itype(i))
7419         else
7420           iti=ntortyp+1
7421         endif
7422         itk1=itortyp(itype(k+1))
7423         itl=itortyp(itype(l))
7424         itj=itortyp(itype(j))
7425         if (j.lt.nres-1) then
7426           itj1=itortyp(itype(j+1))
7427         else
7428           itj1=ntortyp+1
7429         endif
7430 C A2 kernel(j-1)T A1T
7431         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7432      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7433      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7434 C Following matrices are needed only for 6-th order cumulants
7435         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7436      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7437         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7438      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7439      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7440         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7441      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7442      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7443      &   ADtEAderx(1,1,1,1,1,1))
7444         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7445      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7446      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7447      &   ADtEA1derx(1,1,1,1,1,1))
7448         ENDIF
7449 C End 6-th order cumulants
7450         call transpose2(EUgder(1,1,k),auxmat(1,1))
7451         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7452         call transpose2(EUg(1,1,k),auxmat(1,1))
7453         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7454         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7455         do iii=1,2
7456           do kkk=1,5
7457             do lll=1,3
7458               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7459      &          EAEAderx(1,1,lll,kkk,iii,1))
7460             enddo
7461           enddo
7462         enddo
7463 C A2T kernel(i+1)T A1
7464         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7465      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7466      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7467 C Following matrices are needed only for 6-th order cumulants
7468         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7469      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7470         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7471      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7472      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7473         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7474      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7475      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7476      &   ADtEAderx(1,1,1,1,1,2))
7477         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7478      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7479      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7480      &   ADtEA1derx(1,1,1,1,1,2))
7481         ENDIF
7482 C End 6-th order cumulants
7483         call transpose2(EUgder(1,1,j),auxmat(1,1))
7484         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7485         call transpose2(EUg(1,1,j),auxmat(1,1))
7486         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7487         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7488         do iii=1,2
7489           do kkk=1,5
7490             do lll=1,3
7491               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7492      &          EAEAderx(1,1,lll,kkk,iii,2))
7493             enddo
7494           enddo
7495         enddo
7496 C AEAb1 and AEAb2
7497 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7498 C They are needed only when the fifth- or the sixth-order cumulants are
7499 C indluded.
7500         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7501      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7502         call transpose2(AEA(1,1,1),auxmat(1,1))
7503         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7504         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7505         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7506         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7507         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7508         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7509         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7510         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7511         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7512         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7513         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7514         call transpose2(AEA(1,1,2),auxmat(1,1))
7515         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7516         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7517         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7518         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7519         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7520         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7521         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7522         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7523         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7524         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7525         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7526 C Calculate the Cartesian derivatives of the vectors.
7527         do iii=1,2
7528           do kkk=1,5
7529             do lll=1,3
7530               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7531               call matvec2(auxmat(1,1),b1(1,iti),
7532      &          AEAb1derx(1,lll,kkk,iii,1,1))
7533               call matvec2(auxmat(1,1),Ub2(1,i),
7534      &          AEAb2derx(1,lll,kkk,iii,1,1))
7535               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7536      &          AEAb1derx(1,lll,kkk,iii,2,1))
7537               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7538      &          AEAb2derx(1,lll,kkk,iii,2,1))
7539               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7540               call matvec2(auxmat(1,1),b1(1,itl),
7541      &          AEAb1derx(1,lll,kkk,iii,1,2))
7542               call matvec2(auxmat(1,1),Ub2(1,l),
7543      &          AEAb2derx(1,lll,kkk,iii,1,2))
7544               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7545      &          AEAb1derx(1,lll,kkk,iii,2,2))
7546               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7547      &          AEAb2derx(1,lll,kkk,iii,2,2))
7548             enddo
7549           enddo
7550         enddo
7551         ENDIF
7552 C End vectors
7553       endif
7554       return
7555       end
7556 C---------------------------------------------------------------------------
7557       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7558      &  KK,KKderg,AKA,AKAderg,AKAderx)
7559       implicit none
7560       integer nderg
7561       logical transp
7562       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7563      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7564      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7565       integer iii,kkk,lll
7566       integer jjj,mmm
7567       logical lprn
7568       common /kutas/ lprn
7569       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7570       do iii=1,nderg
7571         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7572      &    AKAderg(1,1,iii))
7573       enddo
7574 cd      if (lprn) write (2,*) 'In kernel'
7575       do kkk=1,5
7576 cd        if (lprn) write (2,*) 'kkk=',kkk
7577         do lll=1,3
7578           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7579      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7580 cd          if (lprn) then
7581 cd            write (2,*) 'lll=',lll
7582 cd            write (2,*) 'iii=1'
7583 cd            do jjj=1,2
7584 cd              write (2,'(3(2f10.5),5x)')
7585 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7586 cd            enddo
7587 cd          endif
7588           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7589      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7590 cd          if (lprn) then
7591 cd            write (2,*) 'lll=',lll
7592 cd            write (2,*) 'iii=2'
7593 cd            do jjj=1,2
7594 cd              write (2,'(3(2f10.5),5x)')
7595 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7596 cd            enddo
7597 cd          endif
7598         enddo
7599       enddo
7600       return
7601       end
7602 C---------------------------------------------------------------------------
7603       double precision function eello4(i,j,k,l,jj,kk)
7604       implicit real*8 (a-h,o-z)
7605       include 'DIMENSIONS'
7606       include 'COMMON.IOUNITS'
7607       include 'COMMON.CHAIN'
7608       include 'COMMON.DERIV'
7609       include 'COMMON.INTERACT'
7610       include 'COMMON.CONTACTS'
7611       include 'COMMON.TORSION'
7612       include 'COMMON.VAR'
7613       include 'COMMON.GEO'
7614       double precision pizda(2,2),ggg1(3),ggg2(3)
7615 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7616 cd        eello4=0.0d0
7617 cd        return
7618 cd      endif
7619 cd      print *,'eello4:',i,j,k,l,jj,kk
7620 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7621 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7622 cold      eij=facont_hb(jj,i)
7623 cold      ekl=facont_hb(kk,k)
7624 cold      ekont=eij*ekl
7625       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7626 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7627       gcorr_loc(k-1)=gcorr_loc(k-1)
7628      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7629       if (l.eq.j+1) then
7630         gcorr_loc(l-1)=gcorr_loc(l-1)
7631      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7632       else
7633         gcorr_loc(j-1)=gcorr_loc(j-1)
7634      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7635       endif
7636       do iii=1,2
7637         do kkk=1,5
7638           do lll=1,3
7639             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7640      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7641 cd            derx(lll,kkk,iii)=0.0d0
7642           enddo
7643         enddo
7644       enddo
7645 cd      gcorr_loc(l-1)=0.0d0
7646 cd      gcorr_loc(j-1)=0.0d0
7647 cd      gcorr_loc(k-1)=0.0d0
7648 cd      eel4=1.0d0
7649 cd      write (iout,*)'Contacts have occurred for peptide groups',
7650 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7651 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7652       if (j.lt.nres-1) then
7653         j1=j+1
7654         j2=j-1
7655       else
7656         j1=j-1
7657         j2=j-2
7658       endif
7659       if (l.lt.nres-1) then
7660         l1=l+1
7661         l2=l-1
7662       else
7663         l1=l-1
7664         l2=l-2
7665       endif
7666       do ll=1,3
7667 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7668 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7669         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7670         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7671 cgrad        ghalf=0.5d0*ggg1(ll)
7672         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7673         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7674         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7675         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7676         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7677         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7678 cgrad        ghalf=0.5d0*ggg2(ll)
7679         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7680         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7681         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7682         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7683         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7684         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7685       enddo
7686 cgrad      do m=i+1,j-1
7687 cgrad        do ll=1,3
7688 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7689 cgrad        enddo
7690 cgrad      enddo
7691 cgrad      do m=k+1,l-1
7692 cgrad        do ll=1,3
7693 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7694 cgrad        enddo
7695 cgrad      enddo
7696 cgrad      do m=i+2,j2
7697 cgrad        do ll=1,3
7698 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7699 cgrad        enddo
7700 cgrad      enddo
7701 cgrad      do m=k+2,l2
7702 cgrad        do ll=1,3
7703 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7704 cgrad        enddo
7705 cgrad      enddo
7706 cd      do iii=1,nres-3
7707 cd        write (2,*) iii,gcorr_loc(iii)
7708 cd      enddo
7709       eello4=ekont*eel4
7710 cd      write (2,*) 'ekont',ekont
7711 cd      write (iout,*) 'eello4',ekont*eel4
7712       return
7713       end
7714 C---------------------------------------------------------------------------
7715       double precision function eello5(i,j,k,l,jj,kk)
7716       implicit real*8 (a-h,o-z)
7717       include 'DIMENSIONS'
7718       include 'COMMON.IOUNITS'
7719       include 'COMMON.CHAIN'
7720       include 'COMMON.DERIV'
7721       include 'COMMON.INTERACT'
7722       include 'COMMON.CONTACTS'
7723       include 'COMMON.TORSION'
7724       include 'COMMON.VAR'
7725       include 'COMMON.GEO'
7726       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7727       double precision ggg1(3),ggg2(3)
7728 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7729 C                                                                              C
7730 C                            Parallel chains                                   C
7731 C                                                                              C
7732 C          o             o                   o             o                   C
7733 C         /l\           / \             \   / \           / \   /              C
7734 C        /   \         /   \             \ /   \         /   \ /               C
7735 C       j| o |l1       | o |              o| o |         | o |o                C
7736 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7737 C      \i/   \         /   \ /             /   \         /   \                 C
7738 C       o    k1             o                                                  C
7739 C         (I)          (II)                (III)          (IV)                 C
7740 C                                                                              C
7741 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7742 C                                                                              C
7743 C                            Antiparallel chains                               C
7744 C                                                                              C
7745 C          o             o                   o             o                   C
7746 C         /j\           / \             \   / \           / \   /              C
7747 C        /   \         /   \             \ /   \         /   \ /               C
7748 C      j1| o |l        | o |              o| o |         | o |o                C
7749 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7750 C      \i/   \         /   \ /             /   \         /   \                 C
7751 C       o     k1            o                                                  C
7752 C         (I)          (II)                (III)          (IV)                 C
7753 C                                                                              C
7754 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7755 C                                                                              C
7756 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7757 C                                                                              C
7758 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7759 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7760 cd        eello5=0.0d0
7761 cd        return
7762 cd      endif
7763 cd      write (iout,*)
7764 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7765 cd     &   ' and',k,l
7766       itk=itortyp(itype(k))
7767       itl=itortyp(itype(l))
7768       itj=itortyp(itype(j))
7769       eello5_1=0.0d0
7770       eello5_2=0.0d0
7771       eello5_3=0.0d0
7772       eello5_4=0.0d0
7773 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7774 cd     &   eel5_3_num,eel5_4_num)
7775       do iii=1,2
7776         do kkk=1,5
7777           do lll=1,3
7778             derx(lll,kkk,iii)=0.0d0
7779           enddo
7780         enddo
7781       enddo
7782 cd      eij=facont_hb(jj,i)
7783 cd      ekl=facont_hb(kk,k)
7784 cd      ekont=eij*ekl
7785 cd      write (iout,*)'Contacts have occurred for peptide groups',
7786 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7787 cd      goto 1111
7788 C Contribution from the graph I.
7789 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7790 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7791       call transpose2(EUg(1,1,k),auxmat(1,1))
7792       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7793       vv(1)=pizda(1,1)-pizda(2,2)
7794       vv(2)=pizda(1,2)+pizda(2,1)
7795       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7796      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7797 C Explicit gradient in virtual-dihedral angles.
7798       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7799      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7800      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7801       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7802       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7803       vv(1)=pizda(1,1)-pizda(2,2)
7804       vv(2)=pizda(1,2)+pizda(2,1)
7805       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7806      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7807      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7808       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7809       vv(1)=pizda(1,1)-pizda(2,2)
7810       vv(2)=pizda(1,2)+pizda(2,1)
7811       if (l.eq.j+1) then
7812         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7813      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7814      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7815       else
7816         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7817      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7818      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7819       endif
7820 C Cartesian gradient
7821       do iii=1,2
7822         do kkk=1,5
7823           do lll=1,3
7824             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7825      &        pizda(1,1))
7826             vv(1)=pizda(1,1)-pizda(2,2)
7827             vv(2)=pizda(1,2)+pizda(2,1)
7828             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7829      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7830      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7831           enddo
7832         enddo
7833       enddo
7834 c      goto 1112
7835 c1111  continue
7836 C Contribution from graph II
7837       call transpose2(EE(1,1,itk),auxmat(1,1))
7838       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7839       vv(1)=pizda(1,1)+pizda(2,2)
7840       vv(2)=pizda(2,1)-pizda(1,2)
7841       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7842      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7843 C Explicit gradient in virtual-dihedral angles.
7844       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7845      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7846       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7847       vv(1)=pizda(1,1)+pizda(2,2)
7848       vv(2)=pizda(2,1)-pizda(1,2)
7849       if (l.eq.j+1) then
7850         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7851      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7852      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7853       else
7854         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7855      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7856      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7857       endif
7858 C Cartesian gradient
7859       do iii=1,2
7860         do kkk=1,5
7861           do lll=1,3
7862             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7863      &        pizda(1,1))
7864             vv(1)=pizda(1,1)+pizda(2,2)
7865             vv(2)=pizda(2,1)-pizda(1,2)
7866             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7867      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7868      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7869           enddo
7870         enddo
7871       enddo
7872 cd      goto 1112
7873 cd1111  continue
7874       if (l.eq.j+1) then
7875 cd        goto 1110
7876 C Parallel orientation
7877 C Contribution from graph III
7878         call transpose2(EUg(1,1,l),auxmat(1,1))
7879         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7880         vv(1)=pizda(1,1)-pizda(2,2)
7881         vv(2)=pizda(1,2)+pizda(2,1)
7882         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7883      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7884 C Explicit gradient in virtual-dihedral angles.
7885         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7886      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7887      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7888         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7889         vv(1)=pizda(1,1)-pizda(2,2)
7890         vv(2)=pizda(1,2)+pizda(2,1)
7891         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7892      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7893      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7894         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7895         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7896         vv(1)=pizda(1,1)-pizda(2,2)
7897         vv(2)=pizda(1,2)+pizda(2,1)
7898         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7899      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7900      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7901 C Cartesian gradient
7902         do iii=1,2
7903           do kkk=1,5
7904             do lll=1,3
7905               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7906      &          pizda(1,1))
7907               vv(1)=pizda(1,1)-pizda(2,2)
7908               vv(2)=pizda(1,2)+pizda(2,1)
7909               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7910      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7911      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7912             enddo
7913           enddo
7914         enddo
7915 cd        goto 1112
7916 C Contribution from graph IV
7917 cd1110    continue
7918         call transpose2(EE(1,1,itl),auxmat(1,1))
7919         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7920         vv(1)=pizda(1,1)+pizda(2,2)
7921         vv(2)=pizda(2,1)-pizda(1,2)
7922         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7923      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7924 C Explicit gradient in virtual-dihedral angles.
7925         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7926      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7927         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7928         vv(1)=pizda(1,1)+pizda(2,2)
7929         vv(2)=pizda(2,1)-pizda(1,2)
7930         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7931      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7932      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7933 C Cartesian gradient
7934         do iii=1,2
7935           do kkk=1,5
7936             do lll=1,3
7937               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7938      &          pizda(1,1))
7939               vv(1)=pizda(1,1)+pizda(2,2)
7940               vv(2)=pizda(2,1)-pizda(1,2)
7941               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7942      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7943      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7944             enddo
7945           enddo
7946         enddo
7947       else
7948 C Antiparallel orientation
7949 C Contribution from graph III
7950 c        goto 1110
7951         call transpose2(EUg(1,1,j),auxmat(1,1))
7952         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7953         vv(1)=pizda(1,1)-pizda(2,2)
7954         vv(2)=pizda(1,2)+pizda(2,1)
7955         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7956      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7957 C Explicit gradient in virtual-dihedral angles.
7958         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7959      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7960      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7961         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7962         vv(1)=pizda(1,1)-pizda(2,2)
7963         vv(2)=pizda(1,2)+pizda(2,1)
7964         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7965      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7966      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7967         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7968         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7969         vv(1)=pizda(1,1)-pizda(2,2)
7970         vv(2)=pizda(1,2)+pizda(2,1)
7971         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7972      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7973      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7974 C Cartesian gradient
7975         do iii=1,2
7976           do kkk=1,5
7977             do lll=1,3
7978               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7979      &          pizda(1,1))
7980               vv(1)=pizda(1,1)-pizda(2,2)
7981               vv(2)=pizda(1,2)+pizda(2,1)
7982               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7983      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7984      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7985             enddo
7986           enddo
7987         enddo
7988 cd        goto 1112
7989 C Contribution from graph IV
7990 1110    continue
7991         call transpose2(EE(1,1,itj),auxmat(1,1))
7992         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7993         vv(1)=pizda(1,1)+pizda(2,2)
7994         vv(2)=pizda(2,1)-pizda(1,2)
7995         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7996      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7997 C Explicit gradient in virtual-dihedral angles.
7998         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7999      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8000         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8001         vv(1)=pizda(1,1)+pizda(2,2)
8002         vv(2)=pizda(2,1)-pizda(1,2)
8003         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8004      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8005      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8006 C Cartesian gradient
8007         do iii=1,2
8008           do kkk=1,5
8009             do lll=1,3
8010               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8011      &          pizda(1,1))
8012               vv(1)=pizda(1,1)+pizda(2,2)
8013               vv(2)=pizda(2,1)-pizda(1,2)
8014               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8015      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8016      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8017             enddo
8018           enddo
8019         enddo
8020       endif
8021 1112  continue
8022       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8023 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8024 cd        write (2,*) 'ijkl',i,j,k,l
8025 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8026 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8027 cd      endif
8028 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8029 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8030 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8031 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8032       if (j.lt.nres-1) then
8033         j1=j+1
8034         j2=j-1
8035       else
8036         j1=j-1
8037         j2=j-2
8038       endif
8039       if (l.lt.nres-1) then
8040         l1=l+1
8041         l2=l-1
8042       else
8043         l1=l-1
8044         l2=l-2
8045       endif
8046 cd      eij=1.0d0
8047 cd      ekl=1.0d0
8048 cd      ekont=1.0d0
8049 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8050 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8051 C        summed up outside the subrouine as for the other subroutines
8052 C        handling long-range interactions. The old code is commented out
8053 C        with "cgrad" to keep track of changes.
8054       do ll=1,3
8055 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8056 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8057         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8058         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8059 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8060 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8061 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8062 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8063 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8064 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8065 c     &   gradcorr5ij,
8066 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8067 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8068 cgrad        ghalf=0.5d0*ggg1(ll)
8069 cd        ghalf=0.0d0
8070         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8071         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8072         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8073         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8074         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8075         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8076 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8077 cgrad        ghalf=0.5d0*ggg2(ll)
8078 cd        ghalf=0.0d0
8079         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8080         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8081         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8082         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8083         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8084         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8085       enddo
8086 cd      goto 1112
8087 cgrad      do m=i+1,j-1
8088 cgrad        do ll=1,3
8089 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8090 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8091 cgrad        enddo
8092 cgrad      enddo
8093 cgrad      do m=k+1,l-1
8094 cgrad        do ll=1,3
8095 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8096 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8097 cgrad        enddo
8098 cgrad      enddo
8099 c1112  continue
8100 cgrad      do m=i+2,j2
8101 cgrad        do ll=1,3
8102 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8103 cgrad        enddo
8104 cgrad      enddo
8105 cgrad      do m=k+2,l2
8106 cgrad        do ll=1,3
8107 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8108 cgrad        enddo
8109 cgrad      enddo
8110 cd      do iii=1,nres-3
8111 cd        write (2,*) iii,g_corr5_loc(iii)
8112 cd      enddo
8113       eello5=ekont*eel5
8114 cd      write (2,*) 'ekont',ekont
8115 cd      write (iout,*) 'eello5',ekont*eel5
8116       return
8117       end
8118 c--------------------------------------------------------------------------
8119       double precision function eello6(i,j,k,l,jj,kk)
8120       implicit real*8 (a-h,o-z)
8121       include 'DIMENSIONS'
8122       include 'COMMON.IOUNITS'
8123       include 'COMMON.CHAIN'
8124       include 'COMMON.DERIV'
8125       include 'COMMON.INTERACT'
8126       include 'COMMON.CONTACTS'
8127       include 'COMMON.TORSION'
8128       include 'COMMON.VAR'
8129       include 'COMMON.GEO'
8130       include 'COMMON.FFIELD'
8131       double precision ggg1(3),ggg2(3)
8132 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8133 cd        eello6=0.0d0
8134 cd        return
8135 cd      endif
8136 cd      write (iout,*)
8137 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8138 cd     &   ' and',k,l
8139       eello6_1=0.0d0
8140       eello6_2=0.0d0
8141       eello6_3=0.0d0
8142       eello6_4=0.0d0
8143       eello6_5=0.0d0
8144       eello6_6=0.0d0
8145 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8146 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8147       do iii=1,2
8148         do kkk=1,5
8149           do lll=1,3
8150             derx(lll,kkk,iii)=0.0d0
8151           enddo
8152         enddo
8153       enddo
8154 cd      eij=facont_hb(jj,i)
8155 cd      ekl=facont_hb(kk,k)
8156 cd      ekont=eij*ekl
8157 cd      eij=1.0d0
8158 cd      ekl=1.0d0
8159 cd      ekont=1.0d0
8160       if (l.eq.j+1) then
8161         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8162         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8163         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8164         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8165         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8166         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8167       else
8168         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8169         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8170         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8171         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8172         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8173           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8174         else
8175           eello6_5=0.0d0
8176         endif
8177         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8178       endif
8179 C If turn contributions are considered, they will be handled separately.
8180       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8181 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8182 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8183 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8184 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8185 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8186 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8187 cd      goto 1112
8188       if (j.lt.nres-1) then
8189         j1=j+1
8190         j2=j-1
8191       else
8192         j1=j-1
8193         j2=j-2
8194       endif
8195       if (l.lt.nres-1) then
8196         l1=l+1
8197         l2=l-1
8198       else
8199         l1=l-1
8200         l2=l-2
8201       endif
8202       do ll=1,3
8203 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8204 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8205 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8206 cgrad        ghalf=0.5d0*ggg1(ll)
8207 cd        ghalf=0.0d0
8208         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8209         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8210         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8211         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8212         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8213         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8214         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8215         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8216 cgrad        ghalf=0.5d0*ggg2(ll)
8217 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8218 cd        ghalf=0.0d0
8219         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8220         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8221         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8222         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8223         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8224         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8225       enddo
8226 cd      goto 1112
8227 cgrad      do m=i+1,j-1
8228 cgrad        do ll=1,3
8229 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8230 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8231 cgrad        enddo
8232 cgrad      enddo
8233 cgrad      do m=k+1,l-1
8234 cgrad        do ll=1,3
8235 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8236 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8237 cgrad        enddo
8238 cgrad      enddo
8239 cgrad1112  continue
8240 cgrad      do m=i+2,j2
8241 cgrad        do ll=1,3
8242 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8243 cgrad        enddo
8244 cgrad      enddo
8245 cgrad      do m=k+2,l2
8246 cgrad        do ll=1,3
8247 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8248 cgrad        enddo
8249 cgrad      enddo
8250 cd      do iii=1,nres-3
8251 cd        write (2,*) iii,g_corr6_loc(iii)
8252 cd      enddo
8253       eello6=ekont*eel6
8254 cd      write (2,*) 'ekont',ekont
8255 cd      write (iout,*) 'eello6',ekont*eel6
8256       return
8257       end
8258 c--------------------------------------------------------------------------
8259       double precision function eello6_graph1(i,j,k,l,imat,swap)
8260       implicit real*8 (a-h,o-z)
8261       include 'DIMENSIONS'
8262       include 'COMMON.IOUNITS'
8263       include 'COMMON.CHAIN'
8264       include 'COMMON.DERIV'
8265       include 'COMMON.INTERACT'
8266       include 'COMMON.CONTACTS'
8267       include 'COMMON.TORSION'
8268       include 'COMMON.VAR'
8269       include 'COMMON.GEO'
8270       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8271       logical swap
8272       logical lprn
8273       common /kutas/ lprn
8274 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8275 C                                                                              C
8276 C      Parallel       Antiparallel                                             C
8277 C                                                                              C
8278 C          o             o                                                     C
8279 C         /l\           /j\                                                    C
8280 C        /   \         /   \                                                   C
8281 C       /| o |         | o |\                                                  C
8282 C     \ j|/k\|  /   \  |/k\|l /                                                C
8283 C      \ /   \ /     \ /   \ /                                                 C
8284 C       o     o       o     o                                                  C
8285 C       i             i                                                        C
8286 C                                                                              C
8287 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8288       itk=itortyp(itype(k))
8289       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8290       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8291       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8292       call transpose2(EUgC(1,1,k),auxmat(1,1))
8293       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8294       vv1(1)=pizda1(1,1)-pizda1(2,2)
8295       vv1(2)=pizda1(1,2)+pizda1(2,1)
8296       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8297       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8298       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8299       s5=scalar2(vv(1),Dtobr2(1,i))
8300 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8301       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8302       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8303      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8304      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8305      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8306      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8307      & +scalar2(vv(1),Dtobr2der(1,i)))
8308       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8309       vv1(1)=pizda1(1,1)-pizda1(2,2)
8310       vv1(2)=pizda1(1,2)+pizda1(2,1)
8311       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8312       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8313       if (l.eq.j+1) then
8314         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8315      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8316      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8317      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8318      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8319       else
8320         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8321      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8322      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8323      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8324      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8325       endif
8326       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8327       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8328       vv1(1)=pizda1(1,1)-pizda1(2,2)
8329       vv1(2)=pizda1(1,2)+pizda1(2,1)
8330       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8331      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8332      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8333      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8334       do iii=1,2
8335         if (swap) then
8336           ind=3-iii
8337         else
8338           ind=iii
8339         endif
8340         do kkk=1,5
8341           do lll=1,3
8342             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8343             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8344             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8345             call transpose2(EUgC(1,1,k),auxmat(1,1))
8346             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8347      &        pizda1(1,1))
8348             vv1(1)=pizda1(1,1)-pizda1(2,2)
8349             vv1(2)=pizda1(1,2)+pizda1(2,1)
8350             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8351             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8352      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8353             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8354      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8355             s5=scalar2(vv(1),Dtobr2(1,i))
8356             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8357           enddo
8358         enddo
8359       enddo
8360       return
8361       end
8362 c----------------------------------------------------------------------------
8363       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8364       implicit real*8 (a-h,o-z)
8365       include 'DIMENSIONS'
8366       include 'COMMON.IOUNITS'
8367       include 'COMMON.CHAIN'
8368       include 'COMMON.DERIV'
8369       include 'COMMON.INTERACT'
8370       include 'COMMON.CONTACTS'
8371       include 'COMMON.TORSION'
8372       include 'COMMON.VAR'
8373       include 'COMMON.GEO'
8374       logical swap
8375       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8376      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8377       logical lprn
8378       common /kutas/ lprn
8379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8380 C                                                                              C
8381 C      Parallel       Antiparallel                                             C
8382 C                                                                              C
8383 C          o             o                                                     C
8384 C     \   /l\           /j\   /                                                C
8385 C      \ /   \         /   \ /                                                 C
8386 C       o| o |         | o |o                                                  C
8387 C     \ j|/k\|      \  |/k\|l                                                  C
8388 C      \ /   \       \ /   \                                                   C
8389 C       o             o                                                        C
8390 C       i             i                                                        C
8391 C                                                                              C
8392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8393 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8394 C AL 7/4/01 s1 would occur in the sixth-order moment,
8395 C           but not in a cluster cumulant
8396 #ifdef MOMENT
8397       s1=dip(1,jj,i)*dip(1,kk,k)
8398 #endif
8399       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8400       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8401       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8402       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8403       call transpose2(EUg(1,1,k),auxmat(1,1))
8404       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8405       vv(1)=pizda(1,1)-pizda(2,2)
8406       vv(2)=pizda(1,2)+pizda(2,1)
8407       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8408 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8409 #ifdef MOMENT
8410       eello6_graph2=-(s1+s2+s3+s4)
8411 #else
8412       eello6_graph2=-(s2+s3+s4)
8413 #endif
8414 c      eello6_graph2=-s3
8415 C Derivatives in gamma(i-1)
8416       if (i.gt.1) then
8417 #ifdef MOMENT
8418         s1=dipderg(1,jj,i)*dip(1,kk,k)
8419 #endif
8420         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8421         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8422         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8423         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8424 #ifdef MOMENT
8425         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8426 #else
8427         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8428 #endif
8429 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8430       endif
8431 C Derivatives in gamma(k-1)
8432 #ifdef MOMENT
8433       s1=dip(1,jj,i)*dipderg(1,kk,k)
8434 #endif
8435       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8436       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8437       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8438       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8439       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8440       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8441       vv(1)=pizda(1,1)-pizda(2,2)
8442       vv(2)=pizda(1,2)+pizda(2,1)
8443       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8444 #ifdef MOMENT
8445       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8446 #else
8447       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8448 #endif
8449 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8450 C Derivatives in gamma(j-1) or gamma(l-1)
8451       if (j.gt.1) then
8452 #ifdef MOMENT
8453         s1=dipderg(3,jj,i)*dip(1,kk,k)
8454 #endif
8455         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8456         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8457         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8458         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8459         vv(1)=pizda(1,1)-pizda(2,2)
8460         vv(2)=pizda(1,2)+pizda(2,1)
8461         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8462 #ifdef MOMENT
8463         if (swap) then
8464           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8465         else
8466           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8467         endif
8468 #endif
8469         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8470 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8471       endif
8472 C Derivatives in gamma(l-1) or gamma(j-1)
8473       if (l.gt.1) then
8474 #ifdef MOMENT
8475         s1=dip(1,jj,i)*dipderg(3,kk,k)
8476 #endif
8477         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8478         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8479         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8480         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8481         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8482         vv(1)=pizda(1,1)-pizda(2,2)
8483         vv(2)=pizda(1,2)+pizda(2,1)
8484         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8485 #ifdef MOMENT
8486         if (swap) then
8487           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8488         else
8489           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8490         endif
8491 #endif
8492         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8493 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8494       endif
8495 C Cartesian derivatives.
8496       if (lprn) then
8497         write (2,*) 'In eello6_graph2'
8498         do iii=1,2
8499           write (2,*) 'iii=',iii
8500           do kkk=1,5
8501             write (2,*) 'kkk=',kkk
8502             do jjj=1,2
8503               write (2,'(3(2f10.5),5x)')
8504      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8505             enddo
8506           enddo
8507         enddo
8508       endif
8509       do iii=1,2
8510         do kkk=1,5
8511           do lll=1,3
8512 #ifdef MOMENT
8513             if (iii.eq.1) then
8514               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8515             else
8516               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8517             endif
8518 #endif
8519             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8520      &        auxvec(1))
8521             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8522             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8523      &        auxvec(1))
8524             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8525             call transpose2(EUg(1,1,k),auxmat(1,1))
8526             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8527      &        pizda(1,1))
8528             vv(1)=pizda(1,1)-pizda(2,2)
8529             vv(2)=pizda(1,2)+pizda(2,1)
8530             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8531 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8532 #ifdef MOMENT
8533             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8534 #else
8535             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8536 #endif
8537             if (swap) then
8538               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8539             else
8540               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8541             endif
8542           enddo
8543         enddo
8544       enddo
8545       return
8546       end
8547 c----------------------------------------------------------------------------
8548       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8549       implicit real*8 (a-h,o-z)
8550       include 'DIMENSIONS'
8551       include 'COMMON.IOUNITS'
8552       include 'COMMON.CHAIN'
8553       include 'COMMON.DERIV'
8554       include 'COMMON.INTERACT'
8555       include 'COMMON.CONTACTS'
8556       include 'COMMON.TORSION'
8557       include 'COMMON.VAR'
8558       include 'COMMON.GEO'
8559       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8560       logical swap
8561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8562 C                                                                              C
8563 C      Parallel       Antiparallel                                             C
8564 C                                                                              C
8565 C          o             o                                                     C
8566 C         /l\   /   \   /j\                                                    C
8567 C        /   \ /     \ /   \                                                   C
8568 C       /| o |o       o| o |\                                                  C
8569 C       j|/k\|  /      |/k\|l /                                                C
8570 C        /   \ /       /   \ /                                                 C
8571 C       /     o       /     o                                                  C
8572 C       i             i                                                        C
8573 C                                                                              C
8574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8575 C
8576 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8577 C           energy moment and not to the cluster cumulant.
8578       iti=itortyp(itype(i))
8579       if (j.lt.nres-1) then
8580         itj1=itortyp(itype(j+1))
8581       else
8582         itj1=ntortyp+1
8583       endif
8584       itk=itortyp(itype(k))
8585       itk1=itortyp(itype(k+1))
8586       if (l.lt.nres-1) then
8587         itl1=itortyp(itype(l+1))
8588       else
8589         itl1=ntortyp+1
8590       endif
8591 #ifdef MOMENT
8592       s1=dip(4,jj,i)*dip(4,kk,k)
8593 #endif
8594       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8595       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8596       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8597       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8598       call transpose2(EE(1,1,itk),auxmat(1,1))
8599       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8600       vv(1)=pizda(1,1)+pizda(2,2)
8601       vv(2)=pizda(2,1)-pizda(1,2)
8602       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8603 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8604 cd     & "sum",-(s2+s3+s4)
8605 #ifdef MOMENT
8606       eello6_graph3=-(s1+s2+s3+s4)
8607 #else
8608       eello6_graph3=-(s2+s3+s4)
8609 #endif
8610 c      eello6_graph3=-s4
8611 C Derivatives in gamma(k-1)
8612       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8613       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8614       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8615       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8616 C Derivatives in gamma(l-1)
8617       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8618       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8619       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8620       vv(1)=pizda(1,1)+pizda(2,2)
8621       vv(2)=pizda(2,1)-pizda(1,2)
8622       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8623       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8624 C Cartesian derivatives.
8625       do iii=1,2
8626         do kkk=1,5
8627           do lll=1,3
8628 #ifdef MOMENT
8629             if (iii.eq.1) then
8630               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8631             else
8632               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8633             endif
8634 #endif
8635             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8636      &        auxvec(1))
8637             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8638             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8639      &        auxvec(1))
8640             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8641             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8642      &        pizda(1,1))
8643             vv(1)=pizda(1,1)+pizda(2,2)
8644             vv(2)=pizda(2,1)-pizda(1,2)
8645             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8646 #ifdef MOMENT
8647             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8648 #else
8649             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8650 #endif
8651             if (swap) then
8652               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8653             else
8654               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8655             endif
8656 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8657           enddo
8658         enddo
8659       enddo
8660       return
8661       end
8662 c----------------------------------------------------------------------------
8663       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8664       implicit real*8 (a-h,o-z)
8665       include 'DIMENSIONS'
8666       include 'COMMON.IOUNITS'
8667       include 'COMMON.CHAIN'
8668       include 'COMMON.DERIV'
8669       include 'COMMON.INTERACT'
8670       include 'COMMON.CONTACTS'
8671       include 'COMMON.TORSION'
8672       include 'COMMON.VAR'
8673       include 'COMMON.GEO'
8674       include 'COMMON.FFIELD'
8675       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8676      & auxvec1(2),auxmat1(2,2)
8677       logical swap
8678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8679 C                                                                              C
8680 C      Parallel       Antiparallel                                             C
8681 C                                                                              C
8682 C          o             o                                                     C
8683 C         /l\   /   \   /j\                                                    C
8684 C        /   \ /     \ /   \                                                   C
8685 C       /| o |o       o| o |\                                                  C
8686 C     \ j|/k\|      \  |/k\|l                                                  C
8687 C      \ /   \       \ /   \                                                   C
8688 C       o     \       o     \                                                  C
8689 C       i             i                                                        C
8690 C                                                                              C
8691 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8692 C
8693 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8694 C           energy moment and not to the cluster cumulant.
8695 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8696       iti=itortyp(itype(i))
8697       itj=itortyp(itype(j))
8698       if (j.lt.nres-1) then
8699         itj1=itortyp(itype(j+1))
8700       else
8701         itj1=ntortyp+1
8702       endif
8703       itk=itortyp(itype(k))
8704       if (k.lt.nres-1) then
8705         itk1=itortyp(itype(k+1))
8706       else
8707         itk1=ntortyp+1
8708       endif
8709       itl=itortyp(itype(l))
8710       if (l.lt.nres-1) then
8711         itl1=itortyp(itype(l+1))
8712       else
8713         itl1=ntortyp+1
8714       endif
8715 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8716 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8717 cd     & ' itl',itl,' itl1',itl1
8718 #ifdef MOMENT
8719       if (imat.eq.1) then
8720         s1=dip(3,jj,i)*dip(3,kk,k)
8721       else
8722         s1=dip(2,jj,j)*dip(2,kk,l)
8723       endif
8724 #endif
8725       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8726       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8727       if (j.eq.l+1) then
8728         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8729         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8730       else
8731         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8732         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8733       endif
8734       call transpose2(EUg(1,1,k),auxmat(1,1))
8735       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8736       vv(1)=pizda(1,1)-pizda(2,2)
8737       vv(2)=pizda(2,1)+pizda(1,2)
8738       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8739 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8740 #ifdef MOMENT
8741       eello6_graph4=-(s1+s2+s3+s4)
8742 #else
8743       eello6_graph4=-(s2+s3+s4)
8744 #endif
8745 C Derivatives in gamma(i-1)
8746       if (i.gt.1) then
8747 #ifdef MOMENT
8748         if (imat.eq.1) then
8749           s1=dipderg(2,jj,i)*dip(3,kk,k)
8750         else
8751           s1=dipderg(4,jj,j)*dip(2,kk,l)
8752         endif
8753 #endif
8754         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8755         if (j.eq.l+1) then
8756           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8757           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8758         else
8759           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8760           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8761         endif
8762         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8763         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8764 cd          write (2,*) 'turn6 derivatives'
8765 #ifdef MOMENT
8766           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8767 #else
8768           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8769 #endif
8770         else
8771 #ifdef MOMENT
8772           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8773 #else
8774           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8775 #endif
8776         endif
8777       endif
8778 C Derivatives in gamma(k-1)
8779 #ifdef MOMENT
8780       if (imat.eq.1) then
8781         s1=dip(3,jj,i)*dipderg(2,kk,k)
8782       else
8783         s1=dip(2,jj,j)*dipderg(4,kk,l)
8784       endif
8785 #endif
8786       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8787       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8788       if (j.eq.l+1) then
8789         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8790         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8791       else
8792         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8793         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8794       endif
8795       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8796       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8797       vv(1)=pizda(1,1)-pizda(2,2)
8798       vv(2)=pizda(2,1)+pizda(1,2)
8799       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8800       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8801 #ifdef MOMENT
8802         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8803 #else
8804         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8805 #endif
8806       else
8807 #ifdef MOMENT
8808         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8809 #else
8810         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8811 #endif
8812       endif
8813 C Derivatives in gamma(j-1) or gamma(l-1)
8814       if (l.eq.j+1 .and. l.gt.1) then
8815         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8816         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8817         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8818         vv(1)=pizda(1,1)-pizda(2,2)
8819         vv(2)=pizda(2,1)+pizda(1,2)
8820         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8821         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8822       else if (j.gt.1) then
8823         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8824         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8825         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8826         vv(1)=pizda(1,1)-pizda(2,2)
8827         vv(2)=pizda(2,1)+pizda(1,2)
8828         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8829         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8830           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8831         else
8832           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8833         endif
8834       endif
8835 C Cartesian derivatives.
8836       do iii=1,2
8837         do kkk=1,5
8838           do lll=1,3
8839 #ifdef MOMENT
8840             if (iii.eq.1) then
8841               if (imat.eq.1) then
8842                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8843               else
8844                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8845               endif
8846             else
8847               if (imat.eq.1) then
8848                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8849               else
8850                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8851               endif
8852             endif
8853 #endif
8854             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8855      &        auxvec(1))
8856             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8857             if (j.eq.l+1) then
8858               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8859      &          b1(1,itj1),auxvec(1))
8860               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8861             else
8862               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8863      &          b1(1,itl1),auxvec(1))
8864               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8865             endif
8866             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8867      &        pizda(1,1))
8868             vv(1)=pizda(1,1)-pizda(2,2)
8869             vv(2)=pizda(2,1)+pizda(1,2)
8870             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8871             if (swap) then
8872               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8873 #ifdef MOMENT
8874                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8875      &             -(s1+s2+s4)
8876 #else
8877                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8878      &             -(s2+s4)
8879 #endif
8880                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8881               else
8882 #ifdef MOMENT
8883                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8884 #else
8885                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8886 #endif
8887                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8888               endif
8889             else
8890 #ifdef MOMENT
8891               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8892 #else
8893               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8894 #endif
8895               if (l.eq.j+1) then
8896                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8897               else
8898                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8899               endif
8900             endif
8901           enddo
8902         enddo
8903       enddo
8904       return
8905       end
8906 c----------------------------------------------------------------------------
8907       double precision function eello_turn6(i,jj,kk)
8908       implicit real*8 (a-h,o-z)
8909       include 'DIMENSIONS'
8910       include 'COMMON.IOUNITS'
8911       include 'COMMON.CHAIN'
8912       include 'COMMON.DERIV'
8913       include 'COMMON.INTERACT'
8914       include 'COMMON.CONTACTS'
8915       include 'COMMON.TORSION'
8916       include 'COMMON.VAR'
8917       include 'COMMON.GEO'
8918       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8919      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8920      &  ggg1(3),ggg2(3)
8921       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8922      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8923 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8924 C           the respective energy moment and not to the cluster cumulant.
8925       s1=0.0d0
8926       s8=0.0d0
8927       s13=0.0d0
8928 c
8929       eello_turn6=0.0d0
8930       j=i+4
8931       k=i+1
8932       l=i+3
8933       iti=itortyp(itype(i))
8934       itk=itortyp(itype(k))
8935       itk1=itortyp(itype(k+1))
8936       itl=itortyp(itype(l))
8937       itj=itortyp(itype(j))
8938 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8939 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8940 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8941 cd        eello6=0.0d0
8942 cd        return
8943 cd      endif
8944 cd      write (iout,*)
8945 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8946 cd     &   ' and',k,l
8947 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8948       do iii=1,2
8949         do kkk=1,5
8950           do lll=1,3
8951             derx_turn(lll,kkk,iii)=0.0d0
8952           enddo
8953         enddo
8954       enddo
8955 cd      eij=1.0d0
8956 cd      ekl=1.0d0
8957 cd      ekont=1.0d0
8958       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8959 cd      eello6_5=0.0d0
8960 cd      write (2,*) 'eello6_5',eello6_5
8961 #ifdef MOMENT
8962       call transpose2(AEA(1,1,1),auxmat(1,1))
8963       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8964       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8965       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8966 #endif
8967       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8968       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8969       s2 = scalar2(b1(1,itk),vtemp1(1))
8970 #ifdef MOMENT
8971       call transpose2(AEA(1,1,2),atemp(1,1))
8972       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8973       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8974       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8975 #endif
8976       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8977       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8978       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8979 #ifdef MOMENT
8980       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8981       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8982       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8983       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8984       ss13 = scalar2(b1(1,itk),vtemp4(1))
8985       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8986 #endif
8987 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8988 c      s1=0.0d0
8989 c      s2=0.0d0
8990 c      s8=0.0d0
8991 c      s12=0.0d0
8992 c      s13=0.0d0
8993       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8994 C Derivatives in gamma(i+2)
8995       s1d =0.0d0
8996       s8d =0.0d0
8997 #ifdef MOMENT
8998       call transpose2(AEA(1,1,1),auxmatd(1,1))
8999       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9000       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9001       call transpose2(AEAderg(1,1,2),atempd(1,1))
9002       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9003       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9004 #endif
9005       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9006       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9007       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9008 c      s1d=0.0d0
9009 c      s2d=0.0d0
9010 c      s8d=0.0d0
9011 c      s12d=0.0d0
9012 c      s13d=0.0d0
9013       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9014 C Derivatives in gamma(i+3)
9015 #ifdef MOMENT
9016       call transpose2(AEA(1,1,1),auxmatd(1,1))
9017       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9018       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9019       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9020 #endif
9021       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9022       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9023       s2d = scalar2(b1(1,itk),vtemp1d(1))
9024 #ifdef MOMENT
9025       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9026       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9027 #endif
9028       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9029 #ifdef MOMENT
9030       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9031       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9032       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9033 #endif
9034 c      s1d=0.0d0
9035 c      s2d=0.0d0
9036 c      s8d=0.0d0
9037 c      s12d=0.0d0
9038 c      s13d=0.0d0
9039 #ifdef MOMENT
9040       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9041      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9042 #else
9043       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9044      &               -0.5d0*ekont*(s2d+s12d)
9045 #endif
9046 C Derivatives in gamma(i+4)
9047       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9048       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9049       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9050 #ifdef MOMENT
9051       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9052       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9053       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9054 #endif
9055 c      s1d=0.0d0
9056 c      s2d=0.0d0
9057 c      s8d=0.0d0
9058 C      s12d=0.0d0
9059 c      s13d=0.0d0
9060 #ifdef MOMENT
9061       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9062 #else
9063       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9064 #endif
9065 C Derivatives in gamma(i+5)
9066 #ifdef MOMENT
9067       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9068       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9069       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9070 #endif
9071       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9072       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9073       s2d = scalar2(b1(1,itk),vtemp1d(1))
9074 #ifdef MOMENT
9075       call transpose2(AEA(1,1,2),atempd(1,1))
9076       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9077       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9078 #endif
9079       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9080       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9081 #ifdef MOMENT
9082       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9083       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9084       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9085 #endif
9086 c      s1d=0.0d0
9087 c      s2d=0.0d0
9088 c      s8d=0.0d0
9089 c      s12d=0.0d0
9090 c      s13d=0.0d0
9091 #ifdef MOMENT
9092       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9093      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9094 #else
9095       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9096      &               -0.5d0*ekont*(s2d+s12d)
9097 #endif
9098 C Cartesian derivatives
9099       do iii=1,2
9100         do kkk=1,5
9101           do lll=1,3
9102 #ifdef MOMENT
9103             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9104             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9105             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9106 #endif
9107             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9108             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9109      &          vtemp1d(1))
9110             s2d = scalar2(b1(1,itk),vtemp1d(1))
9111 #ifdef MOMENT
9112             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9113             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9114             s8d = -(atempd(1,1)+atempd(2,2))*
9115      &           scalar2(cc(1,1,itl),vtemp2(1))
9116 #endif
9117             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9118      &           auxmatd(1,1))
9119             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9120             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9121 c      s1d=0.0d0
9122 c      s2d=0.0d0
9123 c      s8d=0.0d0
9124 c      s12d=0.0d0
9125 c      s13d=0.0d0
9126 #ifdef MOMENT
9127             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9128      &        - 0.5d0*(s1d+s2d)
9129 #else
9130             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9131      &        - 0.5d0*s2d
9132 #endif
9133 #ifdef MOMENT
9134             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9135      &        - 0.5d0*(s8d+s12d)
9136 #else
9137             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9138      &        - 0.5d0*s12d
9139 #endif
9140           enddo
9141         enddo
9142       enddo
9143 #ifdef MOMENT
9144       do kkk=1,5
9145         do lll=1,3
9146           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9147      &      achuj_tempd(1,1))
9148           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9149           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9150           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9151           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9152           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9153      &      vtemp4d(1))
9154           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9155           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9156           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9157         enddo
9158       enddo
9159 #endif
9160 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9161 cd     &  16*eel_turn6_num
9162 cd      goto 1112
9163       if (j.lt.nres-1) then
9164         j1=j+1
9165         j2=j-1
9166       else
9167         j1=j-1
9168         j2=j-2
9169       endif
9170       if (l.lt.nres-1) then
9171         l1=l+1
9172         l2=l-1
9173       else
9174         l1=l-1
9175         l2=l-2
9176       endif
9177       do ll=1,3
9178 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9179 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9180 cgrad        ghalf=0.5d0*ggg1(ll)
9181 cd        ghalf=0.0d0
9182         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9183         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9184         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9185      &    +ekont*derx_turn(ll,2,1)
9186         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9187         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9188      &    +ekont*derx_turn(ll,4,1)
9189         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9190         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9191         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9192 cgrad        ghalf=0.5d0*ggg2(ll)
9193 cd        ghalf=0.0d0
9194         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9195      &    +ekont*derx_turn(ll,2,2)
9196         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9197         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9198      &    +ekont*derx_turn(ll,4,2)
9199         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9200         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9201         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9202       enddo
9203 cd      goto 1112
9204 cgrad      do m=i+1,j-1
9205 cgrad        do ll=1,3
9206 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9207 cgrad        enddo
9208 cgrad      enddo
9209 cgrad      do m=k+1,l-1
9210 cgrad        do ll=1,3
9211 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9212 cgrad        enddo
9213 cgrad      enddo
9214 cgrad1112  continue
9215 cgrad      do m=i+2,j2
9216 cgrad        do ll=1,3
9217 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9218 cgrad        enddo
9219 cgrad      enddo
9220 cgrad      do m=k+2,l2
9221 cgrad        do ll=1,3
9222 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9223 cgrad        enddo
9224 cgrad      enddo
9225 cd      do iii=1,nres-3
9226 cd        write (2,*) iii,g_corr6_loc(iii)
9227 cd      enddo
9228       eello_turn6=ekont*eel_turn6
9229 cd      write (2,*) 'ekont',ekont
9230 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9231       return
9232       end
9233
9234 C-----------------------------------------------------------------------------
9235       double precision function scalar(u,v)
9236 !DIR$ INLINEALWAYS scalar
9237 #ifndef OSF
9238 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9239 #endif
9240       implicit none
9241       double precision u(3),v(3)
9242 cd      double precision sc
9243 cd      integer i
9244 cd      sc=0.0d0
9245 cd      do i=1,3
9246 cd        sc=sc+u(i)*v(i)
9247 cd      enddo
9248 cd      scalar=sc
9249
9250       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9251       return
9252       end
9253 crc-------------------------------------------------
9254       SUBROUTINE MATVEC2(A1,V1,V2)
9255 !DIR$ INLINEALWAYS MATVEC2
9256 #ifndef OSF
9257 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9258 #endif
9259       implicit real*8 (a-h,o-z)
9260       include 'DIMENSIONS'
9261       DIMENSION A1(2,2),V1(2),V2(2)
9262 c      DO 1 I=1,2
9263 c        VI=0.0
9264 c        DO 3 K=1,2
9265 c    3     VI=VI+A1(I,K)*V1(K)
9266 c        Vaux(I)=VI
9267 c    1 CONTINUE
9268
9269       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9270       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9271
9272       v2(1)=vaux1
9273       v2(2)=vaux2
9274       END
9275 C---------------------------------------
9276       SUBROUTINE MATMAT2(A1,A2,A3)
9277 #ifndef OSF
9278 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9279 #endif
9280       implicit real*8 (a-h,o-z)
9281       include 'DIMENSIONS'
9282       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9283 c      DIMENSION AI3(2,2)
9284 c        DO  J=1,2
9285 c          A3IJ=0.0
9286 c          DO K=1,2
9287 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9288 c          enddo
9289 c          A3(I,J)=A3IJ
9290 c       enddo
9291 c      enddo
9292
9293       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9294       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9295       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9296       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9297
9298       A3(1,1)=AI3_11
9299       A3(2,1)=AI3_21
9300       A3(1,2)=AI3_12
9301       A3(2,2)=AI3_22
9302       END
9303
9304 c-------------------------------------------------------------------------
9305       double precision function scalar2(u,v)
9306 !DIR$ INLINEALWAYS scalar2
9307       implicit none
9308       double precision u(2),v(2)
9309       double precision sc
9310       integer i
9311       scalar2=u(1)*v(1)+u(2)*v(2)
9312       return
9313       end
9314
9315 C-----------------------------------------------------------------------------
9316
9317       subroutine transpose2(a,at)
9318 !DIR$ INLINEALWAYS transpose2
9319 #ifndef OSF
9320 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9321 #endif
9322       implicit none
9323       double precision a(2,2),at(2,2)
9324       at(1,1)=a(1,1)
9325       at(1,2)=a(2,1)
9326       at(2,1)=a(1,2)
9327       at(2,2)=a(2,2)
9328       return
9329       end
9330 c--------------------------------------------------------------------------
9331       subroutine transpose(n,a,at)
9332       implicit none
9333       integer n,i,j
9334       double precision a(n,n),at(n,n)
9335       do i=1,n
9336         do j=1,n
9337           at(j,i)=a(i,j)
9338         enddo
9339       enddo
9340       return
9341       end
9342 C---------------------------------------------------------------------------
9343       subroutine prodmat3(a1,a2,kk,transp,prod)
9344 !DIR$ INLINEALWAYS prodmat3
9345 #ifndef OSF
9346 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9347 #endif
9348       implicit none
9349       integer i,j
9350       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9351       logical transp
9352 crc      double precision auxmat(2,2),prod_(2,2)
9353
9354       if (transp) then
9355 crc        call transpose2(kk(1,1),auxmat(1,1))
9356 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9357 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9358
9359            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9360      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9361            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9362      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9363            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9364      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9365            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9366      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9367
9368       else
9369 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9370 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9371
9372            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9373      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9374            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9375      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9376            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9377      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9378            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9379      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9380
9381       endif
9382 c      call transpose2(a2(1,1),a2t(1,1))
9383
9384 crc      print *,transp
9385 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9386 crc      print *,((prod(i,j),i=1,2),j=1,2)
9387
9388       return
9389       end
9390