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