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
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
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
2455           endif
2456         else
2457           iti1=ntortyp
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
2873      &  .or. itype(i+3).eq.ntyp1
2874      &  .or. itype(i-1).eq.ntyp1
2875      &  .or. itype(i+4).eq.ntyp1
2876      &  ) cycle
2877         dxi=dc(1,i)
2878         dyi=dc(2,i)
2879         dzi=dc(3,i)
2880         dx_normi=dc_norm(1,i)
2881         dy_normi=dc_norm(2,i)
2882         dz_normi=dc_norm(3,i)
2883         xmedi=c(1,i)+0.5d0*dxi
2884         ymedi=c(2,i)+0.5d0*dyi
2885         zmedi=c(3,i)+0.5d0*dzi
2886 C Return atom into box, boxxsize is size of box in x dimension
2887   184   continue
2888         if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2889         if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2890 C Condition for being inside the proper box
2891         if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2892      &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2893         go to 184
2894         endif
2895   185   continue
2896         if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2897         if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2898 C Condition for being inside the proper box
2899         if ((ymedi.gt.((0.5d0)*boxysize)).or.
2900      &       (ymedi.lt.((-0.5d0)*boxysize))) then
2901         go to 185
2902         endif
2903   186   continue
2904         if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2905         if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2906 C Condition for being inside the proper box
2907         if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2908      &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2909         go to 186
2910         endif
2911         num_conti=0
2912         call eelecij(i,i+2,ees,evdw1,eel_loc)
2913         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2914         num_cont_hb(i)=num_conti
2915       enddo
2916       do i=iturn4_start,iturn4_end
2917         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2918      &    .or. itype(i+3).eq.ntyp1
2919      &    .or. itype(i+4).eq.ntyp1
2920      &    .or. itype(i+5).eq.ntyp1
2921      &    .or. itype(i).eq.ntyp1
2922      &    .or. itype(i-1).eq.ntyp1
2923      &                             ) cycle
2924         dxi=dc(1,i)
2925         dyi=dc(2,i)
2926         dzi=dc(3,i)
2927         dx_normi=dc_norm(1,i)
2928         dy_normi=dc_norm(2,i)
2929         dz_normi=dc_norm(3,i)
2930         xmedi=c(1,i)+0.5d0*dxi
2931         ymedi=c(2,i)+0.5d0*dyi
2932         zmedi=c(3,i)+0.5d0*dzi
2933 C Return atom into box, boxxsize is size of box in x dimension
2934   194   continue
2935         if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2936         if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2937 C Condition for being inside the proper box
2938         if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2939      &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2940         go to 194
2941         endif
2942   195   continue
2943         if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2944         if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2945 C Condition for being inside the proper box
2946         if ((ymedi.gt.((0.5d0)*boxysize)).or.
2947      &       (ymedi.lt.((-0.5d0)*boxysize))) then
2948         go to 195
2949         endif
2950   196   continue
2951         if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2952         if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2953 C Condition for being inside the proper box
2954         if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2955      &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2956         go to 196
2957         endif
2958
2959         num_conti=num_cont_hb(i)
2960         call eelecij(i,i+3,ees,evdw1,eel_loc)
2961         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2962      &   call eturn4(i,eello_turn4)
2963         num_cont_hb(i)=num_conti
2964       enddo   ! i
2965 C Loop over all neighbouring boxes
2966       do xshift=-1,1
2967       do yshift=-1,1
2968       do zshift=-1,1
2969 c
2970 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2971 c
2972       do i=iatel_s,iatel_e
2973         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2974      &  .or. itype(i+2).eq.ntyp1
2975      &  .or. itype(i-1).eq.ntyp1
2976      &                ) cycle
2977         dxi=dc(1,i)
2978         dyi=dc(2,i)
2979         dzi=dc(3,i)
2980         dx_normi=dc_norm(1,i)
2981         dy_normi=dc_norm(2,i)
2982         dz_normi=dc_norm(3,i)
2983         xmedi=c(1,i)+0.5d0*dxi
2984         ymedi=c(2,i)+0.5d0*dyi
2985         zmedi=c(3,i)+0.5d0*dzi
2986 C Return atom into box, boxxsize is size of box in x dimension
2987   164   continue
2988         if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2989         if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2990 C Condition for being inside the proper box
2991         if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2992      &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2993         go to 164
2994         endif
2995   165   continue
2996         if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2997         if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2998 C Condition for being inside the proper box
2999         if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3000      &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3001         go to 165
3002         endif
3003   166   continue
3004         if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3005         if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3006 C Condition for being inside the proper box
3007         if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3008      &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3009         go to 166
3010         endif
3011
3012 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3013         num_conti=num_cont_hb(i)
3014         do j=ielstart(i),ielend(i)
3015 c          write (iout,*) i,j,itype(i),itype(j)
3016           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3017      & .or.itype(j+2).eq.ntyp1
3018      & .or.itype(j-1).eq.ntyp1
3019      &) cycle
3020           call eelecij(i,j,ees,evdw1,eel_loc)
3021         enddo ! j
3022         num_cont_hb(i)=num_conti
3023       enddo   ! i
3024       enddo   ! zshift
3025       enddo   ! yshift
3026       enddo   ! xshift
3027
3028 c      write (iout,*) "Number of loop steps in EELEC:",ind
3029 cd      do i=1,nres
3030 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3031 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3032 cd      enddo
3033 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3034 ccc      eel_loc=eel_loc+eello_turn3
3035 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3036       return
3037       end
3038 C-------------------------------------------------------------------------------
3039       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3040       implicit real*8 (a-h,o-z)
3041       include 'DIMENSIONS'
3042 #ifdef MPI
3043       include "mpif.h"
3044 #endif
3045       include 'COMMON.CONTROL'
3046       include 'COMMON.IOUNITS'
3047       include 'COMMON.GEO'
3048       include 'COMMON.VAR'
3049       include 'COMMON.LOCAL'
3050       include 'COMMON.CHAIN'
3051       include 'COMMON.DERIV'
3052       include 'COMMON.INTERACT'
3053       include 'COMMON.CONTACTS'
3054       include 'COMMON.TORSION'
3055       include 'COMMON.VECTORS'
3056       include 'COMMON.FFIELD'
3057       include 'COMMON.TIME1'
3058       include 'COMMON.SPLITELE'
3059       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3060      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3061       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3062      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3063       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3064      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3065      &    num_conti,j1,j2
3066 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3067 #ifdef MOMENT
3068       double precision scal_el /1.0d0/
3069 #else
3070       double precision scal_el /0.5d0/
3071 #endif
3072 C 12/13/98
3073 C 13-go grudnia roku pamietnego...
3074       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3075      &                   0.0d0,1.0d0,0.0d0,
3076      &                   0.0d0,0.0d0,1.0d0/
3077 c          time00=MPI_Wtime()
3078 cd      write (iout,*) "eelecij",i,j
3079 c          ind=ind+1
3080           iteli=itel(i)
3081           itelj=itel(j)
3082           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3083           aaa=app(iteli,itelj)
3084           bbb=bpp(iteli,itelj)
3085           ael6i=ael6(iteli,itelj)
3086           ael3i=ael3(iteli,itelj)
3087           dxj=dc(1,j)
3088           dyj=dc(2,j)
3089           dzj=dc(3,j)
3090           dx_normj=dc_norm(1,j)
3091           dy_normj=dc_norm(2,j)
3092           dz_normj=dc_norm(3,j)
3093 C          xj=c(1,j)+0.5D0*dxj-xmedi
3094 C          yj=c(2,j)+0.5D0*dyj-ymedi
3095 C          zj=c(3,j)+0.5D0*dzj-zmedi
3096           xj=c(1,j)+0.5D0*dxj
3097           yj=c(2,j)+0.5D0*dyj
3098           zj=c(3,j)+0.5D0*dzj
3099 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3100   174   continue
3101         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3102         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3103 C Condition for being inside the proper box
3104         if ((xj.gt.((0.5d0)*boxxsize)).or.
3105      &       (xj.lt.((-0.5d0)*boxxsize))) then
3106         go to 174
3107         endif
3108   175   continue
3109         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3110         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3111 C Condition for being inside the proper box
3112         if ((yj.gt.((0.5d0)*boxysize)).or.
3113      &       (yj.lt.((-0.5d0)*boxysize))) then
3114         go to 175
3115         endif
3116   176   continue
3117         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3118         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3119 C Condition for being inside the proper box
3120         if ((zj.gt.((0.5d0)*boxzsize)).or.
3121      &       (zj.lt.((-0.5d0)*boxzsize))) then
3122         go to 176
3123         endif
3124 C        endif !endPBC condintion
3125         xj=xj-xmedi
3126         yj=yj-ymedi
3127         zj=zj-zmedi
3128           rij=xj*xj+yj*yj+zj*zj
3129
3130             sss=sscale(sqrt(rij))
3131             sssgrad=sscagrad(sqrt(rij))
3132 c            if (sss.gt.0.0d0) then
3133           rrmij=1.0D0/rij
3134           rij=dsqrt(rij)
3135           rmij=1.0D0/rij
3136           r3ij=rrmij*rmij
3137           r6ij=r3ij*r3ij
3138           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3139           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3140           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3141           fac=cosa-3.0D0*cosb*cosg
3142           ev1=aaa*r6ij*r6ij
3143 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3144           if (j.eq.i+2) ev1=scal_el*ev1
3145           ev2=bbb*r6ij
3146           fac3=ael6i*r6ij
3147           fac4=ael3i*r3ij
3148           evdwij=(ev1+ev2)
3149           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3150           el2=fac4*fac
3151 C MARYSIA
3152           eesij=(el1+el2)
3153 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3154           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3155           ees=ees+eesij
3156           evdw1=evdw1+evdwij*sss
3157 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3158 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3159 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3160 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3161
3162           if (energy_dec) then
3163               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3164      &'evdw1',i,j,evdwij
3165      &,iteli,itelj,aaa,evdw1
3166               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3167           endif
3168
3169 C
3170 C Calculate contributions to the Cartesian gradient.
3171 C
3172 #ifdef SPLITELE
3173           facvdw=-6*rrmij*(ev1+evdwij)*sss
3174           facel=-3*rrmij*(el1+eesij)
3175           fac1=fac
3176           erij(1)=xj*rmij
3177           erij(2)=yj*rmij
3178           erij(3)=zj*rmij
3179 *
3180 * Radial derivatives. First process both termini of the fragment (i,j)
3181 *
3182           ggg(1)=facel*xj
3183           ggg(2)=facel*yj
3184           ggg(3)=facel*zj
3185 c          do k=1,3
3186 c            ghalf=0.5D0*ggg(k)
3187 c            gelc(k,i)=gelc(k,i)+ghalf
3188 c            gelc(k,j)=gelc(k,j)+ghalf
3189 c          enddo
3190 c 9/28/08 AL Gradient compotents will be summed only at the end
3191           do k=1,3
3192             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3193             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3194           enddo
3195 *
3196 * Loop over residues i+1 thru j-1.
3197 *
3198 cgrad          do k=i+1,j-1
3199 cgrad            do l=1,3
3200 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3201 cgrad            enddo
3202 cgrad          enddo
3203           if (sss.gt.0.0) then
3204           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3205           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3206           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3207           else
3208           ggg(1)=0.0
3209           ggg(2)=0.0
3210           ggg(3)=0.0
3211           endif
3212 c          do k=1,3
3213 c            ghalf=0.5D0*ggg(k)
3214 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3215 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3216 c          enddo
3217 c 9/28/08 AL Gradient compotents will be summed only at the end
3218           do k=1,3
3219             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3220             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3221           enddo
3222 *
3223 * Loop over residues i+1 thru j-1.
3224 *
3225 cgrad          do k=i+1,j-1
3226 cgrad            do l=1,3
3227 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3228 cgrad            enddo
3229 cgrad          enddo
3230 #else
3231 C MARYSIA
3232           facvdw=(ev1+evdwij)*sss
3233           facel=(el1+eesij)
3234           fac1=fac
3235           fac=-3*rrmij*(facvdw+facvdw+facel)
3236           erij(1)=xj*rmij
3237           erij(2)=yj*rmij
3238           erij(3)=zj*rmij
3239 *
3240 * Radial derivatives. First process both termini of the fragment (i,j)
3241 *
3242           ggg(1)=fac*xj
3243           ggg(2)=fac*yj
3244           ggg(3)=fac*zj
3245 c          do k=1,3
3246 c            ghalf=0.5D0*ggg(k)
3247 c            gelc(k,i)=gelc(k,i)+ghalf
3248 c            gelc(k,j)=gelc(k,j)+ghalf
3249 c          enddo
3250 c 9/28/08 AL Gradient compotents will be summed only at the end
3251           do k=1,3
3252             gelc_long(k,j)=gelc(k,j)+ggg(k)
3253             gelc_long(k,i)=gelc(k,i)-ggg(k)
3254           enddo
3255 *
3256 * Loop over residues i+1 thru j-1.
3257 *
3258 cgrad          do k=i+1,j-1
3259 cgrad            do l=1,3
3260 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3261 cgrad            enddo
3262 cgrad          enddo
3263 c 9/28/08 AL Gradient compotents will be summed only at the end
3264           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3265           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3266           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3267           do k=1,3
3268             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3269             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3270           enddo
3271 #endif
3272 *
3273 * Angular part
3274 *
3275           ecosa=2.0D0*fac3*fac1+fac4
3276           fac4=-3.0D0*fac4
3277           fac3=-6.0D0*fac3
3278           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3279           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3280           do k=1,3
3281             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3282             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3283           enddo
3284 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3285 cd   &          (dcosg(k),k=1,3)
3286           do k=1,3
3287             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3288           enddo
3289 c          do k=1,3
3290 c            ghalf=0.5D0*ggg(k)
3291 c            gelc(k,i)=gelc(k,i)+ghalf
3292 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3293 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3294 c            gelc(k,j)=gelc(k,j)+ghalf
3295 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3296 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3297 c          enddo
3298 cgrad          do k=i+1,j-1
3299 cgrad            do l=1,3
3300 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3301 cgrad            enddo
3302 cgrad          enddo
3303           do k=1,3
3304             gelc(k,i)=gelc(k,i)
3305      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3306      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3307             gelc(k,j)=gelc(k,j)
3308      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3309      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3310             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3311             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3312           enddo
3313 C MARYSIA
3314 c          endif !sscale
3315           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3316      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3317      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3318 C
3319 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3320 C   energy of a peptide unit is assumed in the form of a second-order
3321 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3322 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3323 C   are computed for EVERY pair of non-contiguous peptide groups.
3324 C
3325           if (j.lt.nres-1) then
3326             j1=j+1
3327             j2=j-1
3328           else
3329             j1=j-1
3330             j2=j-2
3331           endif
3332           kkk=0
3333           do k=1,2
3334             do l=1,2
3335               kkk=kkk+1
3336               muij(kkk)=mu(k,i)*mu(l,j)
3337             enddo
3338           enddo
3339 cd         write (iout,*) 'EELEC: i',i,' j',j
3340 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3341 cd          write(iout,*) 'muij',muij
3342           ury=scalar(uy(1,i),erij)
3343           urz=scalar(uz(1,i),erij)
3344           vry=scalar(uy(1,j),erij)
3345           vrz=scalar(uz(1,j),erij)
3346           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3347           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3348           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3349           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3350           fac=dsqrt(-ael6i)*r3ij
3351           a22=a22*fac
3352           a23=a23*fac
3353           a32=a32*fac
3354           a33=a33*fac
3355 cd          write (iout,'(4i5,4f10.5)')
3356 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3357 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3358 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3359 cd     &      uy(:,j),uz(:,j)
3360 cd          write (iout,'(4f10.5)')
3361 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3362 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3363 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3364 cd           write (iout,'(9f10.5/)')
3365 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3366 C Derivatives of the elements of A in virtual-bond vectors
3367           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3368           do k=1,3
3369             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3370             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3371             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3372             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3373             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3374             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3375             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3376             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3377             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3378             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3379             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3380             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3381           enddo
3382 C Compute radial contributions to the gradient
3383           facr=-3.0d0*rrmij
3384           a22der=a22*facr
3385           a23der=a23*facr
3386           a32der=a32*facr
3387           a33der=a33*facr
3388           agg(1,1)=a22der*xj
3389           agg(2,1)=a22der*yj
3390           agg(3,1)=a22der*zj
3391           agg(1,2)=a23der*xj
3392           agg(2,2)=a23der*yj
3393           agg(3,2)=a23der*zj
3394           agg(1,3)=a32der*xj
3395           agg(2,3)=a32der*yj
3396           agg(3,3)=a32der*zj
3397           agg(1,4)=a33der*xj
3398           agg(2,4)=a33der*yj
3399           agg(3,4)=a33der*zj
3400 C Add the contributions coming from er
3401           fac3=-3.0d0*fac
3402           do k=1,3
3403             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3404             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3405             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3406             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3407           enddo
3408           do k=1,3
3409 C Derivatives in DC(i)
3410 cgrad            ghalf1=0.5d0*agg(k,1)
3411 cgrad            ghalf2=0.5d0*agg(k,2)
3412 cgrad            ghalf3=0.5d0*agg(k,3)
3413 cgrad            ghalf4=0.5d0*agg(k,4)
3414             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3415      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3416             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3417      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3418             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3419      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3420             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3421      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3422 C Derivatives in DC(i+1)
3423             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3424      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3425             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3426      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3427             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3428      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3429             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3430      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3431 C Derivatives in DC(j)
3432             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3433      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3434             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3435      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3436             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3437      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3438             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3439      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3440 C Derivatives in DC(j+1) or DC(nres-1)
3441             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3442      &      -3.0d0*vryg(k,3)*ury)
3443             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3444      &      -3.0d0*vrzg(k,3)*ury)
3445             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3446      &      -3.0d0*vryg(k,3)*urz)
3447             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3448      &      -3.0d0*vrzg(k,3)*urz)
3449 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3450 cgrad              do l=1,4
3451 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3452 cgrad              enddo
3453 cgrad            endif
3454           enddo
3455           acipa(1,1)=a22
3456           acipa(1,2)=a23
3457           acipa(2,1)=a32
3458           acipa(2,2)=a33
3459           a22=-a22
3460           a23=-a23
3461           do l=1,2
3462             do k=1,3
3463               agg(k,l)=-agg(k,l)
3464               aggi(k,l)=-aggi(k,l)
3465               aggi1(k,l)=-aggi1(k,l)
3466               aggj(k,l)=-aggj(k,l)
3467               aggj1(k,l)=-aggj1(k,l)
3468             enddo
3469           enddo
3470           if (j.lt.nres-1) then
3471             a22=-a22
3472             a32=-a32
3473             do l=1,3,2
3474               do k=1,3
3475                 agg(k,l)=-agg(k,l)
3476                 aggi(k,l)=-aggi(k,l)
3477                 aggi1(k,l)=-aggi1(k,l)
3478                 aggj(k,l)=-aggj(k,l)
3479                 aggj1(k,l)=-aggj1(k,l)
3480               enddo
3481             enddo
3482           else
3483             a22=-a22
3484             a23=-a23
3485             a32=-a32
3486             a33=-a33
3487             do l=1,4
3488               do k=1,3
3489                 agg(k,l)=-agg(k,l)
3490                 aggi(k,l)=-aggi(k,l)
3491                 aggi1(k,l)=-aggi1(k,l)
3492                 aggj(k,l)=-aggj(k,l)
3493                 aggj1(k,l)=-aggj1(k,l)
3494               enddo
3495             enddo
3496           endif
3497           ENDIF ! WCORR
3498           IF (wel_loc.gt.0.0d0) THEN
3499 C Contribution to the local-electrostatic energy coming from the i-j pair
3500           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3501      &     +a33*muij(4)
3502 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3503 c     &                     ' eel_loc_ij',eel_loc_ij
3504
3505           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3506      &            'eelloc',i,j,eel_loc_ij
3507 c           if (eel_loc_ij.ne.0)
3508 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3509 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3510
3511           eel_loc=eel_loc+eel_loc_ij
3512 C Partial derivatives in virtual-bond dihedral angles gamma
3513           if (i.gt.1)
3514      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3515      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3516      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3517           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3518      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3519      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3520 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3521           do l=1,3
3522             ggg(l)=agg(l,1)*muij(1)+
3523      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3524             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3525             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3526 cgrad            ghalf=0.5d0*ggg(l)
3527 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3528 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3529           enddo
3530 cgrad          do k=i+1,j2
3531 cgrad            do l=1,3
3532 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3533 cgrad            enddo
3534 cgrad          enddo
3535 C Remaining derivatives of eello
3536           do l=1,3
3537             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3538      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3539             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3540      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3541             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3542      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3543             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3544      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3545           enddo
3546           ENDIF
3547 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3548 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3549           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3550      &       .and. num_conti.le.maxconts) then
3551 c            write (iout,*) i,j," entered corr"
3552 C
3553 C Calculate the contact function. The ith column of the array JCONT will
3554 C contain the numbers of atoms that make contacts with the atom I (of numbers
3555 C greater than I). The arrays FACONT and GACONT will contain the values of
3556 C the contact function and its derivative.
3557 c           r0ij=1.02D0*rpp(iteli,itelj)
3558 c           r0ij=1.11D0*rpp(iteli,itelj)
3559             r0ij=2.20D0*rpp(iteli,itelj)
3560 c           r0ij=1.55D0*rpp(iteli,itelj)
3561             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3562             if (fcont.gt.0.0D0) then
3563               num_conti=num_conti+1
3564               if (num_conti.gt.maxconts) then
3565                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3566      &                         ' will skip next contacts for this conf.'
3567               else
3568                 jcont_hb(num_conti,i)=j
3569 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3570 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3571                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3572      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3573 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3574 C  terms.
3575                 d_cont(num_conti,i)=rij
3576 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3577 C     --- Electrostatic-interaction matrix ---
3578                 a_chuj(1,1,num_conti,i)=a22
3579                 a_chuj(1,2,num_conti,i)=a23
3580                 a_chuj(2,1,num_conti,i)=a32
3581                 a_chuj(2,2,num_conti,i)=a33
3582 C     --- Gradient of rij
3583                 do kkk=1,3
3584                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3585                 enddo
3586                 kkll=0
3587                 do k=1,2
3588                   do l=1,2
3589                     kkll=kkll+1
3590                     do m=1,3
3591                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3592                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3593                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3594                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3595                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3596                     enddo
3597                   enddo
3598                 enddo
3599                 ENDIF
3600                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3601 C Calculate contact energies
3602                 cosa4=4.0D0*cosa
3603                 wij=cosa-3.0D0*cosb*cosg
3604                 cosbg1=cosb+cosg
3605                 cosbg2=cosb-cosg
3606 c               fac3=dsqrt(-ael6i)/r0ij**3
3607                 fac3=dsqrt(-ael6i)*r3ij
3608 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3609                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3610                 if (ees0tmp.gt.0) then
3611                   ees0pij=dsqrt(ees0tmp)
3612                 else
3613                   ees0pij=0
3614                 endif
3615 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3616                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3617                 if (ees0tmp.gt.0) then
3618                   ees0mij=dsqrt(ees0tmp)
3619                 else
3620                   ees0mij=0
3621                 endif
3622 c               ees0mij=0.0D0
3623                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3624                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3625 C Diagnostics. Comment out or remove after debugging!
3626 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3627 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3628 c               ees0m(num_conti,i)=0.0D0
3629 C End diagnostics.
3630 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3631 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3632 C Angular derivatives of the contact function
3633                 ees0pij1=fac3/ees0pij
3634                 ees0mij1=fac3/ees0mij
3635                 fac3p=-3.0D0*fac3*rrmij
3636                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3637                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3638 c               ees0mij1=0.0D0
3639                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3640                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3641                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3642                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3643                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3644                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3645                 ecosap=ecosa1+ecosa2
3646                 ecosbp=ecosb1+ecosb2
3647                 ecosgp=ecosg1+ecosg2
3648                 ecosam=ecosa1-ecosa2
3649                 ecosbm=ecosb1-ecosb2
3650                 ecosgm=ecosg1-ecosg2
3651 C Diagnostics
3652 c               ecosap=ecosa1
3653 c               ecosbp=ecosb1
3654 c               ecosgp=ecosg1
3655 c               ecosam=0.0D0
3656 c               ecosbm=0.0D0
3657 c               ecosgm=0.0D0
3658 C End diagnostics
3659                 facont_hb(num_conti,i)=fcont
3660                 fprimcont=fprimcont/rij
3661 cd              facont_hb(num_conti,i)=1.0D0
3662 C Following line is for diagnostics.
3663 cd              fprimcont=0.0D0
3664                 do k=1,3
3665                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3666                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3667                 enddo
3668                 do k=1,3
3669                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3670                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3671                 enddo
3672                 gggp(1)=gggp(1)+ees0pijp*xj
3673                 gggp(2)=gggp(2)+ees0pijp*yj
3674                 gggp(3)=gggp(3)+ees0pijp*zj
3675                 gggm(1)=gggm(1)+ees0mijp*xj
3676                 gggm(2)=gggm(2)+ees0mijp*yj
3677                 gggm(3)=gggm(3)+ees0mijp*zj
3678 C Derivatives due to the contact function
3679                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3680                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3681                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3682                 do k=1,3
3683 c
3684 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3685 c          following the change of gradient-summation algorithm.
3686 c
3687 cgrad                  ghalfp=0.5D0*gggp(k)
3688 cgrad                  ghalfm=0.5D0*gggm(k)
3689                   gacontp_hb1(k,num_conti,i)=!ghalfp
3690      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3691      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3692                   gacontp_hb2(k,num_conti,i)=!ghalfp
3693      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3694      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3695                   gacontp_hb3(k,num_conti,i)=gggp(k)
3696                   gacontm_hb1(k,num_conti,i)=!ghalfm
3697      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3698      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3699                   gacontm_hb2(k,num_conti,i)=!ghalfm
3700      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3701      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3702                   gacontm_hb3(k,num_conti,i)=gggm(k)
3703                 enddo
3704 C Diagnostics. Comment out or remove after debugging!
3705 cdiag           do k=1,3
3706 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3707 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3708 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3709 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3710 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3711 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3712 cdiag           enddo
3713               ENDIF ! wcorr
3714               endif  ! num_conti.le.maxconts
3715             endif  ! fcont.gt.0
3716           endif    ! j.gt.i+1
3717           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3718             do k=1,4
3719               do l=1,3
3720                 ghalf=0.5d0*agg(l,k)
3721                 aggi(l,k)=aggi(l,k)+ghalf
3722                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3723                 aggj(l,k)=aggj(l,k)+ghalf
3724               enddo
3725             enddo
3726             if (j.eq.nres-1 .and. i.lt.j-2) then
3727               do k=1,4
3728                 do l=1,3
3729                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3730                 enddo
3731               enddo
3732             endif
3733           endif
3734 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3735       return
3736       end
3737 C-----------------------------------------------------------------------------
3738       subroutine eturn3(i,eello_turn3)
3739 C Third- and fourth-order contributions from turns
3740       implicit real*8 (a-h,o-z)
3741       include 'DIMENSIONS'
3742       include 'COMMON.IOUNITS'
3743       include 'COMMON.GEO'
3744       include 'COMMON.VAR'
3745       include 'COMMON.LOCAL'
3746       include 'COMMON.CHAIN'
3747       include 'COMMON.DERIV'
3748       include 'COMMON.INTERACT'
3749       include 'COMMON.CONTACTS'
3750       include 'COMMON.TORSION'
3751       include 'COMMON.VECTORS'
3752       include 'COMMON.FFIELD'
3753       include 'COMMON.CONTROL'
3754       dimension ggg(3)
3755       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3756      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3757      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3758       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3759      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3760       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3761      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3762      &    num_conti,j1,j2
3763       j=i+2
3764 c      write (iout,*) "eturn3",i,j,j1,j2
3765       a_temp(1,1)=a22
3766       a_temp(1,2)=a23
3767       a_temp(2,1)=a32
3768       a_temp(2,2)=a33
3769 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3770 C
3771 C               Third-order contributions
3772 C
3773 C                 (i+2)o----(i+3)
3774 C                      | |
3775 C                      | |
3776 C                 (i+1)o----i
3777 C
3778 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3779 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3780         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3781         call transpose2(auxmat(1,1),auxmat1(1,1))
3782         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3783         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3784         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3785      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3786 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3787 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3788 cd     &    ' eello_turn3_num',4*eello_turn3_num
3789 C Derivatives in gamma(i)
3790         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3791         call transpose2(auxmat2(1,1),auxmat3(1,1))
3792         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3793         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3794 C Derivatives in gamma(i+1)
3795         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3796         call transpose2(auxmat2(1,1),auxmat3(1,1))
3797         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3798         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3799      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3800 C Cartesian derivatives
3801         do l=1,3
3802 c            ghalf1=0.5d0*agg(l,1)
3803 c            ghalf2=0.5d0*agg(l,2)
3804 c            ghalf3=0.5d0*agg(l,3)
3805 c            ghalf4=0.5d0*agg(l,4)
3806           a_temp(1,1)=aggi(l,1)!+ghalf1
3807           a_temp(1,2)=aggi(l,2)!+ghalf2
3808           a_temp(2,1)=aggi(l,3)!+ghalf3
3809           a_temp(2,2)=aggi(l,4)!+ghalf4
3810           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3811           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3812      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3813           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3814           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3815           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3816           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3817           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3818           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3819      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3820           a_temp(1,1)=aggj(l,1)!+ghalf1
3821           a_temp(1,2)=aggj(l,2)!+ghalf2
3822           a_temp(2,1)=aggj(l,3)!+ghalf3
3823           a_temp(2,2)=aggj(l,4)!+ghalf4
3824           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3825           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3826      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3827           a_temp(1,1)=aggj1(l,1)
3828           a_temp(1,2)=aggj1(l,2)
3829           a_temp(2,1)=aggj1(l,3)
3830           a_temp(2,2)=aggj1(l,4)
3831           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3832           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3833      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3834         enddo
3835       return
3836       end
3837 C-------------------------------------------------------------------------------
3838       subroutine eturn4(i,eello_turn4)
3839 C Third- and fourth-order contributions from turns
3840       implicit real*8 (a-h,o-z)
3841       include 'DIMENSIONS'
3842       include 'COMMON.IOUNITS'
3843       include 'COMMON.GEO'
3844       include 'COMMON.VAR'
3845       include 'COMMON.LOCAL'
3846       include 'COMMON.CHAIN'
3847       include 'COMMON.DERIV'
3848       include 'COMMON.INTERACT'
3849       include 'COMMON.CONTACTS'
3850       include 'COMMON.TORSION'
3851       include 'COMMON.VECTORS'
3852       include 'COMMON.FFIELD'
3853       include 'COMMON.CONTROL'
3854       dimension ggg(3)
3855       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3856      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3857      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3858       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3859      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3860       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3861      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3862      &    num_conti,j1,j2
3863       j=i+3
3864 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3865 C
3866 C               Fourth-order contributions
3867 C
3868 C                 (i+3)o----(i+4)
3869 C                     /  |
3870 C               (i+2)o   |
3871 C                     \  |
3872 C                 (i+1)o----i
3873 C
3874 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3875 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3876 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3877         a_temp(1,1)=a22
3878         a_temp(1,2)=a23
3879         a_temp(2,1)=a32
3880         a_temp(2,2)=a33
3881         iti1=itortyp(itype(i+1))
3882         iti2=itortyp(itype(i+2))
3883         iti3=itortyp(itype(i+3))
3884 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3885         call transpose2(EUg(1,1,i+1),e1t(1,1))
3886         call transpose2(Eug(1,1,i+2),e2t(1,1))
3887         call transpose2(Eug(1,1,i+3),e3t(1,1))
3888         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3889         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3890         s1=scalar2(b1(1,iti2),auxvec(1))
3891         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3892         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3893         s2=scalar2(b1(1,iti1),auxvec(1))
3894         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3895         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3896         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3897         eello_turn4=eello_turn4-(s1+s2+s3)
3898 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3899         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3900      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3901 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3902 cd     &    ' eello_turn4_num',8*eello_turn4_num
3903 C Derivatives in gamma(i)
3904         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3905         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3906         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3907         s1=scalar2(b1(1,iti2),auxvec(1))
3908         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3909         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3910         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3911 C Derivatives in gamma(i+1)
3912         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3913         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3914         s2=scalar2(b1(1,iti1),auxvec(1))
3915         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3916         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3917         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3918         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3919 C Derivatives in gamma(i+2)
3920         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3921         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3922         s1=scalar2(b1(1,iti2),auxvec(1))
3923         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3924         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3925         s2=scalar2(b1(1,iti1),auxvec(1))
3926         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3927         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3928         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3929         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3930 C Cartesian derivatives
3931 C Derivatives of this turn contributions in DC(i+2)
3932         if (j.lt.nres-1) then
3933           do l=1,3
3934             a_temp(1,1)=agg(l,1)
3935             a_temp(1,2)=agg(l,2)
3936             a_temp(2,1)=agg(l,3)
3937             a_temp(2,2)=agg(l,4)
3938             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3939             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3940             s1=scalar2(b1(1,iti2),auxvec(1))
3941             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3942             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3943             s2=scalar2(b1(1,iti1),auxvec(1))
3944             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3945             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3946             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3947             ggg(l)=-(s1+s2+s3)
3948             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3949           enddo
3950         endif
3951 C Remaining derivatives of this turn contribution
3952         do l=1,3
3953           a_temp(1,1)=aggi(l,1)
3954           a_temp(1,2)=aggi(l,2)
3955           a_temp(2,1)=aggi(l,3)
3956           a_temp(2,2)=aggi(l,4)
3957           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3958           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3959           s1=scalar2(b1(1,iti2),auxvec(1))
3960           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3961           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3962           s2=scalar2(b1(1,iti1),auxvec(1))
3963           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3964           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3965           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3966           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3967           a_temp(1,1)=aggi1(l,1)
3968           a_temp(1,2)=aggi1(l,2)
3969           a_temp(2,1)=aggi1(l,3)
3970           a_temp(2,2)=aggi1(l,4)
3971           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3972           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3973           s1=scalar2(b1(1,iti2),auxvec(1))
3974           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3975           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3976           s2=scalar2(b1(1,iti1),auxvec(1))
3977           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3978           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3979           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3980           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3981           a_temp(1,1)=aggj(l,1)
3982           a_temp(1,2)=aggj(l,2)
3983           a_temp(2,1)=aggj(l,3)
3984           a_temp(2,2)=aggj(l,4)
3985           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3986           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3987           s1=scalar2(b1(1,iti2),auxvec(1))
3988           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3989           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3990           s2=scalar2(b1(1,iti1),auxvec(1))
3991           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3992           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3993           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3994           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3995           a_temp(1,1)=aggj1(l,1)
3996           a_temp(1,2)=aggj1(l,2)
3997           a_temp(2,1)=aggj1(l,3)
3998           a_temp(2,2)=aggj1(l,4)
3999           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4000           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4001           s1=scalar2(b1(1,iti2),auxvec(1))
4002           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4003           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4004           s2=scalar2(b1(1,iti1),auxvec(1))
4005           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4006           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4007           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4008 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4009           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4010         enddo
4011       return
4012       end
4013 C-----------------------------------------------------------------------------
4014       subroutine vecpr(u,v,w)
4015       implicit real*8(a-h,o-z)
4016       dimension u(3),v(3),w(3)
4017       w(1)=u(2)*v(3)-u(3)*v(2)
4018       w(2)=-u(1)*v(3)+u(3)*v(1)
4019       w(3)=u(1)*v(2)-u(2)*v(1)
4020       return
4021       end
4022 C-----------------------------------------------------------------------------
4023       subroutine unormderiv(u,ugrad,unorm,ungrad)
4024 C This subroutine computes the derivatives of a normalized vector u, given
4025 C the derivatives computed without normalization conditions, ugrad. Returns
4026 C ungrad.
4027       implicit none
4028       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4029       double precision vec(3)
4030       double precision scalar
4031       integer i,j
4032 c      write (2,*) 'ugrad',ugrad
4033 c      write (2,*) 'u',u
4034       do i=1,3
4035         vec(i)=scalar(ugrad(1,i),u(1))
4036       enddo
4037 c      write (2,*) 'vec',vec
4038       do i=1,3
4039         do j=1,3
4040           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4041         enddo
4042       enddo
4043 c      write (2,*) 'ungrad',ungrad
4044       return
4045       end
4046 C-----------------------------------------------------------------------------
4047       subroutine escp_soft_sphere(evdw2,evdw2_14)
4048 C
4049 C This subroutine calculates the excluded-volume interaction energy between
4050 C peptide-group centers and side chains and its gradient in virtual-bond and
4051 C side-chain vectors.
4052 C
4053       implicit real*8 (a-h,o-z)
4054       include 'DIMENSIONS'
4055       include 'COMMON.GEO'
4056       include 'COMMON.VAR'
4057       include 'COMMON.LOCAL'
4058       include 'COMMON.CHAIN'
4059       include 'COMMON.DERIV'
4060       include 'COMMON.INTERACT'
4061       include 'COMMON.FFIELD'
4062       include 'COMMON.IOUNITS'
4063       include 'COMMON.CONTROL'
4064       dimension ggg(3)
4065       evdw2=0.0D0
4066       evdw2_14=0.0d0
4067       r0_scp=4.5d0
4068 cd    print '(a)','Enter ESCP'
4069 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4070       do xshift=-1,1
4071       do yshift=-1,1
4072       do zshift=-1,1
4073       do i=iatscp_s,iatscp_e
4074         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4075         iteli=itel(i)
4076         xi=0.5D0*(c(1,i)+c(1,i+1))
4077         yi=0.5D0*(c(2,i)+c(2,i+1))
4078         zi=0.5D0*(c(3,i)+c(3,i+1))
4079 C Return atom into box, boxxsize is size of box in x dimension
4080   134   continue
4081         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4082         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4083 C Condition for being inside the proper box
4084         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4085      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4086         go to 134
4087         endif
4088   135   continue
4089         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4090         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4091 C Condition for being inside the proper box
4092         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4093      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4094         go to 135
4095         endif
4096   136   continue
4097         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4098         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4099 C Condition for being inside the proper box
4100         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4101      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4102         go to 136
4103         endif
4104         do iint=1,nscp_gr(i)
4105
4106         do j=iscpstart(i,iint),iscpend(i,iint)
4107           if (itype(j).eq.ntyp1) cycle
4108           itypj=iabs(itype(j))
4109 C Uncomment following three lines for SC-p interactions
4110 c         xj=c(1,nres+j)-xi
4111 c         yj=c(2,nres+j)-yi
4112 c         zj=c(3,nres+j)-zi
4113 C Uncomment following three lines for Ca-p interactions
4114           xj=c(1,j)
4115           yj=c(2,j)
4116           zj=c(3,j)
4117   174   continue
4118         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4119         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4120 C Condition for being inside the proper box
4121         if ((xj.gt.((0.5d0)*boxxsize)).or.
4122      &       (xj.lt.((-0.5d0)*boxxsize))) then
4123         go to 174
4124         endif
4125   175   continue
4126         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4127         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4128 C Condition for being inside the proper box
4129         if ((yj.gt.((0.5d0)*boxysize)).or.
4130      &       (yj.lt.((-0.5d0)*boxysize))) then
4131         go to 175
4132         endif
4133   176   continue
4134         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4135         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4136 C Condition for being inside the proper box
4137         if ((zj.gt.((0.5d0)*boxzsize)).or.
4138      &       (zj.lt.((-0.5d0)*boxzsize))) then
4139         go to 176
4140         endif
4141           xj=xj-xi
4142           yj=yj-yi
4143           zj=zj-zi
4144           rij=xj*xj+yj*yj+zj*zj
4145
4146           r0ij=r0_scp
4147           r0ijsq=r0ij*r0ij
4148           if (rij.lt.r0ijsq) then
4149             evdwij=0.25d0*(rij-r0ijsq)**2
4150             fac=rij-r0ijsq
4151           else
4152             evdwij=0.0d0
4153             fac=0.0d0
4154           endif
4155           evdw2=evdw2+evdwij
4156 C
4157 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4158 C
4159           ggg(1)=xj*fac
4160           ggg(2)=yj*fac
4161           ggg(3)=zj*fac
4162 cgrad          if (j.lt.i) then
4163 cd          write (iout,*) 'j<i'
4164 C Uncomment following three lines for SC-p interactions
4165 c           do k=1,3
4166 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4167 c           enddo
4168 cgrad          else
4169 cd          write (iout,*) 'j>i'
4170 cgrad            do k=1,3
4171 cgrad              ggg(k)=-ggg(k)
4172 C Uncomment following line for SC-p interactions
4173 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4174 cgrad            enddo
4175 cgrad          endif
4176 cgrad          do k=1,3
4177 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4178 cgrad          enddo
4179 cgrad          kstart=min0(i+1,j)
4180 cgrad          kend=max0(i-1,j-1)
4181 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4182 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4183 cgrad          do k=kstart,kend
4184 cgrad            do l=1,3
4185 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4186 cgrad            enddo
4187 cgrad          enddo
4188           do k=1,3
4189             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4190             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4191           enddo
4192         enddo
4193
4194         enddo ! iint
4195       enddo ! i
4196       enddo !zshift
4197       enddo !yshift
4198       enddo !xshift
4199       return
4200       end
4201 C-----------------------------------------------------------------------------
4202       subroutine escp(evdw2,evdw2_14)
4203 C
4204 C This subroutine calculates the excluded-volume interaction energy between
4205 C peptide-group centers and side chains and its gradient in virtual-bond and
4206 C side-chain vectors.
4207 C
4208       implicit real*8 (a-h,o-z)
4209       include 'DIMENSIONS'
4210       include 'COMMON.GEO'
4211       include 'COMMON.VAR'
4212       include 'COMMON.LOCAL'
4213       include 'COMMON.CHAIN'
4214       include 'COMMON.DERIV'
4215       include 'COMMON.INTERACT'
4216       include 'COMMON.FFIELD'
4217       include 'COMMON.IOUNITS'
4218       include 'COMMON.CONTROL'
4219       include 'COMMON.SPLITELE'
4220       dimension ggg(3)
4221       evdw2=0.0D0
4222       evdw2_14=0.0d0
4223 cd    print '(a)','Enter ESCP'
4224 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4225       do xshift=-1,1
4226       do yshift=-1,1
4227       do zshift=-1,1
4228       do i=iatscp_s,iatscp_e
4229         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4230         iteli=itel(i)
4231         xi=0.5D0*(c(1,i)+c(1,i+1))
4232         yi=0.5D0*(c(2,i)+c(2,i+1))
4233         zi=0.5D0*(c(3,i)+c(3,i+1))
4234 C Return atom into box, boxxsize is size of box in x dimension
4235   134   continue
4236         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4237         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4238 C Condition for being inside the proper box
4239         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4240      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4241         go to 134
4242         endif
4243   135   continue
4244         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4245         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4246 C Condition for being inside the proper box
4247         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4248      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4249         go to 135
4250         endif
4251   136   continue
4252         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4253         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4254 C Condition for being inside the proper box
4255         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4256      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4257         go to 136
4258         endif
4259         do iint=1,nscp_gr(i)
4260
4261         do j=iscpstart(i,iint),iscpend(i,iint)
4262           itypj=iabs(itype(j))
4263           if (itypj.eq.ntyp1) cycle
4264 C Uncomment following three lines for SC-p interactions
4265 c         xj=c(1,nres+j)-xi
4266 c         yj=c(2,nres+j)-yi
4267 c         zj=c(3,nres+j)-zi
4268 C Uncomment following three lines for Ca-p interactions
4269           xj=c(1,j)
4270           yj=c(2,j)
4271           zj=c(3,j)
4272   174   continue
4273         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4274         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4275 C Condition for being inside the proper box
4276         if ((xj.gt.((0.5d0)*boxxsize)).or.
4277      &       (xj.lt.((-0.5d0)*boxxsize))) then
4278         go to 174
4279         endif
4280   175   continue
4281         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4282         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4283 C Condition for being inside the proper box
4284         if ((yj.gt.((0.5d0)*boxysize)).or.
4285      &       (yj.lt.((-0.5d0)*boxysize))) then
4286         go to 175
4287         endif
4288   176   continue
4289         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4290         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4291 C Condition for being inside the proper box
4292         if ((zj.gt.((0.5d0)*boxzsize)).or.
4293      &       (zj.lt.((-0.5d0)*boxzsize))) then
4294         go to 176
4295         endif
4296           xj=xj-xi
4297           yj=yj-yi
4298           zj=zj-zi
4299           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4300           sss=sscale(1.0d0/(dsqrt(rrij)))
4301           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4302           if (sss.gt.0.0d0) then
4303           fac=rrij**expon2
4304           e1=fac*fac*aad(itypj,iteli)
4305           e2=fac*bad(itypj,iteli)
4306           if (iabs(j-i) .le. 2) then
4307             e1=scal14*e1
4308             e2=scal14*e2
4309             evdw2_14=evdw2_14+(e1+e2)*sss
4310           endif
4311           evdwij=e1+e2
4312           evdw2=evdw2+evdwij*sss
4313           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4314      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4315      &       bad(itypj,iteli)
4316 C
4317 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4318 C
4319           fac=-(evdwij+e1)*rrij*sss
4320           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4321           ggg(1)=xj*fac
4322           ggg(2)=yj*fac
4323           ggg(3)=zj*fac
4324 cgrad          if (j.lt.i) then
4325 cd          write (iout,*) 'j<i'
4326 C Uncomment following three lines for SC-p interactions
4327 c           do k=1,3
4328 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4329 c           enddo
4330 cgrad          else
4331 cd          write (iout,*) 'j>i'
4332 cgrad            do k=1,3
4333 cgrad              ggg(k)=-ggg(k)
4334 C Uncomment following line for SC-p interactions
4335 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4336 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4337 cgrad            enddo
4338 cgrad          endif
4339 cgrad          do k=1,3
4340 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4341 cgrad          enddo
4342 cgrad          kstart=min0(i+1,j)
4343 cgrad          kend=max0(i-1,j-1)
4344 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4345 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4346 cgrad          do k=kstart,kend
4347 cgrad            do l=1,3
4348 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4349 cgrad            enddo
4350 cgrad          enddo
4351           do k=1,3
4352             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4353             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4354           enddo
4355         endif !endif for sscale cutoff
4356         enddo ! j
4357
4358         enddo ! iint
4359       enddo ! i
4360       enddo !zshift
4361       enddo !yshift
4362       enddo !xshift
4363       do i=1,nct
4364         do j=1,3
4365           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4366           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4367           gradx_scp(j,i)=expon*gradx_scp(j,i)
4368         enddo
4369       enddo
4370 C******************************************************************************
4371 C
4372 C                              N O T E !!!
4373 C
4374 C To save time the factor EXPON has been extracted from ALL components
4375 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4376 C use!
4377 C
4378 C******************************************************************************
4379       return
4380       end
4381 C--------------------------------------------------------------------------
4382       subroutine edis(ehpb)
4383 C
4384 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4385 C
4386       implicit real*8 (a-h,o-z)
4387       include 'DIMENSIONS'
4388       include 'COMMON.SBRIDGE'
4389       include 'COMMON.CHAIN'
4390       include 'COMMON.DERIV'
4391       include 'COMMON.VAR'
4392       include 'COMMON.INTERACT'
4393       include 'COMMON.IOUNITS'
4394       dimension ggg(3)
4395       ehpb=0.0D0
4396 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4397 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4398       if (link_end.eq.0) return
4399       do i=link_start,link_end
4400 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4401 C CA-CA distance used in regularization of structure.
4402         ii=ihpb(i)
4403         jj=jhpb(i)
4404 C iii and jjj point to the residues for which the distance is assigned.
4405         if (ii.gt.nres) then
4406           iii=ii-nres
4407           jjj=jj-nres
4408         else
4409           iii=ii
4410           jjj=jj
4411         endif
4412 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4413 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4414 C    distance and angle dependent SS bond potential.
4415         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4416      & iabs(itype(jjj)).eq.1) then
4417           call ssbond_ene(iii,jjj,eij)
4418           ehpb=ehpb+2*eij
4419 cd          write (iout,*) "eij",eij
4420         else
4421 C Calculate the distance between the two points and its difference from the
4422 C target distance.
4423         dd=dist(ii,jj)
4424         rdis=dd-dhpb(i)
4425 C Get the force constant corresponding to this distance.
4426         waga=forcon(i)
4427 C Calculate the contribution to energy.
4428         ehpb=ehpb+waga*rdis*rdis
4429 C
4430 C Evaluate gradient.
4431 C
4432         fac=waga*rdis/dd
4433 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4434 cd   &   ' waga=',waga,' fac=',fac
4435         do j=1,3
4436           ggg(j)=fac*(c(j,jj)-c(j,ii))
4437         enddo
4438 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4439 C If this is a SC-SC distance, we need to calculate the contributions to the
4440 C Cartesian gradient in the SC vectors (ghpbx).
4441         if (iii.lt.ii) then
4442           do j=1,3
4443             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4444             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4445           enddo
4446         endif
4447 cgrad        do j=iii,jjj-1
4448 cgrad          do k=1,3
4449 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4450 cgrad          enddo
4451 cgrad        enddo
4452         do k=1,3
4453           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4454           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4455         enddo
4456         endif
4457       enddo
4458       ehpb=0.5D0*ehpb
4459       return
4460       end
4461 C--------------------------------------------------------------------------
4462       subroutine ssbond_ene(i,j,eij)
4463 C
4464 C Calculate the distance and angle dependent SS-bond potential energy
4465 C using a free-energy function derived based on RHF/6-31G** ab initio
4466 C calculations of diethyl disulfide.
4467 C
4468 C A. Liwo and U. Kozlowska, 11/24/03
4469 C
4470       implicit real*8 (a-h,o-z)
4471       include 'DIMENSIONS'
4472       include 'COMMON.SBRIDGE'
4473       include 'COMMON.CHAIN'
4474       include 'COMMON.DERIV'
4475       include 'COMMON.LOCAL'
4476       include 'COMMON.INTERACT'
4477       include 'COMMON.VAR'
4478       include 'COMMON.IOUNITS'
4479       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4480       itypi=iabs(itype(i))
4481       xi=c(1,nres+i)
4482       yi=c(2,nres+i)
4483       zi=c(3,nres+i)
4484       dxi=dc_norm(1,nres+i)
4485       dyi=dc_norm(2,nres+i)
4486       dzi=dc_norm(3,nres+i)
4487 c      dsci_inv=dsc_inv(itypi)
4488       dsci_inv=vbld_inv(nres+i)
4489       itypj=iabs(itype(j))
4490 c      dscj_inv=dsc_inv(itypj)
4491       dscj_inv=vbld_inv(nres+j)
4492       xj=c(1,nres+j)-xi
4493       yj=c(2,nres+j)-yi
4494       zj=c(3,nres+j)-zi
4495       dxj=dc_norm(1,nres+j)
4496       dyj=dc_norm(2,nres+j)
4497       dzj=dc_norm(3,nres+j)
4498       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4499       rij=dsqrt(rrij)
4500       erij(1)=xj*rij
4501       erij(2)=yj*rij
4502       erij(3)=zj*rij
4503       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4504       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4505       om12=dxi*dxj+dyi*dyj+dzi*dzj
4506       do k=1,3
4507         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4508         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4509       enddo
4510       rij=1.0d0/rij
4511       deltad=rij-d0cm
4512       deltat1=1.0d0-om1
4513       deltat2=1.0d0+om2
4514       deltat12=om2-om1+2.0d0
4515       cosphi=om12-om1*om2
4516       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4517      &  +akct*deltad*deltat12
4518      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4519 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4520 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4521 c     &  " deltat12",deltat12," eij",eij
4522       ed=2*akcm*deltad+akct*deltat12
4523       pom1=akct*deltad
4524       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4525       eom1=-2*akth*deltat1-pom1-om2*pom2
4526       eom2= 2*akth*deltat2+pom1-om1*pom2
4527       eom12=pom2
4528       do k=1,3
4529         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4530         ghpbx(k,i)=ghpbx(k,i)-ggk
4531      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4532      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4533         ghpbx(k,j)=ghpbx(k,j)+ggk
4534      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4535      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4536         ghpbc(k,i)=ghpbc(k,i)-ggk
4537         ghpbc(k,j)=ghpbc(k,j)+ggk
4538       enddo
4539 C
4540 C Calculate the components of the gradient in DC and X
4541 C
4542 cgrad      do k=i,j-1
4543 cgrad        do l=1,3
4544 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4545 cgrad        enddo
4546 cgrad      enddo
4547       return
4548       end
4549 C--------------------------------------------------------------------------
4550       subroutine ebond(estr)
4551 c
4552 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4553 c
4554       implicit real*8 (a-h,o-z)
4555       include 'DIMENSIONS'
4556       include 'COMMON.LOCAL'
4557       include 'COMMON.GEO'
4558       include 'COMMON.INTERACT'
4559       include 'COMMON.DERIV'
4560       include 'COMMON.VAR'
4561       include 'COMMON.CHAIN'
4562       include 'COMMON.IOUNITS'
4563       include 'COMMON.NAMES'
4564       include 'COMMON.FFIELD'
4565       include 'COMMON.CONTROL'
4566       include 'COMMON.SETUP'
4567       double precision u(3),ud(3)
4568       estr=0.0d0
4569       estr1=0.0d0
4570       do i=ibondp_start,ibondp_end
4571         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4572 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4573 c          do j=1,3
4574 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4575 c     &      *dc(j,i-1)/vbld(i)
4576 c          enddo
4577 c          if (energy_dec) write(iout,*)
4578 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4579 c        else
4580 C       Checking if it involves dummy (NH3+ or COO-) group
4581          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4582 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4583         diff = vbld(i)-vbldpDUM
4584          else
4585 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4586         diff = vbld(i)-vbldp0
4587          endif
4588         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4589      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4590         estr=estr+diff*diff
4591         do j=1,3
4592           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4593         enddo
4594 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4595 c        endif
4596       enddo
4597       estr=0.5d0*AKP*estr+estr1
4598 c
4599 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4600 c
4601       do i=ibond_start,ibond_end
4602         iti=iabs(itype(i))
4603         if (iti.ne.10 .and. iti.ne.ntyp1) then
4604           nbi=nbondterm(iti)
4605           if (nbi.eq.1) then
4606             diff=vbld(i+nres)-vbldsc0(1,iti)
4607             if (energy_dec) write (iout,*)
4608      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4609      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4610             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4611             do j=1,3
4612               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4613             enddo
4614           else
4615             do j=1,nbi
4616               diff=vbld(i+nres)-vbldsc0(j,iti)
4617               ud(j)=aksc(j,iti)*diff
4618               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4619             enddo
4620             uprod=u(1)
4621             do j=2,nbi
4622               uprod=uprod*u(j)
4623             enddo
4624             usum=0.0d0
4625             usumsqder=0.0d0
4626             do j=1,nbi
4627               uprod1=1.0d0
4628               uprod2=1.0d0
4629               do k=1,nbi
4630                 if (k.ne.j) then
4631                   uprod1=uprod1*u(k)
4632                   uprod2=uprod2*u(k)*u(k)
4633                 endif
4634               enddo
4635               usum=usum+uprod1
4636               usumsqder=usumsqder+ud(j)*uprod2
4637             enddo
4638             estr=estr+uprod/usum
4639             do j=1,3
4640              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4641             enddo
4642           endif
4643         endif
4644       enddo
4645       return
4646       end
4647 #ifdef CRYST_THETA
4648 C--------------------------------------------------------------------------
4649       subroutine ebend(etheta)
4650 C
4651 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4652 C angles gamma and its derivatives in consecutive thetas and gammas.
4653 C
4654       implicit real*8 (a-h,o-z)
4655       include 'DIMENSIONS'
4656       include 'COMMON.LOCAL'
4657       include 'COMMON.GEO'
4658       include 'COMMON.INTERACT'
4659       include 'COMMON.DERIV'
4660       include 'COMMON.VAR'
4661       include 'COMMON.CHAIN'
4662       include 'COMMON.IOUNITS'
4663       include 'COMMON.NAMES'
4664       include 'COMMON.FFIELD'
4665       include 'COMMON.CONTROL'
4666       common /calcthet/ term1,term2,termm,diffak,ratak,
4667      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4668      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4669       double precision y(2),z(2)
4670       delta=0.02d0*pi
4671 c      time11=dexp(-2*time)
4672 c      time12=1.0d0
4673       etheta=0.0D0
4674 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4675       do i=ithet_start,ithet_end
4676         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4677      &  .or.itype(i).eq.ntyp1) cycle
4678 C Zero the energy function and its derivative at 0 or pi.
4679         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4680         it=itype(i-1)
4681         ichir1=isign(1,itype(i-2))
4682         ichir2=isign(1,itype(i))
4683          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4684          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4685          if (itype(i-1).eq.10) then
4686           itype1=isign(10,itype(i-2))
4687           ichir11=isign(1,itype(i-2))
4688           ichir12=isign(1,itype(i-2))
4689           itype2=isign(10,itype(i))
4690           ichir21=isign(1,itype(i))
4691           ichir22=isign(1,itype(i))
4692          endif
4693
4694         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4695 #ifdef OSF
4696           phii=phi(i)
4697           if (phii.ne.phii) phii=150.0
4698 #else
4699           phii=phi(i)
4700 #endif
4701           y(1)=dcos(phii)
4702           y(2)=dsin(phii)
4703         else
4704           y(1)=0.0D0
4705           y(2)=0.0D0
4706         endif
4707         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4708 #ifdef OSF
4709           phii1=phi(i+1)
4710           if (phii1.ne.phii1) phii1=150.0
4711           phii1=pinorm(phii1)
4712           z(1)=cos(phii1)
4713 #else
4714           phii1=phi(i+1)
4715 #endif
4716           z(1)=dcos(phii1)
4717           z(2)=dsin(phii1)
4718         else
4719           z(1)=0.0D0
4720           z(2)=0.0D0
4721         endif
4722 C Calculate the "mean" value of theta from the part of the distribution
4723 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4724 C In following comments this theta will be referred to as t_c.
4725         thet_pred_mean=0.0d0
4726         do k=1,2
4727             athetk=athet(k,it,ichir1,ichir2)
4728             bthetk=bthet(k,it,ichir1,ichir2)
4729           if (it.eq.10) then
4730              athetk=athet(k,itype1,ichir11,ichir12)
4731              bthetk=bthet(k,itype2,ichir21,ichir22)
4732           endif
4733          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4734 c         write(iout,*) 'chuj tu', y(k),z(k)
4735         enddo
4736         dthett=thet_pred_mean*ssd
4737         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4738 C Derivatives of the "mean" values in gamma1 and gamma2.
4739         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4740      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4741          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4742      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4743          if (it.eq.10) then
4744       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4745      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4746         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4747      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4748          endif
4749         if (theta(i).gt.pi-delta) then
4750           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4751      &         E_tc0)
4752           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4753           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4754           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4755      &        E_theta)
4756           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4757      &        E_tc)
4758         else if (theta(i).lt.delta) then
4759           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4760           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4761           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4762      &        E_theta)
4763           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4764           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4765      &        E_tc)
4766         else
4767           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4768      &        E_theta,E_tc)
4769         endif
4770         etheta=etheta+ethetai
4771         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4772      &      'ebend',i,ethetai,theta(i),itype(i)
4773         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4774         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4775         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4776       enddo
4777 C Ufff.... We've done all this!!!
4778       return
4779       end
4780 C---------------------------------------------------------------------------
4781       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4782      &     E_tc)
4783       implicit real*8 (a-h,o-z)
4784       include 'DIMENSIONS'
4785       include 'COMMON.LOCAL'
4786       include 'COMMON.IOUNITS'
4787       common /calcthet/ term1,term2,termm,diffak,ratak,
4788      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4789      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4790 C Calculate the contributions to both Gaussian lobes.
4791 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4792 C The "polynomial part" of the "standard deviation" of this part of
4793 C the distributioni.
4794 ccc        write (iout,*) thetai,thet_pred_mean
4795         sig=polthet(3,it)
4796         do j=2,0,-1
4797           sig=sig*thet_pred_mean+polthet(j,it)
4798         enddo
4799 C Derivative of the "interior part" of the "standard deviation of the"
4800 C gamma-dependent Gaussian lobe in t_c.
4801         sigtc=3*polthet(3,it)
4802         do j=2,1,-1
4803           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4804         enddo
4805         sigtc=sig*sigtc
4806 C Set the parameters of both Gaussian lobes of the distribution.
4807 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4808         fac=sig*sig+sigc0(it)
4809         sigcsq=fac+fac
4810         sigc=1.0D0/sigcsq
4811 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4812         sigsqtc=-4.0D0*sigcsq*sigtc
4813 c       print *,i,sig,sigtc,sigsqtc
4814 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4815         sigtc=-sigtc/(fac*fac)
4816 C Following variable is sigma(t_c)**(-2)
4817         sigcsq=sigcsq*sigcsq
4818         sig0i=sig0(it)
4819         sig0inv=1.0D0/sig0i**2
4820         delthec=thetai-thet_pred_mean
4821         delthe0=thetai-theta0i
4822         term1=-0.5D0*sigcsq*delthec*delthec
4823         term2=-0.5D0*sig0inv*delthe0*delthe0
4824 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
4825 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4826 C NaNs in taking the logarithm. We extract the largest exponent which is added
4827 C to the energy (this being the log of the distribution) at the end of energy
4828 C term evaluation for this virtual-bond angle.
4829         if (term1.gt.term2) then
4830           termm=term1
4831           term2=dexp(term2-termm)
4832           term1=1.0d0
4833         else
4834           termm=term2
4835           term1=dexp(term1-termm)
4836           term2=1.0d0
4837         endif
4838 C The ratio between the gamma-independent and gamma-dependent lobes of
4839 C the distribution is a Gaussian function of thet_pred_mean too.
4840         diffak=gthet(2,it)-thet_pred_mean
4841         ratak=diffak/gthet(3,it)**2
4842         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4843 C Let's differentiate it in thet_pred_mean NOW.
4844         aktc=ak*ratak
4845 C Now put together the distribution terms to make complete distribution.
4846         termexp=term1+ak*term2
4847         termpre=sigc+ak*sig0i
4848 C Contribution of the bending energy from this theta is just the -log of
4849 C the sum of the contributions from the two lobes and the pre-exponential
4850 C factor. Simple enough, isn't it?
4851         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4852 C       write (iout,*) 'termexp',termexp,termm,termpre,i
4853 C NOW the derivatives!!!
4854 C 6/6/97 Take into account the deformation.
4855         E_theta=(delthec*sigcsq*term1
4856      &       +ak*delthe0*sig0inv*term2)/termexp
4857         E_tc=((sigtc+aktc*sig0i)/termpre
4858      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4859      &       aktc*term2)/termexp)
4860       return
4861       end
4862 c-----------------------------------------------------------------------------
4863       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.LOCAL'
4867       include 'COMMON.IOUNITS'
4868       common /calcthet/ term1,term2,termm,diffak,ratak,
4869      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4870      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4871       delthec=thetai-thet_pred_mean
4872       delthe0=thetai-theta0i
4873 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4874       t3 = thetai-thet_pred_mean
4875       t6 = t3**2
4876       t9 = term1
4877       t12 = t3*sigcsq
4878       t14 = t12+t6*sigsqtc
4879       t16 = 1.0d0
4880       t21 = thetai-theta0i
4881       t23 = t21**2
4882       t26 = term2
4883       t27 = t21*t26
4884       t32 = termexp
4885       t40 = t32**2
4886       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4887      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4888      & *(-t12*t9-ak*sig0inv*t27)
4889       return
4890       end
4891 #else
4892 C--------------------------------------------------------------------------
4893       subroutine ebend(etheta)
4894 C
4895 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4896 C angles gamma and its derivatives in consecutive thetas and gammas.
4897 C ab initio-derived potentials from
4898 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4899 C
4900       implicit real*8 (a-h,o-z)
4901       include 'DIMENSIONS'
4902       include 'COMMON.LOCAL'
4903       include 'COMMON.GEO'
4904       include 'COMMON.INTERACT'
4905       include 'COMMON.DERIV'
4906       include 'COMMON.VAR'
4907       include 'COMMON.CHAIN'
4908       include 'COMMON.IOUNITS'
4909       include 'COMMON.NAMES'
4910       include 'COMMON.FFIELD'
4911       include 'COMMON.CONTROL'
4912       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4913      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4914      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4915      & sinph1ph2(maxdouble,maxdouble)
4916       logical lprn /.false./, lprn1 /.false./
4917       etheta=0.0D0
4918       do i=ithet_start,ithet_end
4919 c        print *,i,itype(i-1),itype(i),itype(i-2)
4920         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4921      &  .or.itype(i).eq.ntyp1) cycle
4922 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4923
4924         if (iabs(itype(i+1)).eq.20) iblock=2
4925         if (iabs(itype(i+1)).ne.20) iblock=1
4926         dethetai=0.0d0
4927         dephii=0.0d0
4928         dephii1=0.0d0
4929         theti2=0.5d0*theta(i)
4930         ityp2=ithetyp((itype(i-1)))
4931         do k=1,nntheterm
4932           coskt(k)=dcos(k*theti2)
4933           sinkt(k)=dsin(k*theti2)
4934         enddo
4935         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4936 #ifdef OSF
4937           phii=phi(i)
4938           if (phii.ne.phii) phii=150.0
4939 #else
4940           phii=phi(i)
4941 #endif
4942           ityp1=ithetyp((itype(i-2)))
4943 C propagation of chirality for glycine type
4944           do k=1,nsingle
4945             cosph1(k)=dcos(k*phii)
4946             sinph1(k)=dsin(k*phii)
4947           enddo
4948         else
4949           phii=0.0d0
4950           ityp1=nthetyp+1
4951           do k=1,nsingle
4952             cosph1(k)=0.0d0
4953             sinph1(k)=0.0d0
4954           enddo
4955         endif
4956         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4957 #ifdef OSF
4958           phii1=phi(i+1)
4959           if (phii1.ne.phii1) phii1=150.0
4960           phii1=pinorm(phii1)
4961 #else
4962           phii1=phi(i+1)
4963 #endif
4964           ityp3=ithetyp((itype(i)))
4965           do k=1,nsingle
4966             cosph2(k)=dcos(k*phii1)
4967             sinph2(k)=dsin(k*phii1)
4968           enddo
4969         else
4970           phii1=0.0d0
4971           ityp3=nthetyp+1
4972           do k=1,nsingle
4973             cosph2(k)=0.0d0
4974             sinph2(k)=0.0d0
4975           enddo
4976         endif
4977         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4978         do k=1,ndouble
4979           do l=1,k-1
4980             ccl=cosph1(l)*cosph2(k-l)
4981             ssl=sinph1(l)*sinph2(k-l)
4982             scl=sinph1(l)*cosph2(k-l)
4983             csl=cosph1(l)*sinph2(k-l)
4984             cosph1ph2(l,k)=ccl-ssl
4985             cosph1ph2(k,l)=ccl+ssl
4986             sinph1ph2(l,k)=scl+csl
4987             sinph1ph2(k,l)=scl-csl
4988           enddo
4989         enddo
4990         if (lprn) then
4991         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4992      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4993         write (iout,*) "coskt and sinkt"
4994         do k=1,nntheterm
4995           write (iout,*) k,coskt(k),sinkt(k)
4996         enddo
4997         endif
4998         do k=1,ntheterm
4999           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5000           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5001      &      *coskt(k)
5002           if (lprn)
5003      &    write (iout,*) "k",k,"
5004      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5005      &     " ethetai",ethetai
5006         enddo
5007         if (lprn) then
5008         write (iout,*) "cosph and sinph"
5009         do k=1,nsingle
5010           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5011         enddo
5012         write (iout,*) "cosph1ph2 and sinph2ph2"
5013         do k=2,ndouble
5014           do l=1,k-1
5015             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5016      &         sinph1ph2(l,k),sinph1ph2(k,l)
5017           enddo
5018         enddo
5019         write(iout,*) "ethetai",ethetai
5020         endif
5021         do m=1,ntheterm2
5022           do k=1,nsingle
5023             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5024      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5025      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5026      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5027             ethetai=ethetai+sinkt(m)*aux
5028             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5029             dephii=dephii+k*sinkt(m)*(
5030      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5031      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5032             dephii1=dephii1+k*sinkt(m)*(
5033      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5034      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5035             if (lprn)
5036      &      write (iout,*) "m",m," k",k," bbthet",
5037      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5038      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5039      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5040      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5041           enddo
5042         enddo
5043         if (lprn)
5044      &  write(iout,*) "ethetai",ethetai
5045         do m=1,ntheterm3
5046           do k=2,ndouble
5047             do l=1,k-1
5048               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5049      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5050      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5051      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5052               ethetai=ethetai+sinkt(m)*aux
5053               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5054               dephii=dephii+l*sinkt(m)*(
5055      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5056      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5057      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5058      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5059               dephii1=dephii1+(k-l)*sinkt(m)*(
5060      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5061      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5062      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5063      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5064               if (lprn) then
5065               write (iout,*) "m",m," k",k," l",l," ffthet",
5066      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5067      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5068      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5069      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5070      &            " ethetai",ethetai
5071               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5072      &            cosph1ph2(k,l)*sinkt(m),
5073      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5074               endif
5075             enddo
5076           enddo
5077         enddo
5078 10      continue
5079 c        lprn1=.true.
5080         if (lprn1)
5081      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5082      &   i,theta(i)*rad2deg,phii*rad2deg,
5083      &   phii1*rad2deg,ethetai
5084 c        lprn1=.false.
5085         etheta=etheta+ethetai
5086         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5087         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5088         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5089       enddo
5090       return
5091       end
5092 #endif
5093 #ifdef CRYST_SC
5094 c-----------------------------------------------------------------------------
5095       subroutine esc(escloc)
5096 C Calculate the local energy of a side chain and its derivatives in the
5097 C corresponding virtual-bond valence angles THETA and the spherical angles
5098 C ALPHA and OMEGA.
5099       implicit real*8 (a-h,o-z)
5100       include 'DIMENSIONS'
5101       include 'COMMON.GEO'
5102       include 'COMMON.LOCAL'
5103       include 'COMMON.VAR'
5104       include 'COMMON.INTERACT'
5105       include 'COMMON.DERIV'
5106       include 'COMMON.CHAIN'
5107       include 'COMMON.IOUNITS'
5108       include 'COMMON.NAMES'
5109       include 'COMMON.FFIELD'
5110       include 'COMMON.CONTROL'
5111       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5112      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5113       common /sccalc/ time11,time12,time112,theti,it,nlobit
5114       delta=0.02d0*pi
5115       escloc=0.0D0
5116 c     write (iout,'(a)') 'ESC'
5117       do i=loc_start,loc_end
5118         it=itype(i)
5119         if (it.eq.ntyp1) cycle
5120         if (it.eq.10) goto 1
5121         nlobit=nlob(iabs(it))
5122 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5123 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5124         theti=theta(i+1)-pipol
5125         x(1)=dtan(theti)
5126         x(2)=alph(i)
5127         x(3)=omeg(i)
5128
5129         if (x(2).gt.pi-delta) then
5130           xtemp(1)=x(1)
5131           xtemp(2)=pi-delta
5132           xtemp(3)=x(3)
5133           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5134           xtemp(2)=pi
5135           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5136           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5137      &        escloci,dersc(2))
5138           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5139      &        ddersc0(1),dersc(1))
5140           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5141      &        ddersc0(3),dersc(3))
5142           xtemp(2)=pi-delta
5143           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5144           xtemp(2)=pi
5145           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5146           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5147      &            dersc0(2),esclocbi,dersc02)
5148           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5149      &            dersc12,dersc01)
5150           call splinthet(x(2),0.5d0*delta,ss,ssd)
5151           dersc0(1)=dersc01
5152           dersc0(2)=dersc02
5153           dersc0(3)=0.0d0
5154           do k=1,3
5155             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5156           enddo
5157           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5158 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5159 c    &             esclocbi,ss,ssd
5160           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5161 c         escloci=esclocbi
5162 c         write (iout,*) escloci
5163         else if (x(2).lt.delta) then
5164           xtemp(1)=x(1)
5165           xtemp(2)=delta
5166           xtemp(3)=x(3)
5167           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5168           xtemp(2)=0.0d0
5169           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5170           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5171      &        escloci,dersc(2))
5172           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5173      &        ddersc0(1),dersc(1))
5174           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5175      &        ddersc0(3),dersc(3))
5176           xtemp(2)=delta
5177           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5178           xtemp(2)=0.0d0
5179           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5180           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5181      &            dersc0(2),esclocbi,dersc02)
5182           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5183      &            dersc12,dersc01)
5184           dersc0(1)=dersc01
5185           dersc0(2)=dersc02
5186           dersc0(3)=0.0d0
5187           call splinthet(x(2),0.5d0*delta,ss,ssd)
5188           do k=1,3
5189             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5190           enddo
5191           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5192 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5193 c    &             esclocbi,ss,ssd
5194           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5195 c         write (iout,*) escloci
5196         else
5197           call enesc(x,escloci,dersc,ddummy,.false.)
5198         endif
5199
5200         escloc=escloc+escloci
5201         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5202      &     'escloc',i,escloci
5203 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5204
5205         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5206      &   wscloc*dersc(1)
5207         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5208         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5209     1   continue
5210       enddo
5211       return
5212       end
5213 C---------------------------------------------------------------------------
5214       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5215       implicit real*8 (a-h,o-z)
5216       include 'DIMENSIONS'
5217       include 'COMMON.GEO'
5218       include 'COMMON.LOCAL'
5219       include 'COMMON.IOUNITS'
5220       common /sccalc/ time11,time12,time112,theti,it,nlobit
5221       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5222       double precision contr(maxlob,-1:1)
5223       logical mixed
5224 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5225         escloc_i=0.0D0
5226         do j=1,3
5227           dersc(j)=0.0D0
5228           if (mixed) ddersc(j)=0.0d0
5229         enddo
5230         x3=x(3)
5231
5232 C Because of periodicity of the dependence of the SC energy in omega we have
5233 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5234 C To avoid underflows, first compute & store the exponents.
5235
5236         do iii=-1,1
5237
5238           x(3)=x3+iii*dwapi
5239
5240           do j=1,nlobit
5241             do k=1,3
5242               z(k)=x(k)-censc(k,j,it)
5243             enddo
5244             do k=1,3
5245               Axk=0.0D0
5246               do l=1,3
5247                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5248               enddo
5249               Ax(k,j,iii)=Axk
5250             enddo
5251             expfac=0.0D0
5252             do k=1,3
5253               expfac=expfac+Ax(k,j,iii)*z(k)
5254             enddo
5255             contr(j,iii)=expfac
5256           enddo ! j
5257
5258         enddo ! iii
5259
5260         x(3)=x3
5261 C As in the case of ebend, we want to avoid underflows in exponentiation and
5262 C subsequent NaNs and INFs in energy calculation.
5263 C Find the largest exponent
5264         emin=contr(1,-1)
5265         do iii=-1,1
5266           do j=1,nlobit
5267             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5268           enddo
5269         enddo
5270         emin=0.5D0*emin
5271 cd      print *,'it=',it,' emin=',emin
5272
5273 C Compute the contribution to SC energy and derivatives
5274         do iii=-1,1
5275
5276           do j=1,nlobit
5277 #ifdef OSF
5278             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5279             if(adexp.ne.adexp) adexp=1.0
5280             expfac=dexp(adexp)
5281 #else
5282             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5283 #endif
5284 cd          print *,'j=',j,' expfac=',expfac
5285             escloc_i=escloc_i+expfac
5286             do k=1,3
5287               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5288             enddo
5289             if (mixed) then
5290               do k=1,3,2
5291                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5292      &            +gaussc(k,2,j,it))*expfac
5293               enddo
5294             endif
5295           enddo
5296
5297         enddo ! iii
5298
5299         dersc(1)=dersc(1)/cos(theti)**2
5300         ddersc(1)=ddersc(1)/cos(theti)**2
5301         ddersc(3)=ddersc(3)
5302
5303         escloci=-(dlog(escloc_i)-emin)
5304         do j=1,3
5305           dersc(j)=dersc(j)/escloc_i
5306         enddo
5307         if (mixed) then
5308           do j=1,3,2
5309             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5310           enddo
5311         endif
5312       return
5313       end
5314 C------------------------------------------------------------------------------
5315       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5316       implicit real*8 (a-h,o-z)
5317       include 'DIMENSIONS'
5318       include 'COMMON.GEO'
5319       include 'COMMON.LOCAL'
5320       include 'COMMON.IOUNITS'
5321       common /sccalc/ time11,time12,time112,theti,it,nlobit
5322       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5323       double precision contr(maxlob)
5324       logical mixed
5325
5326       escloc_i=0.0D0
5327
5328       do j=1,3
5329         dersc(j)=0.0D0
5330       enddo
5331
5332       do j=1,nlobit
5333         do k=1,2
5334           z(k)=x(k)-censc(k,j,it)
5335         enddo
5336         z(3)=dwapi
5337         do k=1,3
5338           Axk=0.0D0
5339           do l=1,3
5340             Axk=Axk+gaussc(l,k,j,it)*z(l)
5341           enddo
5342           Ax(k,j)=Axk
5343         enddo
5344         expfac=0.0D0
5345         do k=1,3
5346           expfac=expfac+Ax(k,j)*z(k)
5347         enddo
5348         contr(j)=expfac
5349       enddo ! j
5350
5351 C As in the case of ebend, we want to avoid underflows in exponentiation and
5352 C subsequent NaNs and INFs in energy calculation.
5353 C Find the largest exponent
5354       emin=contr(1)
5355       do j=1,nlobit
5356         if (emin.gt.contr(j)) emin=contr(j)
5357       enddo
5358       emin=0.5D0*emin
5359
5360 C Compute the contribution to SC energy and derivatives
5361
5362       dersc12=0.0d0
5363       do j=1,nlobit
5364         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5365         escloc_i=escloc_i+expfac
5366         do k=1,2
5367           dersc(k)=dersc(k)+Ax(k,j)*expfac
5368         enddo
5369         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5370      &            +gaussc(1,2,j,it))*expfac
5371         dersc(3)=0.0d0
5372       enddo
5373
5374       dersc(1)=dersc(1)/cos(theti)**2
5375       dersc12=dersc12/cos(theti)**2
5376       escloci=-(dlog(escloc_i)-emin)
5377       do j=1,2
5378         dersc(j)=dersc(j)/escloc_i
5379       enddo
5380       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5381       return
5382       end
5383 #else
5384 c----------------------------------------------------------------------------------
5385       subroutine esc(escloc)
5386 C Calculate the local energy of a side chain and its derivatives in the
5387 C corresponding virtual-bond valence angles THETA and the spherical angles
5388 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5389 C added by Urszula Kozlowska. 07/11/2007
5390 C
5391       implicit real*8 (a-h,o-z)
5392       include 'DIMENSIONS'
5393       include 'COMMON.GEO'
5394       include 'COMMON.LOCAL'
5395       include 'COMMON.VAR'
5396       include 'COMMON.SCROT'
5397       include 'COMMON.INTERACT'
5398       include 'COMMON.DERIV'
5399       include 'COMMON.CHAIN'
5400       include 'COMMON.IOUNITS'
5401       include 'COMMON.NAMES'
5402       include 'COMMON.FFIELD'
5403       include 'COMMON.CONTROL'
5404       include 'COMMON.VECTORS'
5405       double precision x_prime(3),y_prime(3),z_prime(3)
5406      &    , sumene,dsc_i,dp2_i,x(65),
5407      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5408      &    de_dxx,de_dyy,de_dzz,de_dt
5409       double precision s1_t,s1_6_t,s2_t,s2_6_t
5410       double precision
5411      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5412      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5413      & dt_dCi(3),dt_dCi1(3)
5414       common /sccalc/ time11,time12,time112,theti,it,nlobit
5415       delta=0.02d0*pi
5416       escloc=0.0D0
5417       do i=loc_start,loc_end
5418         if (itype(i).eq.ntyp1) cycle
5419         costtab(i+1) =dcos(theta(i+1))
5420         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5421         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5422         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5423         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5424         cosfac=dsqrt(cosfac2)
5425         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5426         sinfac=dsqrt(sinfac2)
5427         it=iabs(itype(i))
5428         if (it.eq.10) goto 1
5429 c
5430 C  Compute the axes of tghe local cartesian coordinates system; store in
5431 c   x_prime, y_prime and z_prime
5432 c
5433         do j=1,3
5434           x_prime(j) = 0.00
5435           y_prime(j) = 0.00
5436           z_prime(j) = 0.00
5437         enddo
5438 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5439 C     &   dc_norm(3,i+nres)
5440         do j = 1,3
5441           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5442           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5443         enddo
5444         do j = 1,3
5445           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5446         enddo
5447 c       write (2,*) "i",i
5448 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5449 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5450 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5451 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5452 c      & " xy",scalar(x_prime(1),y_prime(1)),
5453 c      & " xz",scalar(x_prime(1),z_prime(1)),
5454 c      & " yy",scalar(y_prime(1),y_prime(1)),
5455 c      & " yz",scalar(y_prime(1),z_prime(1)),
5456 c      & " zz",scalar(z_prime(1),z_prime(1))
5457 c
5458 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5459 C to local coordinate system. Store in xx, yy, zz.
5460 c
5461         xx=0.0d0
5462         yy=0.0d0
5463         zz=0.0d0
5464         do j = 1,3
5465           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5466           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5467           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5468         enddo
5469
5470         xxtab(i)=xx
5471         yytab(i)=yy
5472         zztab(i)=zz
5473 C
5474 C Compute the energy of the ith side cbain
5475 C
5476 c        write (2,*) "xx",xx," yy",yy," zz",zz
5477         it=iabs(itype(i))
5478         do j = 1,65
5479           x(j) = sc_parmin(j,it)
5480         enddo
5481 #ifdef CHECK_COORD
5482 Cc diagnostics - remove later
5483         xx1 = dcos(alph(2))
5484         yy1 = dsin(alph(2))*dcos(omeg(2))
5485         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5486         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5487      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5488      &    xx1,yy1,zz1
5489 C,"  --- ", xx_w,yy_w,zz_w
5490 c end diagnostics
5491 #endif
5492         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5493      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5494      &   + x(10)*yy*zz
5495         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5496      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5497      & + x(20)*yy*zz
5498         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5499      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5500      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5501      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5502      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5503      &  +x(40)*xx*yy*zz
5504         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5505      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5506      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5507      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5508      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5509      &  +x(60)*xx*yy*zz
5510         dsc_i   = 0.743d0+x(61)
5511         dp2_i   = 1.9d0+x(62)
5512         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5513      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5514         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5515      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5516         s1=(1+x(63))/(0.1d0 + dscp1)
5517         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5518         s2=(1+x(65))/(0.1d0 + dscp2)
5519         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5520         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5521      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5522 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5523 c     &   sumene4,
5524 c     &   dscp1,dscp2,sumene
5525 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5526         escloc = escloc + sumene
5527 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5528 c     & ,zz,xx,yy
5529 c#define DEBUG
5530 #ifdef DEBUG
5531 C
5532 C This section to check the numerical derivatives of the energy of ith side
5533 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5534 C #define DEBUG in the code to turn it on.
5535 C
5536         write (2,*) "sumene               =",sumene
5537         aincr=1.0d-7
5538         xxsave=xx
5539         xx=xx+aincr
5540         write (2,*) xx,yy,zz
5541         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5542         de_dxx_num=(sumenep-sumene)/aincr
5543         xx=xxsave
5544         write (2,*) "xx+ sumene from enesc=",sumenep
5545         yysave=yy
5546         yy=yy+aincr
5547         write (2,*) xx,yy,zz
5548         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5549         de_dyy_num=(sumenep-sumene)/aincr
5550         yy=yysave
5551         write (2,*) "yy+ sumene from enesc=",sumenep
5552         zzsave=zz
5553         zz=zz+aincr
5554         write (2,*) xx,yy,zz
5555         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5556         de_dzz_num=(sumenep-sumene)/aincr
5557         zz=zzsave
5558         write (2,*) "zz+ sumene from enesc=",sumenep
5559         costsave=cost2tab(i+1)
5560         sintsave=sint2tab(i+1)
5561         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5562         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5563         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5564         de_dt_num=(sumenep-sumene)/aincr
5565         write (2,*) " t+ sumene from enesc=",sumenep
5566         cost2tab(i+1)=costsave
5567         sint2tab(i+1)=sintsave
5568 C End of diagnostics section.
5569 #endif
5570 C
5571 C Compute the gradient of esc
5572 C
5573 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5574         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5575         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5576         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5577         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5578         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5579         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5580         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5581         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5582         pom1=(sumene3*sint2tab(i+1)+sumene1)
5583      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5584         pom2=(sumene4*cost2tab(i+1)+sumene2)
5585      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5586         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5587         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5588      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5589      &  +x(40)*yy*zz
5590         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5591         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5592      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5593      &  +x(60)*yy*zz
5594         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5595      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5596      &        +(pom1+pom2)*pom_dx
5597 #ifdef DEBUG
5598         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5599 #endif
5600 C
5601         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5602         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5603      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5604      &  +x(40)*xx*zz
5605         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5606         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5607      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5608      &  +x(59)*zz**2 +x(60)*xx*zz
5609         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5610      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5611      &        +(pom1-pom2)*pom_dy
5612 #ifdef DEBUG
5613         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5614 #endif
5615 C
5616         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5617      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5618      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5619      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5620      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5621      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5622      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5623      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5624 #ifdef DEBUG
5625         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5626 #endif
5627 C
5628         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5629      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5630      &  +pom1*pom_dt1+pom2*pom_dt2
5631 #ifdef DEBUG
5632         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5633 #endif
5634 c#undef DEBUG
5635 c
5636 C
5637        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5638        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5639        cosfac2xx=cosfac2*xx
5640        sinfac2yy=sinfac2*yy
5641        do k = 1,3
5642          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5643      &      vbld_inv(i+1)
5644          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5645      &      vbld_inv(i)
5646          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5647          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5648 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5649 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5650 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5651 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5652          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5653          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5654          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5655          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5656          dZZ_Ci1(k)=0.0d0
5657          dZZ_Ci(k)=0.0d0
5658          do j=1,3
5659            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5660      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5661            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5662      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5663          enddo
5664
5665          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5666          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5667          dZZ_XYZ(k)=vbld_inv(i+nres)*
5668      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5669 c
5670          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5671          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5672        enddo
5673
5674        do k=1,3
5675          dXX_Ctab(k,i)=dXX_Ci(k)
5676          dXX_C1tab(k,i)=dXX_Ci1(k)
5677          dYY_Ctab(k,i)=dYY_Ci(k)
5678          dYY_C1tab(k,i)=dYY_Ci1(k)
5679          dZZ_Ctab(k,i)=dZZ_Ci(k)
5680          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5681          dXX_XYZtab(k,i)=dXX_XYZ(k)
5682          dYY_XYZtab(k,i)=dYY_XYZ(k)
5683          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5684        enddo
5685
5686        do k = 1,3
5687 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5688 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5689 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5690 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5691 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5692 c     &    dt_dci(k)
5693 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5694 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5695          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5696      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5697          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5698      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5699          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5700      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5701        enddo
5702 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5703 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5704
5705 C to check gradient call subroutine check_grad
5706
5707     1 continue
5708       enddo
5709       return
5710       end
5711 c------------------------------------------------------------------------------
5712       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5713       implicit none
5714       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5715      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5716       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5717      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5718      &   + x(10)*yy*zz
5719       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5720      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5721      & + x(20)*yy*zz
5722       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5723      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5724      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5725      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5726      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5727      &  +x(40)*xx*yy*zz
5728       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5729      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5730      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5731      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5732      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5733      &  +x(60)*xx*yy*zz
5734       dsc_i   = 0.743d0+x(61)
5735       dp2_i   = 1.9d0+x(62)
5736       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5737      &          *(xx*cost2+yy*sint2))
5738       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5739      &          *(xx*cost2-yy*sint2))
5740       s1=(1+x(63))/(0.1d0 + dscp1)
5741       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5742       s2=(1+x(65))/(0.1d0 + dscp2)
5743       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5744       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5745      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5746       enesc=sumene
5747       return
5748       end
5749 #endif
5750 c------------------------------------------------------------------------------
5751       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5752 C
5753 C This procedure calculates two-body contact function g(rij) and its derivative:
5754 C
5755 C           eps0ij                                     !       x < -1
5756 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5757 C            0                                         !       x > 1
5758 C
5759 C where x=(rij-r0ij)/delta
5760 C
5761 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5762 C
5763       implicit none
5764       double precision rij,r0ij,eps0ij,fcont,fprimcont
5765       double precision x,x2,x4,delta
5766 c     delta=0.02D0*r0ij
5767 c      delta=0.2D0*r0ij
5768       x=(rij-r0ij)/delta
5769       if (x.lt.-1.0D0) then
5770         fcont=eps0ij
5771         fprimcont=0.0D0
5772       else if (x.le.1.0D0) then
5773         x2=x*x
5774         x4=x2*x2
5775         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5776         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5777       else
5778         fcont=0.0D0
5779         fprimcont=0.0D0
5780       endif
5781       return
5782       end
5783 c------------------------------------------------------------------------------
5784       subroutine splinthet(theti,delta,ss,ssder)
5785       implicit real*8 (a-h,o-z)
5786       include 'DIMENSIONS'
5787       include 'COMMON.VAR'
5788       include 'COMMON.GEO'
5789       thetup=pi-delta
5790       thetlow=delta
5791       if (theti.gt.pipol) then
5792         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5793       else
5794         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5795         ssder=-ssder
5796       endif
5797       return
5798       end
5799 c------------------------------------------------------------------------------
5800       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5801       implicit none
5802       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5803       double precision ksi,ksi2,ksi3,a1,a2,a3
5804       a1=fprim0*delta/(f1-f0)
5805       a2=3.0d0-2.0d0*a1
5806       a3=a1-2.0d0
5807       ksi=(x-x0)/delta
5808       ksi2=ksi*ksi
5809       ksi3=ksi2*ksi
5810       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5811       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5812       return
5813       end
5814 c------------------------------------------------------------------------------
5815       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5816       implicit none
5817       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5818       double precision ksi,ksi2,ksi3,a1,a2,a3
5819       ksi=(x-x0)/delta
5820       ksi2=ksi*ksi
5821       ksi3=ksi2*ksi
5822       a1=fprim0x*delta
5823       a2=3*(f1x-f0x)-2*fprim0x*delta
5824       a3=fprim0x*delta-2*(f1x-f0x)
5825       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5826       return
5827       end
5828 C-----------------------------------------------------------------------------
5829 #ifdef CRYST_TOR
5830 C-----------------------------------------------------------------------------
5831       subroutine etor(etors,edihcnstr)
5832       implicit real*8 (a-h,o-z)
5833       include 'DIMENSIONS'
5834       include 'COMMON.VAR'
5835       include 'COMMON.GEO'
5836       include 'COMMON.LOCAL'
5837       include 'COMMON.TORSION'
5838       include 'COMMON.INTERACT'
5839       include 'COMMON.DERIV'
5840       include 'COMMON.CHAIN'
5841       include 'COMMON.NAMES'
5842       include 'COMMON.IOUNITS'
5843       include 'COMMON.FFIELD'
5844       include 'COMMON.TORCNSTR'
5845       include 'COMMON.CONTROL'
5846       logical lprn
5847 C Set lprn=.true. for debugging
5848       lprn=.false.
5849 c      lprn=.true.
5850       etors=0.0D0
5851       do i=iphi_start,iphi_end
5852       etors_ii=0.0D0
5853         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5854      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5855         itori=itortyp(itype(i-2))
5856         itori1=itortyp(itype(i-1))
5857         phii=phi(i)
5858         gloci=0.0D0
5859 C Proline-Proline pair is a special case...
5860         if (itori.eq.3 .and. itori1.eq.3) then
5861           if (phii.gt.-dwapi3) then
5862             cosphi=dcos(3*phii)
5863             fac=1.0D0/(1.0D0-cosphi)
5864             etorsi=v1(1,3,3)*fac
5865             etorsi=etorsi+etorsi
5866             etors=etors+etorsi-v1(1,3,3)
5867             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5868             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5869           endif
5870           do j=1,3
5871             v1ij=v1(j+1,itori,itori1)
5872             v2ij=v2(j+1,itori,itori1)
5873             cosphi=dcos(j*phii)
5874             sinphi=dsin(j*phii)
5875             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5876             if (energy_dec) etors_ii=etors_ii+
5877      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5878             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5879           enddo
5880         else
5881           do j=1,nterm_old
5882             v1ij=v1(j,itori,itori1)
5883             v2ij=v2(j,itori,itori1)
5884             cosphi=dcos(j*phii)
5885             sinphi=dsin(j*phii)
5886             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5887             if (energy_dec) etors_ii=etors_ii+
5888      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5889             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5890           enddo
5891         endif
5892         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5893              'etor',i,etors_ii
5894         if (lprn)
5895      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5896      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5897      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5898         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5899 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5900       enddo
5901 ! 6/20/98 - dihedral angle constraints
5902       edihcnstr=0.0d0
5903       do i=1,ndih_constr
5904         itori=idih_constr(i)
5905         phii=phi(itori)
5906         difi=phii-phi0(i)
5907         if (difi.gt.drange(i)) then
5908           difi=difi-drange(i)
5909           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5910           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5911         else if (difi.lt.-drange(i)) then
5912           difi=difi+drange(i)
5913           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5914           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5915         endif
5916 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5917 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5918       enddo
5919 !      write (iout,*) 'edihcnstr',edihcnstr
5920       return
5921       end
5922 c------------------------------------------------------------------------------
5923       subroutine etor_d(etors_d)
5924       etors_d=0.0d0
5925       return
5926       end
5927 c----------------------------------------------------------------------------
5928 #else
5929       subroutine etor(etors,edihcnstr)
5930       implicit real*8 (a-h,o-z)
5931       include 'DIMENSIONS'
5932       include 'COMMON.VAR'
5933       include 'COMMON.GEO'
5934       include 'COMMON.LOCAL'
5935       include 'COMMON.TORSION'
5936       include 'COMMON.INTERACT'
5937       include 'COMMON.DERIV'
5938       include 'COMMON.CHAIN'
5939       include 'COMMON.NAMES'
5940       include 'COMMON.IOUNITS'
5941       include 'COMMON.FFIELD'
5942       include 'COMMON.TORCNSTR'
5943       include 'COMMON.CONTROL'
5944       logical lprn
5945 C Set lprn=.true. for debugging
5946       lprn=.false.
5947 c     lprn=.true.
5948       etors=0.0D0
5949       do i=iphi_start,iphi_end
5950 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5951 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5952 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5953 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5954         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5955      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5956 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5957 C For introducing the NH3+ and COO- group please check the etor_d for reference
5958 C and guidance
5959         etors_ii=0.0D0
5960          if (iabs(itype(i)).eq.20) then
5961          iblock=2
5962          else
5963          iblock=1
5964          endif
5965         itori=itortyp(itype(i-2))
5966         itori1=itortyp(itype(i-1))
5967         phii=phi(i)
5968         gloci=0.0D0
5969 C Regular cosine and sine terms
5970         do j=1,nterm(itori,itori1,iblock)
5971           v1ij=v1(j,itori,itori1,iblock)
5972           v2ij=v2(j,itori,itori1,iblock)
5973           cosphi=dcos(j*phii)
5974           sinphi=dsin(j*phii)
5975           etors=etors+v1ij*cosphi+v2ij*sinphi
5976           if (energy_dec) etors_ii=etors_ii+
5977      &                v1ij*cosphi+v2ij*sinphi
5978           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5979         enddo
5980 C Lorentz terms
5981 C                         v1
5982 C  E = SUM ----------------------------------- - v1
5983 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5984 C
5985         cosphi=dcos(0.5d0*phii)
5986         sinphi=dsin(0.5d0*phii)
5987         do j=1,nlor(itori,itori1,iblock)
5988           vl1ij=vlor1(j,itori,itori1)
5989           vl2ij=vlor2(j,itori,itori1)
5990           vl3ij=vlor3(j,itori,itori1)
5991           pom=vl2ij*cosphi+vl3ij*sinphi
5992           pom1=1.0d0/(pom*pom+1.0d0)
5993           etors=etors+vl1ij*pom1
5994           if (energy_dec) etors_ii=etors_ii+
5995      &                vl1ij*pom1
5996           pom=-pom*pom1*pom1
5997           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5998         enddo
5999 C Subtract the constant term
6000         etors=etors-v0(itori,itori1,iblock)
6001           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6002      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6003         if (lprn)
6004      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6005      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6006      &  (v1(j,itori,itori1,iblock),j=1,6),
6007      &  (v2(j,itori,itori1,iblock),j=1,6)
6008         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6009 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6010       enddo
6011 ! 6/20/98 - dihedral angle constraints
6012       edihcnstr=0.0d0
6013 c      do i=1,ndih_constr
6014       do i=idihconstr_start,idihconstr_end
6015         itori=idih_constr(i)
6016         phii=phi(itori)
6017         difi=pinorm(phii-phi0(i))
6018         if (difi.gt.drange(i)) then
6019           difi=difi-drange(i)
6020           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6021           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6022         else if (difi.lt.-drange(i)) then
6023           difi=difi+drange(i)
6024           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6025           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6026         else
6027           difi=0.0
6028         endif
6029 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6030 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6031 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6032       enddo
6033 cd       write (iout,*) 'edihcnstr',edihcnstr
6034       return
6035       end
6036 c----------------------------------------------------------------------------
6037       subroutine etor_d(etors_d)
6038 C 6/23/01 Compute double torsional energy
6039       implicit real*8 (a-h,o-z)
6040       include 'DIMENSIONS'
6041       include 'COMMON.VAR'
6042       include 'COMMON.GEO'
6043       include 'COMMON.LOCAL'
6044       include 'COMMON.TORSION'
6045       include 'COMMON.INTERACT'
6046       include 'COMMON.DERIV'
6047       include 'COMMON.CHAIN'
6048       include 'COMMON.NAMES'
6049       include 'COMMON.IOUNITS'
6050       include 'COMMON.FFIELD'
6051       include 'COMMON.TORCNSTR'
6052       logical lprn
6053 C Set lprn=.true. for debugging
6054       lprn=.false.
6055 c     lprn=.true.
6056       etors_d=0.0D0
6057 c      write(iout,*) "a tu??"
6058       do i=iphid_start,iphid_end
6059 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6060 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6061 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6062 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6063 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6064          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6065      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6066      &  (itype(i+1).eq.ntyp1)) cycle
6067 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6068         itori=itortyp(itype(i-2))
6069         itori1=itortyp(itype(i-1))
6070         itori2=itortyp(itype(i))
6071         phii=phi(i)
6072         phii1=phi(i+1)
6073         gloci1=0.0D0
6074         gloci2=0.0D0
6075         iblock=1
6076         if (iabs(itype(i+1)).eq.20) iblock=2
6077 C Iblock=2 Proline type
6078 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6079 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6080 C        if (itype(i+1).eq.ntyp1) iblock=3
6081 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6082 C IS or IS NOT need for this
6083 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6084 C        is (itype(i-3).eq.ntyp1) ntblock=2
6085 C        ntblock is N-terminal blocking group
6086
6087 C Regular cosine and sine terms
6088         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6089 C Example of changes for NH3+ blocking group
6090 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6091 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6092           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6093           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6094           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6095           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6096           cosphi1=dcos(j*phii)
6097           sinphi1=dsin(j*phii)
6098           cosphi2=dcos(j*phii1)
6099           sinphi2=dsin(j*phii1)
6100           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6101      &     v2cij*cosphi2+v2sij*sinphi2
6102           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6103           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6104         enddo
6105         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6106           do l=1,k-1
6107             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6108             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6109             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6110             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6111             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6112             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6113             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6114             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6115             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6116      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6117             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6118      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6119             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6120      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6121           enddo
6122         enddo
6123         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6124         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6125       enddo
6126       return
6127       end
6128 #endif
6129 c------------------------------------------------------------------------------
6130       subroutine eback_sc_corr(esccor)
6131 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6132 c        conformational states; temporarily implemented as differences
6133 c        between UNRES torsional potentials (dependent on three types of
6134 c        residues) and the torsional potentials dependent on all 20 types
6135 c        of residues computed from AM1  energy surfaces of terminally-blocked
6136 c        amino-acid residues.
6137       implicit real*8 (a-h,o-z)
6138       include 'DIMENSIONS'
6139       include 'COMMON.VAR'
6140       include 'COMMON.GEO'
6141       include 'COMMON.LOCAL'
6142       include 'COMMON.TORSION'
6143       include 'COMMON.SCCOR'
6144       include 'COMMON.INTERACT'
6145       include 'COMMON.DERIV'
6146       include 'COMMON.CHAIN'
6147       include 'COMMON.NAMES'
6148       include 'COMMON.IOUNITS'
6149       include 'COMMON.FFIELD'
6150       include 'COMMON.CONTROL'
6151       logical lprn
6152 C Set lprn=.true. for debugging
6153       lprn=.false.
6154 c      lprn=.true.
6155 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6156       esccor=0.0D0
6157       do i=itau_start,itau_end
6158         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6159         esccor_ii=0.0D0
6160         isccori=isccortyp(itype(i-2))
6161         isccori1=isccortyp(itype(i-1))
6162 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6163         phii=phi(i)
6164         do intertyp=1,3 !intertyp
6165 cc Added 09 May 2012 (Adasko)
6166 cc  Intertyp means interaction type of backbone mainchain correlation:
6167 c   1 = SC...Ca...Ca...Ca
6168 c   2 = Ca...Ca...Ca...SC
6169 c   3 = SC...Ca...Ca...SCi
6170         gloci=0.0D0
6171         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6172      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6173      &      (itype(i-1).eq.ntyp1)))
6174      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6175      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6176      &     .or.(itype(i).eq.ntyp1)))
6177      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6178      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6179      &      (itype(i-3).eq.ntyp1)))) cycle
6180         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6181         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6182      & cycle
6183        do j=1,nterm_sccor(isccori,isccori1)
6184           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6185           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6186           cosphi=dcos(j*tauangle(intertyp,i))
6187           sinphi=dsin(j*tauangle(intertyp,i))
6188           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6189           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6190         enddo
6191 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6192         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6193         if (lprn)
6194      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6195      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6196      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6197      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6198         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6199        enddo !intertyp
6200       enddo
6201
6202       return
6203       end
6204 c----------------------------------------------------------------------------
6205       subroutine multibody(ecorr)
6206 C This subroutine calculates multi-body contributions to energy following
6207 C the idea of Skolnick et al. If side chains I and J make a contact and
6208 C at the same time side chains I+1 and J+1 make a contact, an extra
6209 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6210       implicit real*8 (a-h,o-z)
6211       include 'DIMENSIONS'
6212       include 'COMMON.IOUNITS'
6213       include 'COMMON.DERIV'
6214       include 'COMMON.INTERACT'
6215       include 'COMMON.CONTACTS'
6216       double precision gx(3),gx1(3)
6217       logical lprn
6218
6219 C Set lprn=.true. for debugging
6220       lprn=.false.
6221
6222       if (lprn) then
6223         write (iout,'(a)') 'Contact function values:'
6224         do i=nnt,nct-2
6225           write (iout,'(i2,20(1x,i2,f10.5))')
6226      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6227         enddo
6228       endif
6229       ecorr=0.0D0
6230       do i=nnt,nct
6231         do j=1,3
6232           gradcorr(j,i)=0.0D0
6233           gradxorr(j,i)=0.0D0
6234         enddo
6235       enddo
6236       do i=nnt,nct-2
6237
6238         DO ISHIFT = 3,4
6239
6240         i1=i+ishift
6241         num_conti=num_cont(i)
6242         num_conti1=num_cont(i1)
6243         do jj=1,num_conti
6244           j=jcont(jj,i)
6245           do kk=1,num_conti1
6246             j1=jcont(kk,i1)
6247             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6248 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6249 cd   &                   ' ishift=',ishift
6250 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6251 C The system gains extra energy.
6252               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6253             endif   ! j1==j+-ishift
6254           enddo     ! kk
6255         enddo       ! jj
6256
6257         ENDDO ! ISHIFT
6258
6259       enddo         ! i
6260       return
6261       end
6262 c------------------------------------------------------------------------------
6263       double precision function esccorr(i,j,k,l,jj,kk)
6264       implicit real*8 (a-h,o-z)
6265       include 'DIMENSIONS'
6266       include 'COMMON.IOUNITS'
6267       include 'COMMON.DERIV'
6268       include 'COMMON.INTERACT'
6269       include 'COMMON.CONTACTS'
6270       double precision gx(3),gx1(3)
6271       logical lprn
6272       lprn=.false.
6273       eij=facont(jj,i)
6274       ekl=facont(kk,k)
6275 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6276 C Calculate the multi-body contribution to energy.
6277 C Calculate multi-body contributions to the gradient.
6278 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6279 cd   & k,l,(gacont(m,kk,k),m=1,3)
6280       do m=1,3
6281         gx(m) =ekl*gacont(m,jj,i)
6282         gx1(m)=eij*gacont(m,kk,k)
6283         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6284         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6285         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6286         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6287       enddo
6288       do m=i,j-1
6289         do ll=1,3
6290           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6291         enddo
6292       enddo
6293       do m=k,l-1
6294         do ll=1,3
6295           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6296         enddo
6297       enddo
6298       esccorr=-eij*ekl
6299       return
6300       end
6301 c------------------------------------------------------------------------------
6302       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6303 C This subroutine calculates multi-body contributions to hydrogen-bonding
6304       implicit real*8 (a-h,o-z)
6305       include 'DIMENSIONS'
6306       include 'COMMON.IOUNITS'
6307 #ifdef MPI
6308       include "mpif.h"
6309       parameter (max_cont=maxconts)
6310       parameter (max_dim=26)
6311       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6312       double precision zapas(max_dim,maxconts,max_fg_procs),
6313      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6314       common /przechowalnia/ zapas
6315       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6316      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6317 #endif
6318       include 'COMMON.SETUP'
6319       include 'COMMON.FFIELD'
6320       include 'COMMON.DERIV'
6321       include 'COMMON.INTERACT'
6322       include 'COMMON.CONTACTS'
6323       include 'COMMON.CONTROL'
6324       include 'COMMON.LOCAL'
6325       double precision gx(3),gx1(3),time00
6326       logical lprn,ldone
6327
6328 C Set lprn=.true. for debugging
6329       lprn=.false.
6330 #ifdef MPI
6331       n_corr=0
6332       n_corr1=0
6333       if (nfgtasks.le.1) goto 30
6334       if (lprn) then
6335         write (iout,'(a)') 'Contact function values before RECEIVE:'
6336         do i=nnt,nct-2
6337           write (iout,'(2i3,50(1x,i2,f5.2))')
6338      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6339      &    j=1,num_cont_hb(i))
6340         enddo
6341       endif
6342       call flush(iout)
6343       do i=1,ntask_cont_from
6344         ncont_recv(i)=0
6345       enddo
6346       do i=1,ntask_cont_to
6347         ncont_sent(i)=0
6348       enddo
6349 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6350 c     & ntask_cont_to
6351 C Make the list of contacts to send to send to other procesors
6352 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6353 c      call flush(iout)
6354       do i=iturn3_start,iturn3_end
6355 c        write (iout,*) "make contact list turn3",i," num_cont",
6356 c     &    num_cont_hb(i)
6357         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6358       enddo
6359       do i=iturn4_start,iturn4_end
6360 c        write (iout,*) "make contact list turn4",i," num_cont",
6361 c     &   num_cont_hb(i)
6362         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6363       enddo
6364       do ii=1,nat_sent
6365         i=iat_sent(ii)
6366 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6367 c     &    num_cont_hb(i)
6368         do j=1,num_cont_hb(i)
6369         do k=1,4
6370           jjc=jcont_hb(j,i)
6371           iproc=iint_sent_local(k,jjc,ii)
6372 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6373           if (iproc.gt.0) then
6374             ncont_sent(iproc)=ncont_sent(iproc)+1
6375             nn=ncont_sent(iproc)
6376             zapas(1,nn,iproc)=i
6377             zapas(2,nn,iproc)=jjc
6378             zapas(3,nn,iproc)=facont_hb(j,i)
6379             zapas(4,nn,iproc)=ees0p(j,i)
6380             zapas(5,nn,iproc)=ees0m(j,i)
6381             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6382             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6383             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6384             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6385             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6386             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6387             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6388             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6389             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6390             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6391             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6392             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6393             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6394             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6395             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6396             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6397             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6398             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6399             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6400             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6401             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6402           endif
6403         enddo
6404         enddo
6405       enddo
6406       if (lprn) then
6407       write (iout,*)
6408      &  "Numbers of contacts to be sent to other processors",
6409      &  (ncont_sent(i),i=1,ntask_cont_to)
6410       write (iout,*) "Contacts sent"
6411       do ii=1,ntask_cont_to
6412         nn=ncont_sent(ii)
6413         iproc=itask_cont_to(ii)
6414         write (iout,*) nn," contacts to processor",iproc,
6415      &   " of CONT_TO_COMM group"
6416         do i=1,nn
6417           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6418         enddo
6419       enddo
6420       call flush(iout)
6421       endif
6422       CorrelType=477
6423       CorrelID=fg_rank+1
6424       CorrelType1=478
6425       CorrelID1=nfgtasks+fg_rank+1
6426       ireq=0
6427 C Receive the numbers of needed contacts from other processors
6428       do ii=1,ntask_cont_from
6429         iproc=itask_cont_from(ii)
6430         ireq=ireq+1
6431         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6432      &    FG_COMM,req(ireq),IERR)
6433       enddo
6434 c      write (iout,*) "IRECV ended"
6435 c      call flush(iout)
6436 C Send the number of contacts needed by other processors
6437       do ii=1,ntask_cont_to
6438         iproc=itask_cont_to(ii)
6439         ireq=ireq+1
6440         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6441      &    FG_COMM,req(ireq),IERR)
6442       enddo
6443 c      write (iout,*) "ISEND ended"
6444 c      write (iout,*) "number of requests (nn)",ireq
6445       call flush(iout)
6446       if (ireq.gt.0)
6447      &  call MPI_Waitall(ireq,req,status_array,ierr)
6448 c      write (iout,*)
6449 c     &  "Numbers of contacts to be received from other processors",
6450 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6451 c      call flush(iout)
6452 C Receive contacts
6453       ireq=0
6454       do ii=1,ntask_cont_from
6455         iproc=itask_cont_from(ii)
6456         nn=ncont_recv(ii)
6457 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6458 c     &   " of CONT_TO_COMM group"
6459         call flush(iout)
6460         if (nn.gt.0) then
6461           ireq=ireq+1
6462           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6463      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6464 c          write (iout,*) "ireq,req",ireq,req(ireq)
6465         endif
6466       enddo
6467 C Send the contacts to processors that need them
6468       do ii=1,ntask_cont_to
6469         iproc=itask_cont_to(ii)
6470         nn=ncont_sent(ii)
6471 c        write (iout,*) nn," contacts to processor",iproc,
6472 c     &   " of CONT_TO_COMM group"
6473         if (nn.gt.0) then
6474           ireq=ireq+1
6475           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6476      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6477 c          write (iout,*) "ireq,req",ireq,req(ireq)
6478 c          do i=1,nn
6479 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6480 c          enddo
6481         endif
6482       enddo
6483 c      write (iout,*) "number of requests (contacts)",ireq
6484 c      write (iout,*) "req",(req(i),i=1,4)
6485 c      call flush(iout)
6486       if (ireq.gt.0)
6487      & call MPI_Waitall(ireq,req,status_array,ierr)
6488       do iii=1,ntask_cont_from
6489         iproc=itask_cont_from(iii)
6490         nn=ncont_recv(iii)
6491         if (lprn) then
6492         write (iout,*) "Received",nn," contacts from processor",iproc,
6493      &   " of CONT_FROM_COMM group"
6494         call flush(iout)
6495         do i=1,nn
6496           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6497         enddo
6498         call flush(iout)
6499         endif
6500         do i=1,nn
6501           ii=zapas_recv(1,i,iii)
6502 c Flag the received contacts to prevent double-counting
6503           jj=-zapas_recv(2,i,iii)
6504 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6505 c          call flush(iout)
6506           nnn=num_cont_hb(ii)+1
6507           num_cont_hb(ii)=nnn
6508           jcont_hb(nnn,ii)=jj
6509           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6510           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6511           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6512           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6513           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6514           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6515           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6516           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6517           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6518           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6519           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6520           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6521           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6522           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6523           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6524           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6525           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6526           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6527           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6528           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6529           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6530           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6531           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6532           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6533         enddo
6534       enddo
6535       call flush(iout)
6536       if (lprn) then
6537         write (iout,'(a)') 'Contact function values after receive:'
6538         do i=nnt,nct-2
6539           write (iout,'(2i3,50(1x,i3,f5.2))')
6540      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6541      &    j=1,num_cont_hb(i))
6542         enddo
6543         call flush(iout)
6544       endif
6545    30 continue
6546 #endif
6547       if (lprn) then
6548         write (iout,'(a)') 'Contact function values:'
6549         do i=nnt,nct-2
6550           write (iout,'(2i3,50(1x,i3,f5.2))')
6551      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6552      &    j=1,num_cont_hb(i))
6553         enddo
6554       endif
6555       ecorr=0.0D0
6556 C Remove the loop below after debugging !!!
6557       do i=nnt,nct
6558         do j=1,3
6559           gradcorr(j,i)=0.0D0
6560           gradxorr(j,i)=0.0D0
6561         enddo
6562       enddo
6563 C Calculate the local-electrostatic correlation terms
6564       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6565         i1=i+1
6566         num_conti=num_cont_hb(i)
6567         num_conti1=num_cont_hb(i+1)
6568         do jj=1,num_conti
6569           j=jcont_hb(jj,i)
6570           jp=iabs(j)
6571           do kk=1,num_conti1
6572             j1=jcont_hb(kk,i1)
6573             jp1=iabs(j1)
6574 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6575 c     &         ' jj=',jj,' kk=',kk
6576             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6577      &          .or. j.lt.0 .and. j1.gt.0) .and.
6578      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6579 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6580 C The system gains extra energy.
6581               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6582               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6583      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6584               n_corr=n_corr+1
6585             else if (j1.eq.j) then
6586 C Contacts I-J and I-(J+1) occur simultaneously.
6587 C The system loses extra energy.
6588 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6589             endif
6590           enddo ! kk
6591           do kk=1,num_conti
6592             j1=jcont_hb(kk,i)
6593 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6594 c    &         ' jj=',jj,' kk=',kk
6595             if (j1.eq.j+1) then
6596 C Contacts I-J and (I+1)-J occur simultaneously.
6597 C The system loses extra energy.
6598 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6599             endif ! j1==j+1
6600           enddo ! kk
6601         enddo ! jj
6602       enddo ! i
6603       return
6604       end
6605 c------------------------------------------------------------------------------
6606       subroutine add_hb_contact(ii,jj,itask)
6607       implicit real*8 (a-h,o-z)
6608       include "DIMENSIONS"
6609       include "COMMON.IOUNITS"
6610       integer max_cont
6611       integer max_dim
6612       parameter (max_cont=maxconts)
6613       parameter (max_dim=26)
6614       include "COMMON.CONTACTS"
6615       double precision zapas(max_dim,maxconts,max_fg_procs),
6616      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6617       common /przechowalnia/ zapas
6618       integer i,j,ii,jj,iproc,itask(4),nn
6619 c      write (iout,*) "itask",itask
6620       do i=1,2
6621         iproc=itask(i)
6622         if (iproc.gt.0) then
6623           do j=1,num_cont_hb(ii)
6624             jjc=jcont_hb(j,ii)
6625 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6626             if (jjc.eq.jj) then
6627               ncont_sent(iproc)=ncont_sent(iproc)+1
6628               nn=ncont_sent(iproc)
6629               zapas(1,nn,iproc)=ii
6630               zapas(2,nn,iproc)=jjc
6631               zapas(3,nn,iproc)=facont_hb(j,ii)
6632               zapas(4,nn,iproc)=ees0p(j,ii)
6633               zapas(5,nn,iproc)=ees0m(j,ii)
6634               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6635               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6636               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6637               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6638               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6639               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6640               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6641               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6642               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6643               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6644               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6645               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6646               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6647               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6648               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6649               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6650               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6651               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6652               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6653               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6654               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6655               exit
6656             endif
6657           enddo
6658         endif
6659       enddo
6660       return
6661       end
6662 c------------------------------------------------------------------------------
6663       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6664      &  n_corr1)
6665 C This subroutine calculates multi-body contributions to hydrogen-bonding
6666       implicit real*8 (a-h,o-z)
6667       include 'DIMENSIONS'
6668       include 'COMMON.IOUNITS'
6669 #ifdef MPI
6670       include "mpif.h"
6671       parameter (max_cont=maxconts)
6672       parameter (max_dim=70)
6673       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6674       double precision zapas(max_dim,maxconts,max_fg_procs),
6675      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6676       common /przechowalnia/ zapas
6677       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6678      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6679 #endif
6680       include 'COMMON.SETUP'
6681       include 'COMMON.FFIELD'
6682       include 'COMMON.DERIV'
6683       include 'COMMON.LOCAL'
6684       include 'COMMON.INTERACT'
6685       include 'COMMON.CONTACTS'
6686       include 'COMMON.CHAIN'
6687       include 'COMMON.CONTROL'
6688       double precision gx(3),gx1(3)
6689       integer num_cont_hb_old(maxres)
6690       logical lprn,ldone
6691       double precision eello4,eello5,eelo6,eello_turn6
6692       external eello4,eello5,eello6,eello_turn6
6693 C Set lprn=.true. for debugging
6694       lprn=.false.
6695       eturn6=0.0d0
6696 #ifdef MPI
6697       do i=1,nres
6698         num_cont_hb_old(i)=num_cont_hb(i)
6699       enddo
6700       n_corr=0
6701       n_corr1=0
6702       if (nfgtasks.le.1) goto 30
6703       if (lprn) then
6704         write (iout,'(a)') 'Contact function values before RECEIVE:'
6705         do i=nnt,nct-2
6706           write (iout,'(2i3,50(1x,i2,f5.2))')
6707      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6708      &    j=1,num_cont_hb(i))
6709         enddo
6710       endif
6711       call flush(iout)
6712       do i=1,ntask_cont_from
6713         ncont_recv(i)=0
6714       enddo
6715       do i=1,ntask_cont_to
6716         ncont_sent(i)=0
6717       enddo
6718 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6719 c     & ntask_cont_to
6720 C Make the list of contacts to send to send to other procesors
6721       do i=iturn3_start,iturn3_end
6722 c        write (iout,*) "make contact list turn3",i," num_cont",
6723 c     &    num_cont_hb(i)
6724         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6725       enddo
6726       do i=iturn4_start,iturn4_end
6727 c        write (iout,*) "make contact list turn4",i," num_cont",
6728 c     &   num_cont_hb(i)
6729         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6730       enddo
6731       do ii=1,nat_sent
6732         i=iat_sent(ii)
6733 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6734 c     &    num_cont_hb(i)
6735         do j=1,num_cont_hb(i)
6736         do k=1,4
6737           jjc=jcont_hb(j,i)
6738           iproc=iint_sent_local(k,jjc,ii)
6739 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6740           if (iproc.ne.0) then
6741             ncont_sent(iproc)=ncont_sent(iproc)+1
6742             nn=ncont_sent(iproc)
6743             zapas(1,nn,iproc)=i
6744             zapas(2,nn,iproc)=jjc
6745             zapas(3,nn,iproc)=d_cont(j,i)
6746             ind=3
6747             do kk=1,3
6748               ind=ind+1
6749               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6750             enddo
6751             do kk=1,2
6752               do ll=1,2
6753                 ind=ind+1
6754                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6755               enddo
6756             enddo
6757             do jj=1,5
6758               do kk=1,3
6759                 do ll=1,2
6760                   do mm=1,2
6761                     ind=ind+1
6762                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6763                   enddo
6764                 enddo
6765               enddo
6766             enddo
6767           endif
6768         enddo
6769         enddo
6770       enddo
6771       if (lprn) then
6772       write (iout,*)
6773      &  "Numbers of contacts to be sent to other processors",
6774      &  (ncont_sent(i),i=1,ntask_cont_to)
6775       write (iout,*) "Contacts sent"
6776       do ii=1,ntask_cont_to
6777         nn=ncont_sent(ii)
6778         iproc=itask_cont_to(ii)
6779         write (iout,*) nn," contacts to processor",iproc,
6780      &   " of CONT_TO_COMM group"
6781         do i=1,nn
6782           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6783         enddo
6784       enddo
6785       call flush(iout)
6786       endif
6787       CorrelType=477
6788       CorrelID=fg_rank+1
6789       CorrelType1=478
6790       CorrelID1=nfgtasks+fg_rank+1
6791       ireq=0
6792 C Receive the numbers of needed contacts from other processors
6793       do ii=1,ntask_cont_from
6794         iproc=itask_cont_from(ii)
6795         ireq=ireq+1
6796         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6797      &    FG_COMM,req(ireq),IERR)
6798       enddo
6799 c      write (iout,*) "IRECV ended"
6800 c      call flush(iout)
6801 C Send the number of contacts needed by other processors
6802       do ii=1,ntask_cont_to
6803         iproc=itask_cont_to(ii)
6804         ireq=ireq+1
6805         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6806      &    FG_COMM,req(ireq),IERR)
6807       enddo
6808 c      write (iout,*) "ISEND ended"
6809 c      write (iout,*) "number of requests (nn)",ireq
6810       call flush(iout)
6811       if (ireq.gt.0)
6812      &  call MPI_Waitall(ireq,req,status_array,ierr)
6813 c      write (iout,*)
6814 c     &  "Numbers of contacts to be received from other processors",
6815 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6816 c      call flush(iout)
6817 C Receive contacts
6818       ireq=0
6819       do ii=1,ntask_cont_from
6820         iproc=itask_cont_from(ii)
6821         nn=ncont_recv(ii)
6822 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6823 c     &   " of CONT_TO_COMM group"
6824         call flush(iout)
6825         if (nn.gt.0) then
6826           ireq=ireq+1
6827           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6828      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6829 c          write (iout,*) "ireq,req",ireq,req(ireq)
6830         endif
6831       enddo
6832 C Send the contacts to processors that need them
6833       do ii=1,ntask_cont_to
6834         iproc=itask_cont_to(ii)
6835         nn=ncont_sent(ii)
6836 c        write (iout,*) nn," contacts to processor",iproc,
6837 c     &   " of CONT_TO_COMM group"
6838         if (nn.gt.0) then
6839           ireq=ireq+1
6840           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6841      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6842 c          write (iout,*) "ireq,req",ireq,req(ireq)
6843 c          do i=1,nn
6844 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6845 c          enddo
6846         endif
6847       enddo
6848 c      write (iout,*) "number of requests (contacts)",ireq
6849 c      write (iout,*) "req",(req(i),i=1,4)
6850 c      call flush(iout)
6851       if (ireq.gt.0)
6852      & call MPI_Waitall(ireq,req,status_array,ierr)
6853       do iii=1,ntask_cont_from
6854         iproc=itask_cont_from(iii)
6855         nn=ncont_recv(iii)
6856         if (lprn) then
6857         write (iout,*) "Received",nn," contacts from processor",iproc,
6858      &   " of CONT_FROM_COMM group"
6859         call flush(iout)
6860         do i=1,nn
6861           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6862         enddo
6863         call flush(iout)
6864         endif
6865         do i=1,nn
6866           ii=zapas_recv(1,i,iii)
6867 c Flag the received contacts to prevent double-counting
6868           jj=-zapas_recv(2,i,iii)
6869 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6870 c          call flush(iout)
6871           nnn=num_cont_hb(ii)+1
6872           num_cont_hb(ii)=nnn
6873           jcont_hb(nnn,ii)=jj
6874           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6875           ind=3
6876           do kk=1,3
6877             ind=ind+1
6878             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6879           enddo
6880           do kk=1,2
6881             do ll=1,2
6882               ind=ind+1
6883               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6884             enddo
6885           enddo
6886           do jj=1,5
6887             do kk=1,3
6888               do ll=1,2
6889                 do mm=1,2
6890                   ind=ind+1
6891                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6892                 enddo
6893               enddo
6894             enddo
6895           enddo
6896         enddo
6897       enddo
6898       call flush(iout)
6899       if (lprn) then
6900         write (iout,'(a)') 'Contact function values after receive:'
6901         do i=nnt,nct-2
6902           write (iout,'(2i3,50(1x,i3,5f6.3))')
6903      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6904      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6905         enddo
6906         call flush(iout)
6907       endif
6908    30 continue
6909 #endif
6910       if (lprn) then
6911         write (iout,'(a)') 'Contact function values:'
6912         do i=nnt,nct-2
6913           write (iout,'(2i3,50(1x,i2,5f6.3))')
6914      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6915      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6916         enddo
6917       endif
6918       ecorr=0.0D0
6919       ecorr5=0.0d0
6920       ecorr6=0.0d0
6921 C Remove the loop below after debugging !!!
6922       do i=nnt,nct
6923         do j=1,3
6924           gradcorr(j,i)=0.0D0
6925           gradxorr(j,i)=0.0D0
6926         enddo
6927       enddo
6928 C Calculate the dipole-dipole interaction energies
6929       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6930       do i=iatel_s,iatel_e+1
6931         num_conti=num_cont_hb(i)
6932         do jj=1,num_conti
6933           j=jcont_hb(jj,i)
6934 #ifdef MOMENT
6935           call dipole(i,j,jj)
6936 #endif
6937         enddo
6938       enddo
6939       endif
6940 C Calculate the local-electrostatic correlation terms
6941 c                write (iout,*) "gradcorr5 in eello5 before loop"
6942 c                do iii=1,nres
6943 c                  write (iout,'(i5,3f10.5)')
6944 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6945 c                enddo
6946       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6947 c        write (iout,*) "corr loop i",i
6948         i1=i+1
6949         num_conti=num_cont_hb(i)
6950         num_conti1=num_cont_hb(i+1)
6951         do jj=1,num_conti
6952           j=jcont_hb(jj,i)
6953           jp=iabs(j)
6954           do kk=1,num_conti1
6955             j1=jcont_hb(kk,i1)
6956             jp1=iabs(j1)
6957 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6958 c     &         ' jj=',jj,' kk=',kk
6959 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6960             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6961      &          .or. j.lt.0 .and. j1.gt.0) .and.
6962      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6963 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6964 C The system gains extra energy.
6965               n_corr=n_corr+1
6966               sqd1=dsqrt(d_cont(jj,i))
6967               sqd2=dsqrt(d_cont(kk,i1))
6968               sred_geom = sqd1*sqd2
6969               IF (sred_geom.lt.cutoff_corr) THEN
6970                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6971      &            ekont,fprimcont)
6972 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6973 cd     &         ' jj=',jj,' kk=',kk
6974                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6975                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6976                 do l=1,3
6977                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6978                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6979                 enddo
6980                 n_corr1=n_corr1+1
6981 cd               write (iout,*) 'sred_geom=',sred_geom,
6982 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6983 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6984 cd               write (iout,*) "g_contij",g_contij
6985 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6986 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6987                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6988                 if (wcorr4.gt.0.0d0)
6989      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6990                   if (energy_dec.and.wcorr4.gt.0.0d0)
6991      1                 write (iout,'(a6,4i5,0pf7.3)')
6992      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6993 c                write (iout,*) "gradcorr5 before eello5"
6994 c                do iii=1,nres
6995 c                  write (iout,'(i5,3f10.5)')
6996 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6997 c                enddo
6998                 if (wcorr5.gt.0.0d0)
6999      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7000 c                write (iout,*) "gradcorr5 after eello5"
7001 c                do iii=1,nres
7002 c                  write (iout,'(i5,3f10.5)')
7003 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7004 c                enddo
7005                   if (energy_dec.and.wcorr5.gt.0.0d0)
7006      1                 write (iout,'(a6,4i5,0pf7.3)')
7007      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7008 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7009 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7010                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7011      &               .or. wturn6.eq.0.0d0))then
7012 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7013                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7014                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7015      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7016 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7017 cd     &            'ecorr6=',ecorr6
7018 cd                write (iout,'(4e15.5)') sred_geom,
7019 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7020 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7021 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7022                 else if (wturn6.gt.0.0d0
7023      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7024 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7025                   eturn6=eturn6+eello_turn6(i,jj,kk)
7026                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7027      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7028 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7029                 endif
7030               ENDIF
7031 1111          continue
7032             endif
7033           enddo ! kk
7034         enddo ! jj
7035       enddo ! i
7036       do i=1,nres
7037         num_cont_hb(i)=num_cont_hb_old(i)
7038       enddo
7039 c                write (iout,*) "gradcorr5 in eello5"
7040 c                do iii=1,nres
7041 c                  write (iout,'(i5,3f10.5)')
7042 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7043 c                enddo
7044       return
7045       end
7046 c------------------------------------------------------------------------------
7047       subroutine add_hb_contact_eello(ii,jj,itask)
7048       implicit real*8 (a-h,o-z)
7049       include "DIMENSIONS"
7050       include "COMMON.IOUNITS"
7051       integer max_cont
7052       integer max_dim
7053       parameter (max_cont=maxconts)
7054       parameter (max_dim=70)
7055       include "COMMON.CONTACTS"
7056       double precision zapas(max_dim,maxconts,max_fg_procs),
7057      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7058       common /przechowalnia/ zapas
7059       integer i,j,ii,jj,iproc,itask(4),nn
7060 c      write (iout,*) "itask",itask
7061       do i=1,2
7062         iproc=itask(i)
7063         if (iproc.gt.0) then
7064           do j=1,num_cont_hb(ii)
7065             jjc=jcont_hb(j,ii)
7066 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7067             if (jjc.eq.jj) then
7068               ncont_sent(iproc)=ncont_sent(iproc)+1
7069               nn=ncont_sent(iproc)
7070               zapas(1,nn,iproc)=ii
7071               zapas(2,nn,iproc)=jjc
7072               zapas(3,nn,iproc)=d_cont(j,ii)
7073               ind=3
7074               do kk=1,3
7075                 ind=ind+1
7076                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7077               enddo
7078               do kk=1,2
7079                 do ll=1,2
7080                   ind=ind+1
7081                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7082                 enddo
7083               enddo
7084               do jj=1,5
7085                 do kk=1,3
7086                   do ll=1,2
7087                     do mm=1,2
7088                       ind=ind+1
7089                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7090                     enddo
7091                   enddo
7092                 enddo
7093               enddo
7094               exit
7095             endif
7096           enddo
7097         endif
7098       enddo
7099       return
7100       end
7101 c------------------------------------------------------------------------------
7102       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7103       implicit real*8 (a-h,o-z)
7104       include 'DIMENSIONS'
7105       include 'COMMON.IOUNITS'
7106       include 'COMMON.DERIV'
7107       include 'COMMON.INTERACT'
7108       include 'COMMON.CONTACTS'
7109       double precision gx(3),gx1(3)
7110       logical lprn
7111       lprn=.false.
7112       eij=facont_hb(jj,i)
7113       ekl=facont_hb(kk,k)
7114       ees0pij=ees0p(jj,i)
7115       ees0pkl=ees0p(kk,k)
7116       ees0mij=ees0m(jj,i)
7117       ees0mkl=ees0m(kk,k)
7118       ekont=eij*ekl
7119       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7120 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7121 C Following 4 lines for diagnostics.
7122 cd    ees0pkl=0.0D0
7123 cd    ees0pij=1.0D0
7124 cd    ees0mkl=0.0D0
7125 cd    ees0mij=1.0D0
7126 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7127 c     & 'Contacts ',i,j,
7128 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7129 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7130 c     & 'gradcorr_long'
7131 C Calculate the multi-body contribution to energy.
7132 c      ecorr=ecorr+ekont*ees
7133 C Calculate multi-body contributions to the gradient.
7134       coeffpees0pij=coeffp*ees0pij
7135       coeffmees0mij=coeffm*ees0mij
7136       coeffpees0pkl=coeffp*ees0pkl
7137       coeffmees0mkl=coeffm*ees0mkl
7138       do ll=1,3
7139 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7140         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7141      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7142      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7143         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7144      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7145      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7146 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7147         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7148      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7149      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7150         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7151      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7152      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7153         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7154      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7155      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7156         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7157         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7158         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7159      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7160      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7161         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7162         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7163 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7164       enddo
7165 c      write (iout,*)
7166 cgrad      do m=i+1,j-1
7167 cgrad        do ll=1,3
7168 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7169 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7170 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7171 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7172 cgrad        enddo
7173 cgrad      enddo
7174 cgrad      do m=k+1,l-1
7175 cgrad        do ll=1,3
7176 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7177 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7178 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7179 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7180 cgrad        enddo
7181 cgrad      enddo
7182 c      write (iout,*) "ehbcorr",ekont*ees
7183       ehbcorr=ekont*ees
7184       return
7185       end
7186 #ifdef MOMENT
7187 C---------------------------------------------------------------------------
7188       subroutine dipole(i,j,jj)
7189       implicit real*8 (a-h,o-z)
7190       include 'DIMENSIONS'
7191       include 'COMMON.IOUNITS'
7192       include 'COMMON.CHAIN'
7193       include 'COMMON.FFIELD'
7194       include 'COMMON.DERIV'
7195       include 'COMMON.INTERACT'
7196       include 'COMMON.CONTACTS'
7197       include 'COMMON.TORSION'
7198       include 'COMMON.VAR'
7199       include 'COMMON.GEO'
7200       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7201      &  auxmat(2,2)
7202       iti1 = itortyp(itype(i+1))
7203       if (j.lt.nres-1) then
7204         itj1 = itortyp(itype(j+1))
7205       else
7206         itj1=ntortyp
7207       endif
7208       do iii=1,2
7209         dipi(iii,1)=Ub2(iii,i)
7210         dipderi(iii)=Ub2der(iii,i)
7211         dipi(iii,2)=b1(iii,iti1)
7212         dipj(iii,1)=Ub2(iii,j)
7213         dipderj(iii)=Ub2der(iii,j)
7214         dipj(iii,2)=b1(iii,itj1)
7215       enddo
7216       kkk=0
7217       do iii=1,2
7218         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7219         do jjj=1,2
7220           kkk=kkk+1
7221           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7222         enddo
7223       enddo
7224       do kkk=1,5
7225         do lll=1,3
7226           mmm=0
7227           do iii=1,2
7228             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7229      &        auxvec(1))
7230             do jjj=1,2
7231               mmm=mmm+1
7232               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7233             enddo
7234           enddo
7235         enddo
7236       enddo
7237       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7238       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7239       do iii=1,2
7240         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7241       enddo
7242       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7243       do iii=1,2
7244         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7245       enddo
7246       return
7247       end
7248 #endif
7249 C---------------------------------------------------------------------------
7250       subroutine calc_eello(i,j,k,l,jj,kk)
7251 C
7252 C This subroutine computes matrices and vectors needed to calculate
7253 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7254 C
7255       implicit real*8 (a-h,o-z)
7256       include 'DIMENSIONS'
7257       include 'COMMON.IOUNITS'
7258       include 'COMMON.CHAIN'
7259       include 'COMMON.DERIV'
7260       include 'COMMON.INTERACT'
7261       include 'COMMON.CONTACTS'
7262       include 'COMMON.TORSION'
7263       include 'COMMON.VAR'
7264       include 'COMMON.GEO'
7265       include 'COMMON.FFIELD'
7266       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7267      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7268       logical lprn
7269       common /kutas/ lprn
7270 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7271 cd     & ' jj=',jj,' kk=',kk
7272 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7273 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7274 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7275       do iii=1,2
7276         do jjj=1,2
7277           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7278           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7279         enddo
7280       enddo
7281       call transpose2(aa1(1,1),aa1t(1,1))
7282       call transpose2(aa2(1,1),aa2t(1,1))
7283       do kkk=1,5
7284         do lll=1,3
7285           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7286      &      aa1tder(1,1,lll,kkk))
7287           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7288      &      aa2tder(1,1,lll,kkk))
7289         enddo
7290       enddo
7291       if (l.eq.j+1) then
7292 C parallel orientation of the two CA-CA-CA frames.
7293         if (i.gt.1) then
7294           iti=itortyp(itype(i))
7295         else
7296           iti=ntortyp
7297         endif
7298         itk1=itortyp(itype(k+1))
7299         itj=itortyp(itype(j))
7300         if (l.lt.nres-1) then
7301           itl1=itortyp(itype(l+1))
7302         else
7303           itl1=ntortyp
7304         endif
7305 C A1 kernel(j+1) A2T
7306 cd        do iii=1,2
7307 cd          write (iout,'(3f10.5,5x,3f10.5)')
7308 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7309 cd        enddo
7310         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7311      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7312      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7313 C Following matrices are needed only for 6-th order cumulants
7314         IF (wcorr6.gt.0.0d0) THEN
7315         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7316      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7317      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7318         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7319      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7320      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7321      &   ADtEAderx(1,1,1,1,1,1))
7322         lprn=.false.
7323         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7324      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7325      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7326      &   ADtEA1derx(1,1,1,1,1,1))
7327         ENDIF
7328 C End 6-th order cumulants
7329 cd        lprn=.false.
7330 cd        if (lprn) then
7331 cd        write (2,*) 'In calc_eello6'
7332 cd        do iii=1,2
7333 cd          write (2,*) 'iii=',iii
7334 cd          do kkk=1,5
7335 cd            write (2,*) 'kkk=',kkk
7336 cd            do jjj=1,2
7337 cd              write (2,'(3(2f10.5),5x)')
7338 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7339 cd            enddo
7340 cd          enddo
7341 cd        enddo
7342 cd        endif
7343         call transpose2(EUgder(1,1,k),auxmat(1,1))
7344         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7345         call transpose2(EUg(1,1,k),auxmat(1,1))
7346         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7347         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7348         do iii=1,2
7349           do kkk=1,5
7350             do lll=1,3
7351               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7352      &          EAEAderx(1,1,lll,kkk,iii,1))
7353             enddo
7354           enddo
7355         enddo
7356 C A1T kernel(i+1) A2
7357         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7358      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7359      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7360 C Following matrices are needed only for 6-th order cumulants
7361         IF (wcorr6.gt.0.0d0) THEN
7362         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7363      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7364      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7365         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7366      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7367      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7368      &   ADtEAderx(1,1,1,1,1,2))
7369         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7370      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7371      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7372      &   ADtEA1derx(1,1,1,1,1,2))
7373         ENDIF
7374 C End 6-th order cumulants
7375         call transpose2(EUgder(1,1,l),auxmat(1,1))
7376         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7377         call transpose2(EUg(1,1,l),auxmat(1,1))
7378         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7379         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7380         do iii=1,2
7381           do kkk=1,5
7382             do lll=1,3
7383               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7384      &          EAEAderx(1,1,lll,kkk,iii,2))
7385             enddo
7386           enddo
7387         enddo
7388 C AEAb1 and AEAb2
7389 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7390 C They are needed only when the fifth- or the sixth-order cumulants are
7391 C indluded.
7392         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7393         call transpose2(AEA(1,1,1),auxmat(1,1))
7394         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7395         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7396         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7397         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7398         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7399         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7400         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7401         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7402         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7403         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7404         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7405         call transpose2(AEA(1,1,2),auxmat(1,1))
7406         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7407         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7408         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7409         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7410         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7411         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7412         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7413         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7414         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7415         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7416         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7417 C Calculate the Cartesian derivatives of the vectors.
7418         do iii=1,2
7419           do kkk=1,5
7420             do lll=1,3
7421               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7422               call matvec2(auxmat(1,1),b1(1,iti),
7423      &          AEAb1derx(1,lll,kkk,iii,1,1))
7424               call matvec2(auxmat(1,1),Ub2(1,i),
7425      &          AEAb2derx(1,lll,kkk,iii,1,1))
7426               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7427      &          AEAb1derx(1,lll,kkk,iii,2,1))
7428               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7429      &          AEAb2derx(1,lll,kkk,iii,2,1))
7430               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7431               call matvec2(auxmat(1,1),b1(1,itj),
7432      &          AEAb1derx(1,lll,kkk,iii,1,2))
7433               call matvec2(auxmat(1,1),Ub2(1,j),
7434      &          AEAb2derx(1,lll,kkk,iii,1,2))
7435               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7436      &          AEAb1derx(1,lll,kkk,iii,2,2))
7437               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7438      &          AEAb2derx(1,lll,kkk,iii,2,2))
7439             enddo
7440           enddo
7441         enddo
7442         ENDIF
7443 C End vectors
7444       else
7445 C Antiparallel orientation of the two CA-CA-CA frames.
7446         if (i.gt.1) then
7447           iti=itortyp(itype(i))
7448         else
7449           iti=ntortyp
7450         endif
7451         itk1=itortyp(itype(k+1))
7452         itl=itortyp(itype(l))
7453         itj=itortyp(itype(j))
7454         if (j.lt.nres-1) then
7455           itj1=itortyp(itype(j+1))
7456         else
7457           itj1=ntortyp
7458         endif
7459 C A2 kernel(j-1)T A1T
7460         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7461      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7462      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7463 C Following matrices are needed only for 6-th order cumulants
7464         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7465      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7466         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7467      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7468      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7469         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7470      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7471      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7472      &   ADtEAderx(1,1,1,1,1,1))
7473         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7474      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7475      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7476      &   ADtEA1derx(1,1,1,1,1,1))
7477         ENDIF
7478 C End 6-th order cumulants
7479         call transpose2(EUgder(1,1,k),auxmat(1,1))
7480         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7481         call transpose2(EUg(1,1,k),auxmat(1,1))
7482         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7483         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7484         do iii=1,2
7485           do kkk=1,5
7486             do lll=1,3
7487               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7488      &          EAEAderx(1,1,lll,kkk,iii,1))
7489             enddo
7490           enddo
7491         enddo
7492 C A2T kernel(i+1)T A1
7493         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7494      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7495      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7496 C Following matrices are needed only for 6-th order cumulants
7497         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7498      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7499         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7500      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7501      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7502         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7503      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7504      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7505      &   ADtEAderx(1,1,1,1,1,2))
7506         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7507      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7508      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7509      &   ADtEA1derx(1,1,1,1,1,2))
7510         ENDIF
7511 C End 6-th order cumulants
7512         call transpose2(EUgder(1,1,j),auxmat(1,1))
7513         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7514         call transpose2(EUg(1,1,j),auxmat(1,1))
7515         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7516         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7517         do iii=1,2
7518           do kkk=1,5
7519             do lll=1,3
7520               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7521      &          EAEAderx(1,1,lll,kkk,iii,2))
7522             enddo
7523           enddo
7524         enddo
7525 C AEAb1 and AEAb2
7526 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7527 C They are needed only when the fifth- or the sixth-order cumulants are
7528 C indluded.
7529         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7530      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7531         call transpose2(AEA(1,1,1),auxmat(1,1))
7532         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7533         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7534         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7535         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7536         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7537         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7538         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7539         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7540         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7541         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7542         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7543         call transpose2(AEA(1,1,2),auxmat(1,1))
7544         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7545         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7546         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7547         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7548         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7549         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7550         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7551         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7552         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7553         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7554         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7555 C Calculate the Cartesian derivatives of the vectors.
7556         do iii=1,2
7557           do kkk=1,5
7558             do lll=1,3
7559               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7560               call matvec2(auxmat(1,1),b1(1,iti),
7561      &          AEAb1derx(1,lll,kkk,iii,1,1))
7562               call matvec2(auxmat(1,1),Ub2(1,i),
7563      &          AEAb2derx(1,lll,kkk,iii,1,1))
7564               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7565      &          AEAb1derx(1,lll,kkk,iii,2,1))
7566               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7567      &          AEAb2derx(1,lll,kkk,iii,2,1))
7568               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7569               call matvec2(auxmat(1,1),b1(1,itl),
7570      &          AEAb1derx(1,lll,kkk,iii,1,2))
7571               call matvec2(auxmat(1,1),Ub2(1,l),
7572      &          AEAb2derx(1,lll,kkk,iii,1,2))
7573               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7574      &          AEAb1derx(1,lll,kkk,iii,2,2))
7575               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7576      &          AEAb2derx(1,lll,kkk,iii,2,2))
7577             enddo
7578           enddo
7579         enddo
7580         ENDIF
7581 C End vectors
7582       endif
7583       return
7584       end
7585 C---------------------------------------------------------------------------
7586       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7587      &  KK,KKderg,AKA,AKAderg,AKAderx)
7588       implicit none
7589       integer nderg
7590       logical transp
7591       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7592      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7593      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7594       integer iii,kkk,lll
7595       integer jjj,mmm
7596       logical lprn
7597       common /kutas/ lprn
7598       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7599       do iii=1,nderg
7600         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7601      &    AKAderg(1,1,iii))
7602       enddo
7603 cd      if (lprn) write (2,*) 'In kernel'
7604       do kkk=1,5
7605 cd        if (lprn) write (2,*) 'kkk=',kkk
7606         do lll=1,3
7607           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7608      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7609 cd          if (lprn) then
7610 cd            write (2,*) 'lll=',lll
7611 cd            write (2,*) 'iii=1'
7612 cd            do jjj=1,2
7613 cd              write (2,'(3(2f10.5),5x)')
7614 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7615 cd            enddo
7616 cd          endif
7617           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7618      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7619 cd          if (lprn) then
7620 cd            write (2,*) 'lll=',lll
7621 cd            write (2,*) 'iii=2'
7622 cd            do jjj=1,2
7623 cd              write (2,'(3(2f10.5),5x)')
7624 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7625 cd            enddo
7626 cd          endif
7627         enddo
7628       enddo
7629       return
7630       end
7631 C---------------------------------------------------------------------------
7632       double precision function eello4(i,j,k,l,jj,kk)
7633       implicit real*8 (a-h,o-z)
7634       include 'DIMENSIONS'
7635       include 'COMMON.IOUNITS'
7636       include 'COMMON.CHAIN'
7637       include 'COMMON.DERIV'
7638       include 'COMMON.INTERACT'
7639       include 'COMMON.CONTACTS'
7640       include 'COMMON.TORSION'
7641       include 'COMMON.VAR'
7642       include 'COMMON.GEO'
7643       double precision pizda(2,2),ggg1(3),ggg2(3)
7644 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7645 cd        eello4=0.0d0
7646 cd        return
7647 cd      endif
7648 cd      print *,'eello4:',i,j,k,l,jj,kk
7649 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7650 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7651 cold      eij=facont_hb(jj,i)
7652 cold      ekl=facont_hb(kk,k)
7653 cold      ekont=eij*ekl
7654       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7655 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7656       gcorr_loc(k-1)=gcorr_loc(k-1)
7657      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7658       if (l.eq.j+1) then
7659         gcorr_loc(l-1)=gcorr_loc(l-1)
7660      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7661       else
7662         gcorr_loc(j-1)=gcorr_loc(j-1)
7663      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7664       endif
7665       do iii=1,2
7666         do kkk=1,5
7667           do lll=1,3
7668             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7669      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7670 cd            derx(lll,kkk,iii)=0.0d0
7671           enddo
7672         enddo
7673       enddo
7674 cd      gcorr_loc(l-1)=0.0d0
7675 cd      gcorr_loc(j-1)=0.0d0
7676 cd      gcorr_loc(k-1)=0.0d0
7677 cd      eel4=1.0d0
7678 cd      write (iout,*)'Contacts have occurred for peptide groups',
7679 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7680 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7681       if (j.lt.nres-1) then
7682         j1=j+1
7683         j2=j-1
7684       else
7685         j1=j-1
7686         j2=j-2
7687       endif
7688       if (l.lt.nres-1) then
7689         l1=l+1
7690         l2=l-1
7691       else
7692         l1=l-1
7693         l2=l-2
7694       endif
7695       do ll=1,3
7696 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7697 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7698         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7699         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7700 cgrad        ghalf=0.5d0*ggg1(ll)
7701         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7702         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7703         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7704         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7705         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7706         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7707 cgrad        ghalf=0.5d0*ggg2(ll)
7708         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7709         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7710         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7711         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7712         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7713         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7714       enddo
7715 cgrad      do m=i+1,j-1
7716 cgrad        do ll=1,3
7717 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7718 cgrad        enddo
7719 cgrad      enddo
7720 cgrad      do m=k+1,l-1
7721 cgrad        do ll=1,3
7722 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7723 cgrad        enddo
7724 cgrad      enddo
7725 cgrad      do m=i+2,j2
7726 cgrad        do ll=1,3
7727 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7728 cgrad        enddo
7729 cgrad      enddo
7730 cgrad      do m=k+2,l2
7731 cgrad        do ll=1,3
7732 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7733 cgrad        enddo
7734 cgrad      enddo
7735 cd      do iii=1,nres-3
7736 cd        write (2,*) iii,gcorr_loc(iii)
7737 cd      enddo
7738       eello4=ekont*eel4
7739 cd      write (2,*) 'ekont',ekont
7740 cd      write (iout,*) 'eello4',ekont*eel4
7741       return
7742       end
7743 C---------------------------------------------------------------------------
7744       double precision function eello5(i,j,k,l,jj,kk)
7745       implicit real*8 (a-h,o-z)
7746       include 'DIMENSIONS'
7747       include 'COMMON.IOUNITS'
7748       include 'COMMON.CHAIN'
7749       include 'COMMON.DERIV'
7750       include 'COMMON.INTERACT'
7751       include 'COMMON.CONTACTS'
7752       include 'COMMON.TORSION'
7753       include 'COMMON.VAR'
7754       include 'COMMON.GEO'
7755       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7756       double precision ggg1(3),ggg2(3)
7757 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7758 C                                                                              C
7759 C                            Parallel chains                                   C
7760 C                                                                              C
7761 C          o             o                   o             o                   C
7762 C         /l\           / \             \   / \           / \   /              C
7763 C        /   \         /   \             \ /   \         /   \ /               C
7764 C       j| o |l1       | o |              o| o |         | o |o                C
7765 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7766 C      \i/   \         /   \ /             /   \         /   \                 C
7767 C       o    k1             o                                                  C
7768 C         (I)          (II)                (III)          (IV)                 C
7769 C                                                                              C
7770 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7771 C                                                                              C
7772 C                            Antiparallel chains                               C
7773 C                                                                              C
7774 C          o             o                   o             o                   C
7775 C         /j\           / \             \   / \           / \   /              C
7776 C        /   \         /   \             \ /   \         /   \ /               C
7777 C      j1| o |l        | o |              o| o |         | o |o                C
7778 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7779 C      \i/   \         /   \ /             /   \         /   \                 C
7780 C       o     k1            o                                                  C
7781 C         (I)          (II)                (III)          (IV)                 C
7782 C                                                                              C
7783 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7784 C                                                                              C
7785 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7786 C                                                                              C
7787 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7788 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7789 cd        eello5=0.0d0
7790 cd        return
7791 cd      endif
7792 cd      write (iout,*)
7793 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7794 cd     &   ' and',k,l
7795       itk=itortyp(itype(k))
7796       itl=itortyp(itype(l))
7797       itj=itortyp(itype(j))
7798       eello5_1=0.0d0
7799       eello5_2=0.0d0
7800       eello5_3=0.0d0
7801       eello5_4=0.0d0
7802 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7803 cd     &   eel5_3_num,eel5_4_num)
7804       do iii=1,2
7805         do kkk=1,5
7806           do lll=1,3
7807             derx(lll,kkk,iii)=0.0d0
7808           enddo
7809         enddo
7810       enddo
7811 cd      eij=facont_hb(jj,i)
7812 cd      ekl=facont_hb(kk,k)
7813 cd      ekont=eij*ekl
7814 cd      write (iout,*)'Contacts have occurred for peptide groups',
7815 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7816 cd      goto 1111
7817 C Contribution from the graph I.
7818 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7819 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7820       call transpose2(EUg(1,1,k),auxmat(1,1))
7821       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7822       vv(1)=pizda(1,1)-pizda(2,2)
7823       vv(2)=pizda(1,2)+pizda(2,1)
7824       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7825      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7826 C Explicit gradient in virtual-dihedral angles.
7827       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7828      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7829      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7830       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7831       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7832       vv(1)=pizda(1,1)-pizda(2,2)
7833       vv(2)=pizda(1,2)+pizda(2,1)
7834       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7835      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7836      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7837       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7838       vv(1)=pizda(1,1)-pizda(2,2)
7839       vv(2)=pizda(1,2)+pizda(2,1)
7840       if (l.eq.j+1) then
7841         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7842      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7843      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7844       else
7845         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7846      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7847      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7848       endif
7849 C Cartesian gradient
7850       do iii=1,2
7851         do kkk=1,5
7852           do lll=1,3
7853             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7854      &        pizda(1,1))
7855             vv(1)=pizda(1,1)-pizda(2,2)
7856             vv(2)=pizda(1,2)+pizda(2,1)
7857             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7858      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7859      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7860           enddo
7861         enddo
7862       enddo
7863 c      goto 1112
7864 c1111  continue
7865 C Contribution from graph II
7866       call transpose2(EE(1,1,itk),auxmat(1,1))
7867       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7868       vv(1)=pizda(1,1)+pizda(2,2)
7869       vv(2)=pizda(2,1)-pizda(1,2)
7870       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7871      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7872 C Explicit gradient in virtual-dihedral angles.
7873       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7874      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7875       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7876       vv(1)=pizda(1,1)+pizda(2,2)
7877       vv(2)=pizda(2,1)-pizda(1,2)
7878       if (l.eq.j+1) then
7879         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7880      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7881      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7882       else
7883         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7884      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7885      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7886       endif
7887 C Cartesian gradient
7888       do iii=1,2
7889         do kkk=1,5
7890           do lll=1,3
7891             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7892      &        pizda(1,1))
7893             vv(1)=pizda(1,1)+pizda(2,2)
7894             vv(2)=pizda(2,1)-pizda(1,2)
7895             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7896      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7897      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7898           enddo
7899         enddo
7900       enddo
7901 cd      goto 1112
7902 cd1111  continue
7903       if (l.eq.j+1) then
7904 cd        goto 1110
7905 C Parallel orientation
7906 C Contribution from graph III
7907         call transpose2(EUg(1,1,l),auxmat(1,1))
7908         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7909         vv(1)=pizda(1,1)-pizda(2,2)
7910         vv(2)=pizda(1,2)+pizda(2,1)
7911         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7912      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7913 C Explicit gradient in virtual-dihedral angles.
7914         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7915      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7916      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7917         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7918         vv(1)=pizda(1,1)-pizda(2,2)
7919         vv(2)=pizda(1,2)+pizda(2,1)
7920         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7921      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7922      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7923         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7924         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7925         vv(1)=pizda(1,1)-pizda(2,2)
7926         vv(2)=pizda(1,2)+pizda(2,1)
7927         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7928      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7929      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7930 C Cartesian gradient
7931         do iii=1,2
7932           do kkk=1,5
7933             do lll=1,3
7934               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7935      &          pizda(1,1))
7936               vv(1)=pizda(1,1)-pizda(2,2)
7937               vv(2)=pizda(1,2)+pizda(2,1)
7938               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7939      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7940      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7941             enddo
7942           enddo
7943         enddo
7944 cd        goto 1112
7945 C Contribution from graph IV
7946 cd1110    continue
7947         call transpose2(EE(1,1,itl),auxmat(1,1))
7948         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7949         vv(1)=pizda(1,1)+pizda(2,2)
7950         vv(2)=pizda(2,1)-pizda(1,2)
7951         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7952      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7953 C Explicit gradient in virtual-dihedral angles.
7954         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7955      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7956         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7957         vv(1)=pizda(1,1)+pizda(2,2)
7958         vv(2)=pizda(2,1)-pizda(1,2)
7959         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7960      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7961      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7962 C Cartesian gradient
7963         do iii=1,2
7964           do kkk=1,5
7965             do lll=1,3
7966               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7967      &          pizda(1,1))
7968               vv(1)=pizda(1,1)+pizda(2,2)
7969               vv(2)=pizda(2,1)-pizda(1,2)
7970               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7971      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7972      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7973             enddo
7974           enddo
7975         enddo
7976       else
7977 C Antiparallel orientation
7978 C Contribution from graph III
7979 c        goto 1110
7980         call transpose2(EUg(1,1,j),auxmat(1,1))
7981         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7982         vv(1)=pizda(1,1)-pizda(2,2)
7983         vv(2)=pizda(1,2)+pizda(2,1)
7984         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7985      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7986 C Explicit gradient in virtual-dihedral angles.
7987         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7988      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7989      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7990         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7991         vv(1)=pizda(1,1)-pizda(2,2)
7992         vv(2)=pizda(1,2)+pizda(2,1)
7993         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7994      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7995      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7996         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7997         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7998         vv(1)=pizda(1,1)-pizda(2,2)
7999         vv(2)=pizda(1,2)+pizda(2,1)
8000         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8001      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8002      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8003 C Cartesian gradient
8004         do iii=1,2
8005           do kkk=1,5
8006             do lll=1,3
8007               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8008      &          pizda(1,1))
8009               vv(1)=pizda(1,1)-pizda(2,2)
8010               vv(2)=pizda(1,2)+pizda(2,1)
8011               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8012      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8013      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8014             enddo
8015           enddo
8016         enddo
8017 cd        goto 1112
8018 C Contribution from graph IV
8019 1110    continue
8020         call transpose2(EE(1,1,itj),auxmat(1,1))
8021         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8022         vv(1)=pizda(1,1)+pizda(2,2)
8023         vv(2)=pizda(2,1)-pizda(1,2)
8024         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8025      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8026 C Explicit gradient in virtual-dihedral angles.
8027         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8028      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8029         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8030         vv(1)=pizda(1,1)+pizda(2,2)
8031         vv(2)=pizda(2,1)-pizda(1,2)
8032         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8033      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8034      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8035 C Cartesian gradient
8036         do iii=1,2
8037           do kkk=1,5
8038             do lll=1,3
8039               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8040      &          pizda(1,1))
8041               vv(1)=pizda(1,1)+pizda(2,2)
8042               vv(2)=pizda(2,1)-pizda(1,2)
8043               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8044      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8045      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8046             enddo
8047           enddo
8048         enddo
8049       endif
8050 1112  continue
8051       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8052 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8053 cd        write (2,*) 'ijkl',i,j,k,l
8054 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8055 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8056 cd      endif
8057 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8058 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8059 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8060 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8061       if (j.lt.nres-1) then
8062         j1=j+1
8063         j2=j-1
8064       else
8065         j1=j-1
8066         j2=j-2
8067       endif
8068       if (l.lt.nres-1) then
8069         l1=l+1
8070         l2=l-1
8071       else
8072         l1=l-1
8073         l2=l-2
8074       endif
8075 cd      eij=1.0d0
8076 cd      ekl=1.0d0
8077 cd      ekont=1.0d0
8078 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8079 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8080 C        summed up outside the subrouine as for the other subroutines
8081 C        handling long-range interactions. The old code is commented out
8082 C        with "cgrad" to keep track of changes.
8083       do ll=1,3
8084 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8085 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8086         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8087         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8088 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8089 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8090 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8091 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8092 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8093 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8094 c     &   gradcorr5ij,
8095 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8096 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8097 cgrad        ghalf=0.5d0*ggg1(ll)
8098 cd        ghalf=0.0d0
8099         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8100         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8101         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8102         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8103         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8104         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8105 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8106 cgrad        ghalf=0.5d0*ggg2(ll)
8107 cd        ghalf=0.0d0
8108         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8109         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8110         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8111         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8112         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8113         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8114       enddo
8115 cd      goto 1112
8116 cgrad      do m=i+1,j-1
8117 cgrad        do ll=1,3
8118 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8119 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8120 cgrad        enddo
8121 cgrad      enddo
8122 cgrad      do m=k+1,l-1
8123 cgrad        do ll=1,3
8124 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8125 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8126 cgrad        enddo
8127 cgrad      enddo
8128 c1112  continue
8129 cgrad      do m=i+2,j2
8130 cgrad        do ll=1,3
8131 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8132 cgrad        enddo
8133 cgrad      enddo
8134 cgrad      do m=k+2,l2
8135 cgrad        do ll=1,3
8136 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8137 cgrad        enddo
8138 cgrad      enddo
8139 cd      do iii=1,nres-3
8140 cd        write (2,*) iii,g_corr5_loc(iii)
8141 cd      enddo
8142       eello5=ekont*eel5
8143 cd      write (2,*) 'ekont',ekont
8144 cd      write (iout,*) 'eello5',ekont*eel5
8145       return
8146       end
8147 c--------------------------------------------------------------------------
8148       double precision function eello6(i,j,k,l,jj,kk)
8149       implicit real*8 (a-h,o-z)
8150       include 'DIMENSIONS'
8151       include 'COMMON.IOUNITS'
8152       include 'COMMON.CHAIN'
8153       include 'COMMON.DERIV'
8154       include 'COMMON.INTERACT'
8155       include 'COMMON.CONTACTS'
8156       include 'COMMON.TORSION'
8157       include 'COMMON.VAR'
8158       include 'COMMON.GEO'
8159       include 'COMMON.FFIELD'
8160       double precision ggg1(3),ggg2(3)
8161 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8162 cd        eello6=0.0d0
8163 cd        return
8164 cd      endif
8165 cd      write (iout,*)
8166 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8167 cd     &   ' and',k,l
8168       eello6_1=0.0d0
8169       eello6_2=0.0d0
8170       eello6_3=0.0d0
8171       eello6_4=0.0d0
8172       eello6_5=0.0d0
8173       eello6_6=0.0d0
8174 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8175 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8176       do iii=1,2
8177         do kkk=1,5
8178           do lll=1,3
8179             derx(lll,kkk,iii)=0.0d0
8180           enddo
8181         enddo
8182       enddo
8183 cd      eij=facont_hb(jj,i)
8184 cd      ekl=facont_hb(kk,k)
8185 cd      ekont=eij*ekl
8186 cd      eij=1.0d0
8187 cd      ekl=1.0d0
8188 cd      ekont=1.0d0
8189       if (l.eq.j+1) then
8190         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8191         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8192         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8193         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8194         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8195         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8196       else
8197         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8198         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8199         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8200         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8201         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8202           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8203         else
8204           eello6_5=0.0d0
8205         endif
8206         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8207       endif
8208 C If turn contributions are considered, they will be handled separately.
8209       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8210 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8211 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8212 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8213 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8214 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8215 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8216 cd      goto 1112
8217       if (j.lt.nres-1) then
8218         j1=j+1
8219         j2=j-1
8220       else
8221         j1=j-1
8222         j2=j-2
8223       endif
8224       if (l.lt.nres-1) then
8225         l1=l+1
8226         l2=l-1
8227       else
8228         l1=l-1
8229         l2=l-2
8230       endif
8231       do ll=1,3
8232 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8233 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8234 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8235 cgrad        ghalf=0.5d0*ggg1(ll)
8236 cd        ghalf=0.0d0
8237         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8238         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8239         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8240         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8241         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8242         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8243         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8244         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8245 cgrad        ghalf=0.5d0*ggg2(ll)
8246 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8247 cd        ghalf=0.0d0
8248         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8249         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8250         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8251         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8252         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8253         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8254       enddo
8255 cd      goto 1112
8256 cgrad      do m=i+1,j-1
8257 cgrad        do ll=1,3
8258 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8259 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8260 cgrad        enddo
8261 cgrad      enddo
8262 cgrad      do m=k+1,l-1
8263 cgrad        do ll=1,3
8264 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8265 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8266 cgrad        enddo
8267 cgrad      enddo
8268 cgrad1112  continue
8269 cgrad      do m=i+2,j2
8270 cgrad        do ll=1,3
8271 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8272 cgrad        enddo
8273 cgrad      enddo
8274 cgrad      do m=k+2,l2
8275 cgrad        do ll=1,3
8276 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8277 cgrad        enddo
8278 cgrad      enddo
8279 cd      do iii=1,nres-3
8280 cd        write (2,*) iii,g_corr6_loc(iii)
8281 cd      enddo
8282       eello6=ekont*eel6
8283 cd      write (2,*) 'ekont',ekont
8284 cd      write (iout,*) 'eello6',ekont*eel6
8285       return
8286       end
8287 c--------------------------------------------------------------------------
8288       double precision function eello6_graph1(i,j,k,l,imat,swap)
8289       implicit real*8 (a-h,o-z)
8290       include 'DIMENSIONS'
8291       include 'COMMON.IOUNITS'
8292       include 'COMMON.CHAIN'
8293       include 'COMMON.DERIV'
8294       include 'COMMON.INTERACT'
8295       include 'COMMON.CONTACTS'
8296       include 'COMMON.TORSION'
8297       include 'COMMON.VAR'
8298       include 'COMMON.GEO'
8299       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8300       logical swap
8301       logical lprn
8302       common /kutas/ lprn
8303 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8304 C                                                                              C
8305 C      Parallel       Antiparallel                                             C
8306 C                                                                              C
8307 C          o             o                                                     C
8308 C         /l\           /j\                                                    C
8309 C        /   \         /   \                                                   C
8310 C       /| o |         | o |\                                                  C
8311 C     \ j|/k\|  /   \  |/k\|l /                                                C
8312 C      \ /   \ /     \ /   \ /                                                 C
8313 C       o     o       o     o                                                  C
8314 C       i             i                                                        C
8315 C                                                                              C
8316 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8317       itk=itortyp(itype(k))
8318       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8319       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8320       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8321       call transpose2(EUgC(1,1,k),auxmat(1,1))
8322       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8323       vv1(1)=pizda1(1,1)-pizda1(2,2)
8324       vv1(2)=pizda1(1,2)+pizda1(2,1)
8325       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8326       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8327       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8328       s5=scalar2(vv(1),Dtobr2(1,i))
8329 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8330       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8331       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8332      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8333      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8334      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8335      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8336      & +scalar2(vv(1),Dtobr2der(1,i)))
8337       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8338       vv1(1)=pizda1(1,1)-pizda1(2,2)
8339       vv1(2)=pizda1(1,2)+pizda1(2,1)
8340       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8341       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8342       if (l.eq.j+1) then
8343         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8344      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8345      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8346      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8347      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8348       else
8349         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8350      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8351      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8352      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8353      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8354       endif
8355       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8356       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8357       vv1(1)=pizda1(1,1)-pizda1(2,2)
8358       vv1(2)=pizda1(1,2)+pizda1(2,1)
8359       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8360      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8361      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8362      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8363       do iii=1,2
8364         if (swap) then
8365           ind=3-iii
8366         else
8367           ind=iii
8368         endif
8369         do kkk=1,5
8370           do lll=1,3
8371             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8372             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8373             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8374             call transpose2(EUgC(1,1,k),auxmat(1,1))
8375             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8376      &        pizda1(1,1))
8377             vv1(1)=pizda1(1,1)-pizda1(2,2)
8378             vv1(2)=pizda1(1,2)+pizda1(2,1)
8379             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8380             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8381      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8382             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8383      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8384             s5=scalar2(vv(1),Dtobr2(1,i))
8385             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8386           enddo
8387         enddo
8388       enddo
8389       return
8390       end
8391 c----------------------------------------------------------------------------
8392       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8393       implicit real*8 (a-h,o-z)
8394       include 'DIMENSIONS'
8395       include 'COMMON.IOUNITS'
8396       include 'COMMON.CHAIN'
8397       include 'COMMON.DERIV'
8398       include 'COMMON.INTERACT'
8399       include 'COMMON.CONTACTS'
8400       include 'COMMON.TORSION'
8401       include 'COMMON.VAR'
8402       include 'COMMON.GEO'
8403       logical swap
8404       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8405      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8406       logical lprn
8407       common /kutas/ lprn
8408 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8409 C                                                                              C
8410 C      Parallel       Antiparallel                                             C
8411 C                                                                              C
8412 C          o             o                                                     C
8413 C     \   /l\           /j\   /                                                C
8414 C      \ /   \         /   \ /                                                 C
8415 C       o| o |         | o |o                                                  C
8416 C     \ j|/k\|      \  |/k\|l                                                  C
8417 C      \ /   \       \ /   \                                                   C
8418 C       o             o                                                        C
8419 C       i             i                                                        C
8420 C                                                                              C
8421 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8422 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8423 C AL 7/4/01 s1 would occur in the sixth-order moment,
8424 C           but not in a cluster cumulant
8425 #ifdef MOMENT
8426       s1=dip(1,jj,i)*dip(1,kk,k)
8427 #endif
8428       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8429       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8430       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8431       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8432       call transpose2(EUg(1,1,k),auxmat(1,1))
8433       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8434       vv(1)=pizda(1,1)-pizda(2,2)
8435       vv(2)=pizda(1,2)+pizda(2,1)
8436       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8437 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8438 #ifdef MOMENT
8439       eello6_graph2=-(s1+s2+s3+s4)
8440 #else
8441       eello6_graph2=-(s2+s3+s4)
8442 #endif
8443 c      eello6_graph2=-s3
8444 C Derivatives in gamma(i-1)
8445       if (i.gt.1) then
8446 #ifdef MOMENT
8447         s1=dipderg(1,jj,i)*dip(1,kk,k)
8448 #endif
8449         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8450         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8451         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8452         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8453 #ifdef MOMENT
8454         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8455 #else
8456         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8457 #endif
8458 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8459       endif
8460 C Derivatives in gamma(k-1)
8461 #ifdef MOMENT
8462       s1=dip(1,jj,i)*dipderg(1,kk,k)
8463 #endif
8464       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8465       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8466       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8467       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8468       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8469       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8470       vv(1)=pizda(1,1)-pizda(2,2)
8471       vv(2)=pizda(1,2)+pizda(2,1)
8472       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8473 #ifdef MOMENT
8474       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8475 #else
8476       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8477 #endif
8478 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8479 C Derivatives in gamma(j-1) or gamma(l-1)
8480       if (j.gt.1) then
8481 #ifdef MOMENT
8482         s1=dipderg(3,jj,i)*dip(1,kk,k)
8483 #endif
8484         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8485         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8486         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8487         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8488         vv(1)=pizda(1,1)-pizda(2,2)
8489         vv(2)=pizda(1,2)+pizda(2,1)
8490         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8491 #ifdef MOMENT
8492         if (swap) then
8493           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8494         else
8495           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8496         endif
8497 #endif
8498         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8499 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8500       endif
8501 C Derivatives in gamma(l-1) or gamma(j-1)
8502       if (l.gt.1) then
8503 #ifdef MOMENT
8504         s1=dip(1,jj,i)*dipderg(3,kk,k)
8505 #endif
8506         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8507         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8508         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8509         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8510         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8511         vv(1)=pizda(1,1)-pizda(2,2)
8512         vv(2)=pizda(1,2)+pizda(2,1)
8513         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8514 #ifdef MOMENT
8515         if (swap) then
8516           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8517         else
8518           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8519         endif
8520 #endif
8521         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8522 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8523       endif
8524 C Cartesian derivatives.
8525       if (lprn) then
8526         write (2,*) 'In eello6_graph2'
8527         do iii=1,2
8528           write (2,*) 'iii=',iii
8529           do kkk=1,5
8530             write (2,*) 'kkk=',kkk
8531             do jjj=1,2
8532               write (2,'(3(2f10.5),5x)')
8533      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8534             enddo
8535           enddo
8536         enddo
8537       endif
8538       do iii=1,2
8539         do kkk=1,5
8540           do lll=1,3
8541 #ifdef MOMENT
8542             if (iii.eq.1) then
8543               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8544             else
8545               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8546             endif
8547 #endif
8548             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8549      &        auxvec(1))
8550             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8551             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8552      &        auxvec(1))
8553             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8554             call transpose2(EUg(1,1,k),auxmat(1,1))
8555             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8556      &        pizda(1,1))
8557             vv(1)=pizda(1,1)-pizda(2,2)
8558             vv(2)=pizda(1,2)+pizda(2,1)
8559             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8560 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8561 #ifdef MOMENT
8562             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8563 #else
8564             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8565 #endif
8566             if (swap) then
8567               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8568             else
8569               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8570             endif
8571           enddo
8572         enddo
8573       enddo
8574       return
8575       end
8576 c----------------------------------------------------------------------------
8577       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8578       implicit real*8 (a-h,o-z)
8579       include 'DIMENSIONS'
8580       include 'COMMON.IOUNITS'
8581       include 'COMMON.CHAIN'
8582       include 'COMMON.DERIV'
8583       include 'COMMON.INTERACT'
8584       include 'COMMON.CONTACTS'
8585       include 'COMMON.TORSION'
8586       include 'COMMON.VAR'
8587       include 'COMMON.GEO'
8588       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8589       logical swap
8590 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8591 C                                                                              C
8592 C      Parallel       Antiparallel                                             C
8593 C                                                                              C
8594 C          o             o                                                     C
8595 C         /l\   /   \   /j\                                                    C
8596 C        /   \ /     \ /   \                                                   C
8597 C       /| o |o       o| o |\                                                  C
8598 C       j|/k\|  /      |/k\|l /                                                C
8599 C        /   \ /       /   \ /                                                 C
8600 C       /     o       /     o                                                  C
8601 C       i             i                                                        C
8602 C                                                                              C
8603 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8604 C
8605 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8606 C           energy moment and not to the cluster cumulant.
8607       iti=itortyp(itype(i))
8608       if (j.lt.nres-1) then
8609         itj1=itortyp(itype(j+1))
8610       else
8611         itj1=ntortyp
8612       endif
8613       itk=itortyp(itype(k))
8614       itk1=itortyp(itype(k+1))
8615       if (l.lt.nres-1) then
8616         itl1=itortyp(itype(l+1))
8617       else
8618         itl1=ntortyp
8619       endif
8620 #ifdef MOMENT
8621       s1=dip(4,jj,i)*dip(4,kk,k)
8622 #endif
8623       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8624       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8625       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8626       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8627       call transpose2(EE(1,1,itk),auxmat(1,1))
8628       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8629       vv(1)=pizda(1,1)+pizda(2,2)
8630       vv(2)=pizda(2,1)-pizda(1,2)
8631       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8632 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8633 cd     & "sum",-(s2+s3+s4)
8634 #ifdef MOMENT
8635       eello6_graph3=-(s1+s2+s3+s4)
8636 #else
8637       eello6_graph3=-(s2+s3+s4)
8638 #endif
8639 c      eello6_graph3=-s4
8640 C Derivatives in gamma(k-1)
8641       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8642       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8643       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8644       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8645 C Derivatives in gamma(l-1)
8646       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8647       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8648       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8649       vv(1)=pizda(1,1)+pizda(2,2)
8650       vv(2)=pizda(2,1)-pizda(1,2)
8651       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8652       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8653 C Cartesian derivatives.
8654       do iii=1,2
8655         do kkk=1,5
8656           do lll=1,3
8657 #ifdef MOMENT
8658             if (iii.eq.1) then
8659               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8660             else
8661               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8662             endif
8663 #endif
8664             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8665      &        auxvec(1))
8666             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8667             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8668      &        auxvec(1))
8669             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8670             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8671      &        pizda(1,1))
8672             vv(1)=pizda(1,1)+pizda(2,2)
8673             vv(2)=pizda(2,1)-pizda(1,2)
8674             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8675 #ifdef MOMENT
8676             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8677 #else
8678             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8679 #endif
8680             if (swap) then
8681               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8682             else
8683               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8684             endif
8685 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8686           enddo
8687         enddo
8688       enddo
8689       return
8690       end
8691 c----------------------------------------------------------------------------
8692       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8693       implicit real*8 (a-h,o-z)
8694       include 'DIMENSIONS'
8695       include 'COMMON.IOUNITS'
8696       include 'COMMON.CHAIN'
8697       include 'COMMON.DERIV'
8698       include 'COMMON.INTERACT'
8699       include 'COMMON.CONTACTS'
8700       include 'COMMON.TORSION'
8701       include 'COMMON.VAR'
8702       include 'COMMON.GEO'
8703       include 'COMMON.FFIELD'
8704       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8705      & auxvec1(2),auxmat1(2,2)
8706       logical swap
8707 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8708 C                                                                              C
8709 C      Parallel       Antiparallel                                             C
8710 C                                                                              C
8711 C          o             o                                                     C
8712 C         /l\   /   \   /j\                                                    C
8713 C        /   \ /     \ /   \                                                   C
8714 C       /| o |o       o| o |\                                                  C
8715 C     \ j|/k\|      \  |/k\|l                                                  C
8716 C      \ /   \       \ /   \                                                   C
8717 C       o     \       o     \                                                  C
8718 C       i             i                                                        C
8719 C                                                                              C
8720 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8721 C
8722 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8723 C           energy moment and not to the cluster cumulant.
8724 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8725       iti=itortyp(itype(i))
8726       itj=itortyp(itype(j))
8727       if (j.lt.nres-1) then
8728         itj1=itortyp(itype(j+1))
8729       else
8730         itj1=ntortyp
8731       endif
8732       itk=itortyp(itype(k))
8733       if (k.lt.nres-1) then
8734         itk1=itortyp(itype(k+1))
8735       else
8736         itk1=ntortyp
8737       endif
8738       itl=itortyp(itype(l))
8739       if (l.lt.nres-1) then
8740         itl1=itortyp(itype(l+1))
8741       else
8742         itl1=ntortyp
8743       endif
8744 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8745 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8746 cd     & ' itl',itl,' itl1',itl1
8747 #ifdef MOMENT
8748       if (imat.eq.1) then
8749         s1=dip(3,jj,i)*dip(3,kk,k)
8750       else
8751         s1=dip(2,jj,j)*dip(2,kk,l)
8752       endif
8753 #endif
8754       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8755       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8756       if (j.eq.l+1) then
8757         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8758         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8759       else
8760         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8761         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8762       endif
8763       call transpose2(EUg(1,1,k),auxmat(1,1))
8764       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8765       vv(1)=pizda(1,1)-pizda(2,2)
8766       vv(2)=pizda(2,1)+pizda(1,2)
8767       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8768 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8769 #ifdef MOMENT
8770       eello6_graph4=-(s1+s2+s3+s4)
8771 #else
8772       eello6_graph4=-(s2+s3+s4)
8773 #endif
8774 C Derivatives in gamma(i-1)
8775       if (i.gt.1) then
8776 #ifdef MOMENT
8777         if (imat.eq.1) then
8778           s1=dipderg(2,jj,i)*dip(3,kk,k)
8779         else
8780           s1=dipderg(4,jj,j)*dip(2,kk,l)
8781         endif
8782 #endif
8783         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8784         if (j.eq.l+1) then
8785           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8786           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8787         else
8788           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8789           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8790         endif
8791         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8792         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8793 cd          write (2,*) 'turn6 derivatives'
8794 #ifdef MOMENT
8795           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8796 #else
8797           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8798 #endif
8799         else
8800 #ifdef MOMENT
8801           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8802 #else
8803           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8804 #endif
8805         endif
8806       endif
8807 C Derivatives in gamma(k-1)
8808 #ifdef MOMENT
8809       if (imat.eq.1) then
8810         s1=dip(3,jj,i)*dipderg(2,kk,k)
8811       else
8812         s1=dip(2,jj,j)*dipderg(4,kk,l)
8813       endif
8814 #endif
8815       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8816       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8817       if (j.eq.l+1) then
8818         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8819         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8820       else
8821         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8822         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8823       endif
8824       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8825       call matmat2(AECA(1,1,imat),auxmat1(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 #ifdef MOMENT
8831         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8832 #else
8833         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8834 #endif
8835       else
8836 #ifdef MOMENT
8837         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8838 #else
8839         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8840 #endif
8841       endif
8842 C Derivatives in gamma(j-1) or gamma(l-1)
8843       if (l.eq.j+1 .and. l.gt.1) then
8844         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8845         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8846         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8847         vv(1)=pizda(1,1)-pizda(2,2)
8848         vv(2)=pizda(2,1)+pizda(1,2)
8849         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8850         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8851       else if (j.gt.1) then
8852         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8853         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8854         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8855         vv(1)=pizda(1,1)-pizda(2,2)
8856         vv(2)=pizda(2,1)+pizda(1,2)
8857         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8858         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8859           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8860         else
8861           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8862         endif
8863       endif
8864 C Cartesian derivatives.
8865       do iii=1,2
8866         do kkk=1,5
8867           do lll=1,3
8868 #ifdef MOMENT
8869             if (iii.eq.1) then
8870               if (imat.eq.1) then
8871                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8872               else
8873                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8874               endif
8875             else
8876               if (imat.eq.1) then
8877                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8878               else
8879                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8880               endif
8881             endif
8882 #endif
8883             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8884      &        auxvec(1))
8885             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8886             if (j.eq.l+1) then
8887               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8888      &          b1(1,itj1),auxvec(1))
8889               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8890             else
8891               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8892      &          b1(1,itl1),auxvec(1))
8893               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8894             endif
8895             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8896      &        pizda(1,1))
8897             vv(1)=pizda(1,1)-pizda(2,2)
8898             vv(2)=pizda(2,1)+pizda(1,2)
8899             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8900             if (swap) then
8901               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8902 #ifdef MOMENT
8903                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8904      &             -(s1+s2+s4)
8905 #else
8906                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8907      &             -(s2+s4)
8908 #endif
8909                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8910               else
8911 #ifdef MOMENT
8912                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8913 #else
8914                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8915 #endif
8916                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8917               endif
8918             else
8919 #ifdef MOMENT
8920               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8921 #else
8922               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8923 #endif
8924               if (l.eq.j+1) then
8925                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8926               else
8927                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8928               endif
8929             endif
8930           enddo
8931         enddo
8932       enddo
8933       return
8934       end
8935 c----------------------------------------------------------------------------
8936       double precision function eello_turn6(i,jj,kk)
8937       implicit real*8 (a-h,o-z)
8938       include 'DIMENSIONS'
8939       include 'COMMON.IOUNITS'
8940       include 'COMMON.CHAIN'
8941       include 'COMMON.DERIV'
8942       include 'COMMON.INTERACT'
8943       include 'COMMON.CONTACTS'
8944       include 'COMMON.TORSION'
8945       include 'COMMON.VAR'
8946       include 'COMMON.GEO'
8947       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8948      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8949      &  ggg1(3),ggg2(3)
8950       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8951      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8952 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8953 C           the respective energy moment and not to the cluster cumulant.
8954       s1=0.0d0
8955       s8=0.0d0
8956       s13=0.0d0
8957 c
8958       eello_turn6=0.0d0
8959       j=i+4
8960       k=i+1
8961       l=i+3
8962       iti=itortyp(itype(i))
8963       itk=itortyp(itype(k))
8964       itk1=itortyp(itype(k+1))
8965       itl=itortyp(itype(l))
8966       itj=itortyp(itype(j))
8967 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8968 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8969 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8970 cd        eello6=0.0d0
8971 cd        return
8972 cd      endif
8973 cd      write (iout,*)
8974 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8975 cd     &   ' and',k,l
8976 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8977       do iii=1,2
8978         do kkk=1,5
8979           do lll=1,3
8980             derx_turn(lll,kkk,iii)=0.0d0
8981           enddo
8982         enddo
8983       enddo
8984 cd      eij=1.0d0
8985 cd      ekl=1.0d0
8986 cd      ekont=1.0d0
8987       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8988 cd      eello6_5=0.0d0
8989 cd      write (2,*) 'eello6_5',eello6_5
8990 #ifdef MOMENT
8991       call transpose2(AEA(1,1,1),auxmat(1,1))
8992       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8993       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8994       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8995 #endif
8996       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8997       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8998       s2 = scalar2(b1(1,itk),vtemp1(1))
8999 #ifdef MOMENT
9000       call transpose2(AEA(1,1,2),atemp(1,1))
9001       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9002       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9003       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9004 #endif
9005       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9006       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9007       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9008 #ifdef MOMENT
9009       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9010       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9011       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9012       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9013       ss13 = scalar2(b1(1,itk),vtemp4(1))
9014       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9015 #endif
9016 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9017 c      s1=0.0d0
9018 c      s2=0.0d0
9019 c      s8=0.0d0
9020 c      s12=0.0d0
9021 c      s13=0.0d0
9022       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9023 C Derivatives in gamma(i+2)
9024       s1d =0.0d0
9025       s8d =0.0d0
9026 #ifdef MOMENT
9027       call transpose2(AEA(1,1,1),auxmatd(1,1))
9028       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9029       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9030       call transpose2(AEAderg(1,1,2),atempd(1,1))
9031       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9032       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9033 #endif
9034       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9035       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9036       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9037 c      s1d=0.0d0
9038 c      s2d=0.0d0
9039 c      s8d=0.0d0
9040 c      s12d=0.0d0
9041 c      s13d=0.0d0
9042       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9043 C Derivatives in gamma(i+3)
9044 #ifdef MOMENT
9045       call transpose2(AEA(1,1,1),auxmatd(1,1))
9046       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9047       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9048       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9049 #endif
9050       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9051       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9052       s2d = scalar2(b1(1,itk),vtemp1d(1))
9053 #ifdef MOMENT
9054       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9055       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9056 #endif
9057       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9058 #ifdef MOMENT
9059       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9060       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9061       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9062 #endif
9063 c      s1d=0.0d0
9064 c      s2d=0.0d0
9065 c      s8d=0.0d0
9066 c      s12d=0.0d0
9067 c      s13d=0.0d0
9068 #ifdef MOMENT
9069       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9070      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9071 #else
9072       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9073      &               -0.5d0*ekont*(s2d+s12d)
9074 #endif
9075 C Derivatives in gamma(i+4)
9076       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9077       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9078       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9079 #ifdef MOMENT
9080       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9081       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9082       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9083 #endif
9084 c      s1d=0.0d0
9085 c      s2d=0.0d0
9086 c      s8d=0.0d0
9087 C      s12d=0.0d0
9088 c      s13d=0.0d0
9089 #ifdef MOMENT
9090       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9091 #else
9092       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9093 #endif
9094 C Derivatives in gamma(i+5)
9095 #ifdef MOMENT
9096       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9097       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9098       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9099 #endif
9100       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9101       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9102       s2d = scalar2(b1(1,itk),vtemp1d(1))
9103 #ifdef MOMENT
9104       call transpose2(AEA(1,1,2),atempd(1,1))
9105       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9106       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9107 #endif
9108       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9109       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9110 #ifdef MOMENT
9111       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9112       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9113       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9114 #endif
9115 c      s1d=0.0d0
9116 c      s2d=0.0d0
9117 c      s8d=0.0d0
9118 c      s12d=0.0d0
9119 c      s13d=0.0d0
9120 #ifdef MOMENT
9121       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9122      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9123 #else
9124       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9125      &               -0.5d0*ekont*(s2d+s12d)
9126 #endif
9127 C Cartesian derivatives
9128       do iii=1,2
9129         do kkk=1,5
9130           do lll=1,3
9131 #ifdef MOMENT
9132             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9133             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9134             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9135 #endif
9136             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9137             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9138      &          vtemp1d(1))
9139             s2d = scalar2(b1(1,itk),vtemp1d(1))
9140 #ifdef MOMENT
9141             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9142             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9143             s8d = -(atempd(1,1)+atempd(2,2))*
9144      &           scalar2(cc(1,1,itl),vtemp2(1))
9145 #endif
9146             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9147      &           auxmatd(1,1))
9148             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9149             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9150 c      s1d=0.0d0
9151 c      s2d=0.0d0
9152 c      s8d=0.0d0
9153 c      s12d=0.0d0
9154 c      s13d=0.0d0
9155 #ifdef MOMENT
9156             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9157      &        - 0.5d0*(s1d+s2d)
9158 #else
9159             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9160      &        - 0.5d0*s2d
9161 #endif
9162 #ifdef MOMENT
9163             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9164      &        - 0.5d0*(s8d+s12d)
9165 #else
9166             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9167      &        - 0.5d0*s12d
9168 #endif
9169           enddo
9170         enddo
9171       enddo
9172 #ifdef MOMENT
9173       do kkk=1,5
9174         do lll=1,3
9175           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9176      &      achuj_tempd(1,1))
9177           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9178           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9179           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9180           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9181           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9182      &      vtemp4d(1))
9183           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9184           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9185           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9186         enddo
9187       enddo
9188 #endif
9189 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9190 cd     &  16*eel_turn6_num
9191 cd      goto 1112
9192       if (j.lt.nres-1) then
9193         j1=j+1
9194         j2=j-1
9195       else
9196         j1=j-1
9197         j2=j-2
9198       endif
9199       if (l.lt.nres-1) then
9200         l1=l+1
9201         l2=l-1
9202       else
9203         l1=l-1
9204         l2=l-2
9205       endif
9206       do ll=1,3
9207 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9208 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9209 cgrad        ghalf=0.5d0*ggg1(ll)
9210 cd        ghalf=0.0d0
9211         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9212         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9213         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9214      &    +ekont*derx_turn(ll,2,1)
9215         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9216         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9217      &    +ekont*derx_turn(ll,4,1)
9218         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9219         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9220         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9221 cgrad        ghalf=0.5d0*ggg2(ll)
9222 cd        ghalf=0.0d0
9223         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9224      &    +ekont*derx_turn(ll,2,2)
9225         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9226         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9227      &    +ekont*derx_turn(ll,4,2)
9228         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9229         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9230         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9231       enddo
9232 cd      goto 1112
9233 cgrad      do m=i+1,j-1
9234 cgrad        do ll=1,3
9235 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9236 cgrad        enddo
9237 cgrad      enddo
9238 cgrad      do m=k+1,l-1
9239 cgrad        do ll=1,3
9240 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9241 cgrad        enddo
9242 cgrad      enddo
9243 cgrad1112  continue
9244 cgrad      do m=i+2,j2
9245 cgrad        do ll=1,3
9246 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9247 cgrad        enddo
9248 cgrad      enddo
9249 cgrad      do m=k+2,l2
9250 cgrad        do ll=1,3
9251 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9252 cgrad        enddo
9253 cgrad      enddo
9254 cd      do iii=1,nres-3
9255 cd        write (2,*) iii,g_corr6_loc(iii)
9256 cd      enddo
9257       eello_turn6=ekont*eel_turn6
9258 cd      write (2,*) 'ekont',ekont
9259 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9260       return
9261       end
9262
9263 C-----------------------------------------------------------------------------
9264       double precision function scalar(u,v)
9265 !DIR$ INLINEALWAYS scalar
9266 #ifndef OSF
9267 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9268 #endif
9269       implicit none
9270       double precision u(3),v(3)
9271 cd      double precision sc
9272 cd      integer i
9273 cd      sc=0.0d0
9274 cd      do i=1,3
9275 cd        sc=sc+u(i)*v(i)
9276 cd      enddo
9277 cd      scalar=sc
9278
9279       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9280       return
9281       end
9282 crc-------------------------------------------------
9283       SUBROUTINE MATVEC2(A1,V1,V2)
9284 !DIR$ INLINEALWAYS MATVEC2
9285 #ifndef OSF
9286 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9287 #endif
9288       implicit real*8 (a-h,o-z)
9289       include 'DIMENSIONS'
9290       DIMENSION A1(2,2),V1(2),V2(2)
9291 c      DO 1 I=1,2
9292 c        VI=0.0
9293 c        DO 3 K=1,2
9294 c    3     VI=VI+A1(I,K)*V1(K)
9295 c        Vaux(I)=VI
9296 c    1 CONTINUE
9297
9298       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9299       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9300
9301       v2(1)=vaux1
9302       v2(2)=vaux2
9303       END
9304 C---------------------------------------
9305       SUBROUTINE MATMAT2(A1,A2,A3)
9306 #ifndef OSF
9307 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9308 #endif
9309       implicit real*8 (a-h,o-z)
9310       include 'DIMENSIONS'
9311       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9312 c      DIMENSION AI3(2,2)
9313 c        DO  J=1,2
9314 c          A3IJ=0.0
9315 c          DO K=1,2
9316 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9317 c          enddo
9318 c          A3(I,J)=A3IJ
9319 c       enddo
9320 c      enddo
9321
9322       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9323       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9324       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9325       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9326
9327       A3(1,1)=AI3_11
9328       A3(2,1)=AI3_21
9329       A3(1,2)=AI3_12
9330       A3(2,2)=AI3_22
9331       END
9332
9333 c-------------------------------------------------------------------------
9334       double precision function scalar2(u,v)
9335 !DIR$ INLINEALWAYS scalar2
9336       implicit none
9337       double precision u(2),v(2)
9338       double precision sc
9339       integer i
9340       scalar2=u(1)*v(1)+u(2)*v(2)
9341       return
9342       end
9343
9344 C-----------------------------------------------------------------------------
9345
9346       subroutine transpose2(a,at)
9347 !DIR$ INLINEALWAYS transpose2
9348 #ifndef OSF
9349 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9350 #endif
9351       implicit none
9352       double precision a(2,2),at(2,2)
9353       at(1,1)=a(1,1)
9354       at(1,2)=a(2,1)
9355       at(2,1)=a(1,2)
9356       at(2,2)=a(2,2)
9357       return
9358       end
9359 c--------------------------------------------------------------------------
9360       subroutine transpose(n,a,at)
9361       implicit none
9362       integer n,i,j
9363       double precision a(n,n),at(n,n)
9364       do i=1,n
9365         do j=1,n
9366           at(j,i)=a(i,j)
9367         enddo
9368       enddo
9369       return
9370       end
9371 C---------------------------------------------------------------------------
9372       subroutine prodmat3(a1,a2,kk,transp,prod)
9373 !DIR$ INLINEALWAYS prodmat3
9374 #ifndef OSF
9375 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9376 #endif
9377       implicit none
9378       integer i,j
9379       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9380       logical transp
9381 crc      double precision auxmat(2,2),prod_(2,2)
9382
9383       if (transp) then
9384 crc        call transpose2(kk(1,1),auxmat(1,1))
9385 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9386 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9387
9388            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9389      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9390            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9391      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9392            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9393      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9394            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9395      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9396
9397       else
9398 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9399 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9400
9401            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9402      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9403            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9404      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9405            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9406      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9407            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9408      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9409
9410       endif
9411 c      call transpose2(a2(1,1),a2t(1,1))
9412
9413 crc      print *,transp
9414 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9415 crc      print *,((prod(i,j),i=1,2),j=1,2)
9416
9417       return
9418       end
9419