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 c#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 c#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 c#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 c#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 c  134   continue
1440 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1441 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1442 C Condition for being inside the proper box
1443 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1444 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1445 c        go to 134
1446 c        endif
1447 c  135   continue
1448 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1449 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1450 C Condition for being inside the proper box
1451 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1452 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1453 c        go to 135
1454 c        endif
1455 c  136   continue
1456 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1457 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1458 C Condition for being inside the proper box
1459 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1460 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1461 c        go to 136
1462 c        endif
1463           xi=mod(xi,boxxsize)
1464           if (xi.lt.0) xi=xi+boxxsize
1465           yi=mod(yi,boxysize)
1466           if (yi.lt.0) yi=yi+boxysize
1467           zi=mod(zi,boxzsize)
1468           if (zi.lt.0) zi=zi+boxzsize
1469           xi=xi+xshift*boxxsize
1470           yi=yi+yshift*boxysize
1471           zi=zi+zshift*boxzsize
1472
1473         dxi=dc_norm(1,nres+i)
1474         dyi=dc_norm(2,nres+i)
1475         dzi=dc_norm(3,nres+i)
1476 c        dsci_inv=dsc_inv(itypi)
1477         dsci_inv=vbld_inv(i+nres)
1478 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1479 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1480 C
1481 C Calculate SC interaction energy.
1482 C
1483         do iint=1,nint_gr(i)
1484           do j=istart(i,iint),iend(i,iint)
1485             ind=ind+1
1486             itypj=iabs(itype(j))
1487             if (itypj.eq.ntyp1) cycle
1488 c            dscj_inv=dsc_inv(itypj)
1489             dscj_inv=vbld_inv(j+nres)
1490 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1491 c     &       1.0d0/vbld(j+nres)
1492 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1493             sig0ij=sigma(itypi,itypj)
1494             chi1=chi(itypi,itypj)
1495             chi2=chi(itypj,itypi)
1496             chi12=chi1*chi2
1497             chip1=chip(itypi)
1498             chip2=chip(itypj)
1499             chip12=chip1*chip2
1500             alf1=alp(itypi)
1501             alf2=alp(itypj)
1502             alf12=0.5D0*(alf1+alf2)
1503 C For diagnostics only!!!
1504 c           chi1=0.0D0
1505 c           chi2=0.0D0
1506 c           chi12=0.0D0
1507 c           chip1=0.0D0
1508 c           chip2=0.0D0
1509 c           chip12=0.0D0
1510 c           alf1=0.0D0
1511 c           alf2=0.0D0
1512 c           alf12=0.0D0
1513             xj=c(1,nres+j)
1514             yj=c(2,nres+j)
1515             zj=c(3,nres+j)
1516 C Return atom J into box the original box
1517 c  137   continue
1518 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1519 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1520 C Condition for being inside the proper box
1521 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1522 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1523 c        go to 137
1524 c        endif
1525 c  138   continue
1526 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1527 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1528 C Condition for being inside the proper box
1529 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1530 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1531 c        go to 138
1532 c        endif
1533 c  139   continue
1534 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1535 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1536 C Condition for being inside the proper box
1537 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1538 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1539 c        go to 139
1540 c        endif
1541           xj=mod(xj,boxxsize)
1542           if (xj.lt.0) xj=xj+boxxsize
1543           yj=mod(yj,boxysize)
1544           if (yj.lt.0) yj=yj+boxysize
1545           zj=mod(zj,boxzsize)
1546           if (zj.lt.0) zj=zj+boxzsize
1547             dxj=dc_norm(1,nres+j)
1548             dyj=dc_norm(2,nres+j)
1549             dzj=dc_norm(3,nres+j)
1550             xj=xj-xi
1551             yj=yj-yi
1552             zj=zj-zi
1553 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1554 c            write (iout,*) "j",j," dc_norm",
1555 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1556             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1557             rij=dsqrt(rrij)
1558             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1559             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1560
1561 c            write (iout,'(a7,4f8.3)')
1562 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1563             if (sss.gt.0.0d0) then
1564 C Calculate angle-dependent terms of energy and contributions to their
1565 C derivatives.
1566             call sc_angular
1567             sigsq=1.0D0/sigsq
1568             sig=sig0ij*dsqrt(sigsq)
1569             rij_shift=1.0D0/rij-sig+sig0ij
1570 c for diagnostics; uncomment
1571 c            rij_shift=1.2*sig0ij
1572 C I hate to put IF's in the loops, but here don't have another choice!!!!
1573             if (rij_shift.le.0.0D0) then
1574               evdw=1.0D20
1575 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1576 cd     &        restyp(itypi),i,restyp(itypj),j,
1577 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1578               return
1579             endif
1580             sigder=-sig*sigsq
1581 c---------------------------------------------------------------
1582             rij_shift=1.0D0/rij_shift
1583             fac=rij_shift**expon
1584             e1=fac*fac*aa(itypi,itypj)
1585             e2=fac*bb(itypi,itypj)
1586             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1587             eps2der=evdwij*eps3rt
1588             eps3der=evdwij*eps2rt
1589 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1590 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1591             evdwij=evdwij*eps2rt*eps3rt
1592             evdw=evdw+evdwij*sss
1593             if (lprn) then
1594             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1595             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1596             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1597      &        restyp(itypi),i,restyp(itypj),j,
1598      &        epsi,sigm,chi1,chi2,chip1,chip2,
1599      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1600      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1601      &        evdwij
1602             endif
1603
1604             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1605      &                        'evdw',i,j,evdwij
1606
1607 C Calculate gradient components.
1608             e1=e1*eps1*eps2rt**2*eps3rt**2
1609             fac=-expon*(e1+evdwij)*rij_shift
1610             sigder=fac*sigder
1611             fac=rij*fac
1612 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1613 c     &      evdwij,fac,sigma(itypi,itypj),expon
1614             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1615 c            fac=0.0d0
1616 C Calculate the radial part of the gradient
1617             gg(1)=xj*fac
1618             gg(2)=yj*fac
1619             gg(3)=zj*fac
1620 C Calculate angular part of the gradient.
1621             call sc_grad
1622             endif
1623           enddo      ! j
1624         enddo        ! iint
1625       enddo          ! i
1626       enddo          ! zshift
1627       enddo          ! yshift
1628       enddo          ! xshift
1629 c      write (iout,*) "Number of loop steps in EGB:",ind
1630 cccc      energy_dec=.false.
1631       return
1632       end
1633 C-----------------------------------------------------------------------------
1634       subroutine egbv(evdw)
1635 C
1636 C This subroutine calculates the interaction energy of nonbonded side chains
1637 C assuming the Gay-Berne-Vorobjev potential of interaction.
1638 C
1639       implicit real*8 (a-h,o-z)
1640       include 'DIMENSIONS'
1641       include 'COMMON.GEO'
1642       include 'COMMON.VAR'
1643       include 'COMMON.LOCAL'
1644       include 'COMMON.CHAIN'
1645       include 'COMMON.DERIV'
1646       include 'COMMON.NAMES'
1647       include 'COMMON.INTERACT'
1648       include 'COMMON.IOUNITS'
1649       include 'COMMON.CALC'
1650       common /srutu/ icall
1651       logical lprn
1652       evdw=0.0D0
1653 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1654       evdw=0.0D0
1655       lprn=.false.
1656 c     if (icall.eq.0) lprn=.true.
1657       ind=0
1658       do i=iatsc_s,iatsc_e
1659         itypi=iabs(itype(i))
1660         if (itypi.eq.ntyp1) cycle
1661         itypi1=iabs(itype(i+1))
1662         xi=c(1,nres+i)
1663         yi=c(2,nres+i)
1664         zi=c(3,nres+i)
1665         dxi=dc_norm(1,nres+i)
1666         dyi=dc_norm(2,nres+i)
1667         dzi=dc_norm(3,nres+i)
1668 c        dsci_inv=dsc_inv(itypi)
1669         dsci_inv=vbld_inv(i+nres)
1670 C
1671 C Calculate SC interaction energy.
1672 C
1673         do iint=1,nint_gr(i)
1674           do j=istart(i,iint),iend(i,iint)
1675             ind=ind+1
1676             itypj=iabs(itype(j))
1677             if (itypj.eq.ntyp1) cycle
1678 c            dscj_inv=dsc_inv(itypj)
1679             dscj_inv=vbld_inv(j+nres)
1680             sig0ij=sigma(itypi,itypj)
1681             r0ij=r0(itypi,itypj)
1682             chi1=chi(itypi,itypj)
1683             chi2=chi(itypj,itypi)
1684             chi12=chi1*chi2
1685             chip1=chip(itypi)
1686             chip2=chip(itypj)
1687             chip12=chip1*chip2
1688             alf1=alp(itypi)
1689             alf2=alp(itypj)
1690             alf12=0.5D0*(alf1+alf2)
1691 C For diagnostics only!!!
1692 c           chi1=0.0D0
1693 c           chi2=0.0D0
1694 c           chi12=0.0D0
1695 c           chip1=0.0D0
1696 c           chip2=0.0D0
1697 c           chip12=0.0D0
1698 c           alf1=0.0D0
1699 c           alf2=0.0D0
1700 c           alf12=0.0D0
1701             xj=c(1,nres+j)-xi
1702             yj=c(2,nres+j)-yi
1703             zj=c(3,nres+j)-zi
1704             dxj=dc_norm(1,nres+j)
1705             dyj=dc_norm(2,nres+j)
1706             dzj=dc_norm(3,nres+j)
1707             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1708             rij=dsqrt(rrij)
1709 C Calculate angle-dependent terms of energy and contributions to their
1710 C derivatives.
1711             call sc_angular
1712             sigsq=1.0D0/sigsq
1713             sig=sig0ij*dsqrt(sigsq)
1714             rij_shift=1.0D0/rij-sig+r0ij
1715 C I hate to put IF's in the loops, but here don't have another choice!!!!
1716             if (rij_shift.le.0.0D0) then
1717               evdw=1.0D20
1718               return
1719             endif
1720             sigder=-sig*sigsq
1721 c---------------------------------------------------------------
1722             rij_shift=1.0D0/rij_shift
1723             fac=rij_shift**expon
1724             e1=fac*fac*aa(itypi,itypj)
1725             e2=fac*bb(itypi,itypj)
1726             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1727             eps2der=evdwij*eps3rt
1728             eps3der=evdwij*eps2rt
1729             fac_augm=rrij**expon
1730             e_augm=augm(itypi,itypj)*fac_augm
1731             evdwij=evdwij*eps2rt*eps3rt
1732             evdw=evdw+evdwij+e_augm
1733             if (lprn) then
1734             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1735             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1736             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1737      &        restyp(itypi),i,restyp(itypj),j,
1738      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1739      &        chi1,chi2,chip1,chip2,
1740      &        eps1,eps2rt**2,eps3rt**2,
1741      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1742      &        evdwij+e_augm
1743             endif
1744 C Calculate gradient components.
1745             e1=e1*eps1*eps2rt**2*eps3rt**2
1746             fac=-expon*(e1+evdwij)*rij_shift
1747             sigder=fac*sigder
1748             fac=rij*fac-2*expon*rrij*e_augm
1749 C Calculate the radial part of the gradient
1750             gg(1)=xj*fac
1751             gg(2)=yj*fac
1752             gg(3)=zj*fac
1753 C Calculate angular part of the gradient.
1754             call sc_grad
1755           enddo      ! j
1756         enddo        ! iint
1757       enddo          ! i
1758       end
1759 C-----------------------------------------------------------------------------
1760       subroutine sc_angular
1761 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1762 C om12. Called by ebp, egb, and egbv.
1763       implicit none
1764       include 'COMMON.CALC'
1765       include 'COMMON.IOUNITS'
1766       erij(1)=xj*rij
1767       erij(2)=yj*rij
1768       erij(3)=zj*rij
1769       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1770       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1771       om12=dxi*dxj+dyi*dyj+dzi*dzj
1772       chiom12=chi12*om12
1773 C Calculate eps1(om12) and its derivative in om12
1774       faceps1=1.0D0-om12*chiom12
1775       faceps1_inv=1.0D0/faceps1
1776       eps1=dsqrt(faceps1_inv)
1777 C Following variable is eps1*deps1/dom12
1778       eps1_om12=faceps1_inv*chiom12
1779 c diagnostics only
1780 c      faceps1_inv=om12
1781 c      eps1=om12
1782 c      eps1_om12=1.0d0
1783 c      write (iout,*) "om12",om12," eps1",eps1
1784 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1785 C and om12.
1786       om1om2=om1*om2
1787       chiom1=chi1*om1
1788       chiom2=chi2*om2
1789       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1790       sigsq=1.0D0-facsig*faceps1_inv
1791       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1792       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1793       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1794 c diagnostics only
1795 c      sigsq=1.0d0
1796 c      sigsq_om1=0.0d0
1797 c      sigsq_om2=0.0d0
1798 c      sigsq_om12=0.0d0
1799 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1800 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1801 c     &    " eps1",eps1
1802 C Calculate eps2 and its derivatives in om1, om2, and om12.
1803       chipom1=chip1*om1
1804       chipom2=chip2*om2
1805       chipom12=chip12*om12
1806       facp=1.0D0-om12*chipom12
1807       facp_inv=1.0D0/facp
1808       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1809 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1810 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1811 C Following variable is the square root of eps2
1812       eps2rt=1.0D0-facp1*facp_inv
1813 C Following three variables are the derivatives of the square root of eps
1814 C in om1, om2, and om12.
1815       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1816       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1817       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1818 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1819       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1820 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1821 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1822 c     &  " eps2rt_om12",eps2rt_om12
1823 C Calculate whole angle-dependent part of epsilon and contributions
1824 C to its derivatives
1825       return
1826       end
1827 C----------------------------------------------------------------------------
1828       subroutine sc_grad
1829       implicit real*8 (a-h,o-z)
1830       include 'DIMENSIONS'
1831       include 'COMMON.CHAIN'
1832       include 'COMMON.DERIV'
1833       include 'COMMON.CALC'
1834       include 'COMMON.IOUNITS'
1835       double precision dcosom1(3),dcosom2(3)
1836 cc      print *,'sss=',sss
1837       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1838       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1839       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1840      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1841 c diagnostics only
1842 c      eom1=0.0d0
1843 c      eom2=0.0d0
1844 c      eom12=evdwij*eps1_om12
1845 c end diagnostics
1846 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1847 c     &  " sigder",sigder
1848 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1849 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1850       do k=1,3
1851         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1852         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1853       enddo
1854       do k=1,3
1855         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1856       enddo
1857 c      write (iout,*) "gg",(gg(k),k=1,3)
1858       do k=1,3
1859         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1860      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1861      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1862         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1863      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1864      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1865 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1866 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1867 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1868 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1869       enddo
1870 C
1871 C Calculate the components of the gradient in DC and X
1872 C
1873 cgrad      do k=i,j-1
1874 cgrad        do l=1,3
1875 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1876 cgrad        enddo
1877 cgrad      enddo
1878       do l=1,3
1879         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1880         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1881       enddo
1882       return
1883       end
1884 C-----------------------------------------------------------------------
1885       subroutine e_softsphere(evdw)
1886 C
1887 C This subroutine calculates the interaction energy of nonbonded side chains
1888 C assuming the LJ potential of interaction.
1889 C
1890       implicit real*8 (a-h,o-z)
1891       include 'DIMENSIONS'
1892       parameter (accur=1.0d-10)
1893       include 'COMMON.GEO'
1894       include 'COMMON.VAR'
1895       include 'COMMON.LOCAL'
1896       include 'COMMON.CHAIN'
1897       include 'COMMON.DERIV'
1898       include 'COMMON.INTERACT'
1899       include 'COMMON.TORSION'
1900       include 'COMMON.SBRIDGE'
1901       include 'COMMON.NAMES'
1902       include 'COMMON.IOUNITS'
1903       include 'COMMON.CONTACTS'
1904       dimension gg(3)
1905 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1906       evdw=0.0D0
1907       do i=iatsc_s,iatsc_e
1908         itypi=iabs(itype(i))
1909         if (itypi.eq.ntyp1) cycle
1910         itypi1=iabs(itype(i+1))
1911         xi=c(1,nres+i)
1912         yi=c(2,nres+i)
1913         zi=c(3,nres+i)
1914 C
1915 C Calculate SC interaction energy.
1916 C
1917         do iint=1,nint_gr(i)
1918 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1919 cd   &                  'iend=',iend(i,iint)
1920           do j=istart(i,iint),iend(i,iint)
1921             itypj=iabs(itype(j))
1922             if (itypj.eq.ntyp1) cycle
1923             xj=c(1,nres+j)-xi
1924             yj=c(2,nres+j)-yi
1925             zj=c(3,nres+j)-zi
1926             rij=xj*xj+yj*yj+zj*zj
1927 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1928             r0ij=r0(itypi,itypj)
1929             r0ijsq=r0ij*r0ij
1930 c            print *,i,j,r0ij,dsqrt(rij)
1931             if (rij.lt.r0ijsq) then
1932               evdwij=0.25d0*(rij-r0ijsq)**2
1933               fac=rij-r0ijsq
1934             else
1935               evdwij=0.0d0
1936               fac=0.0d0
1937             endif
1938             evdw=evdw+evdwij
1939 C
1940 C Calculate the components of the gradient in DC and X
1941 C
1942             gg(1)=xj*fac
1943             gg(2)=yj*fac
1944             gg(3)=zj*fac
1945             do k=1,3
1946               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1947               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1948               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1949               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1950             enddo
1951 cgrad            do k=i,j-1
1952 cgrad              do l=1,3
1953 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1954 cgrad              enddo
1955 cgrad            enddo
1956           enddo ! j
1957         enddo ! iint
1958       enddo ! i
1959       return
1960       end
1961 C--------------------------------------------------------------------------
1962       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1963      &              eello_turn4)
1964 C
1965 C Soft-sphere potential of p-p interaction
1966 C
1967       implicit real*8 (a-h,o-z)
1968       include 'DIMENSIONS'
1969       include 'COMMON.CONTROL'
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.DERIV'
1976       include 'COMMON.INTERACT'
1977       include 'COMMON.CONTACTS'
1978       include 'COMMON.TORSION'
1979       include 'COMMON.VECTORS'
1980       include 'COMMON.FFIELD'
1981       dimension ggg(3)
1982 cd      write(iout,*) 'In EELEC_soft_sphere'
1983       ees=0.0D0
1984       evdw1=0.0D0
1985       eel_loc=0.0d0
1986       eello_turn3=0.0d0
1987       eello_turn4=0.0d0
1988       ind=0
1989       do i=iatel_s,iatel_e
1990         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1991         dxi=dc(1,i)
1992         dyi=dc(2,i)
1993         dzi=dc(3,i)
1994         xmedi=c(1,i)+0.5d0*dxi
1995         ymedi=c(2,i)+0.5d0*dyi
1996         zmedi=c(3,i)+0.5d0*dzi
1997         num_conti=0
1998 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1999         do j=ielstart(i),ielend(i)
2000           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2001           ind=ind+1
2002           iteli=itel(i)
2003           itelj=itel(j)
2004           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2005           r0ij=rpp(iteli,itelj)
2006           r0ijsq=r0ij*r0ij
2007           dxj=dc(1,j)
2008           dyj=dc(2,j)
2009           dzj=dc(3,j)
2010           xj=c(1,j)+0.5D0*dxj-xmedi
2011           yj=c(2,j)+0.5D0*dyj-ymedi
2012           zj=c(3,j)+0.5D0*dzj-zmedi
2013           rij=xj*xj+yj*yj+zj*zj
2014           if (rij.lt.r0ijsq) then
2015             evdw1ij=0.25d0*(rij-r0ijsq)**2
2016             fac=rij-r0ijsq
2017           else
2018             evdw1ij=0.0d0
2019             fac=0.0d0
2020           endif
2021           evdw1=evdw1+evdw1ij
2022 C
2023 C Calculate contributions to the Cartesian gradient.
2024 C
2025           ggg(1)=fac*xj
2026           ggg(2)=fac*yj
2027           ggg(3)=fac*zj
2028           do k=1,3
2029             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2030             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2031           enddo
2032 *
2033 * Loop over residues i+1 thru j-1.
2034 *
2035 cgrad          do k=i+1,j-1
2036 cgrad            do l=1,3
2037 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2038 cgrad            enddo
2039 cgrad          enddo
2040         enddo ! j
2041       enddo   ! i
2042 cgrad      do i=nnt,nct-1
2043 cgrad        do k=1,3
2044 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2045 cgrad        enddo
2046 cgrad        do j=i+1,nct-1
2047 cgrad          do k=1,3
2048 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2049 cgrad          enddo
2050 cgrad        enddo
2051 cgrad      enddo
2052       return
2053       end
2054 c------------------------------------------------------------------------------
2055       subroutine vec_and_deriv
2056       implicit real*8 (a-h,o-z)
2057       include 'DIMENSIONS'
2058 #ifdef MPI
2059       include 'mpif.h'
2060 #endif
2061       include 'COMMON.IOUNITS'
2062       include 'COMMON.GEO'
2063       include 'COMMON.VAR'
2064       include 'COMMON.LOCAL'
2065       include 'COMMON.CHAIN'
2066       include 'COMMON.VECTORS'
2067       include 'COMMON.SETUP'
2068       include 'COMMON.TIME1'
2069       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2070 C Compute the local reference systems. For reference system (i), the
2071 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2072 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2073 #ifdef PARVEC
2074       do i=ivec_start,ivec_end
2075 #else
2076       do i=1,nres-1
2077 #endif
2078           if (i.eq.nres-1) then
2079 C Case of the last full residue
2080 C Compute the Z-axis
2081             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2082             costh=dcos(pi-theta(nres))
2083             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2084             do k=1,3
2085               uz(k,i)=fac*uz(k,i)
2086             enddo
2087 C Compute the derivatives of uz
2088             uzder(1,1,1)= 0.0d0
2089             uzder(2,1,1)=-dc_norm(3,i-1)
2090             uzder(3,1,1)= dc_norm(2,i-1)
2091             uzder(1,2,1)= dc_norm(3,i-1)
2092             uzder(2,2,1)= 0.0d0
2093             uzder(3,2,1)=-dc_norm(1,i-1)
2094             uzder(1,3,1)=-dc_norm(2,i-1)
2095             uzder(2,3,1)= dc_norm(1,i-1)
2096             uzder(3,3,1)= 0.0d0
2097             uzder(1,1,2)= 0.0d0
2098             uzder(2,1,2)= dc_norm(3,i)
2099             uzder(3,1,2)=-dc_norm(2,i)
2100             uzder(1,2,2)=-dc_norm(3,i)
2101             uzder(2,2,2)= 0.0d0
2102             uzder(3,2,2)= dc_norm(1,i)
2103             uzder(1,3,2)= dc_norm(2,i)
2104             uzder(2,3,2)=-dc_norm(1,i)
2105             uzder(3,3,2)= 0.0d0
2106 C Compute the Y-axis
2107             facy=fac
2108             do k=1,3
2109               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2110             enddo
2111 C Compute the derivatives of uy
2112             do j=1,3
2113               do k=1,3
2114                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2115      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2116                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2117               enddo
2118               uyder(j,j,1)=uyder(j,j,1)-costh
2119               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2120             enddo
2121             do j=1,2
2122               do k=1,3
2123                 do l=1,3
2124                   uygrad(l,k,j,i)=uyder(l,k,j)
2125                   uzgrad(l,k,j,i)=uzder(l,k,j)
2126                 enddo
2127               enddo
2128             enddo
2129             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2130             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2131             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2132             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2133           else
2134 C Other residues
2135 C Compute the Z-axis
2136             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2137             costh=dcos(pi-theta(i+2))
2138             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2139             do k=1,3
2140               uz(k,i)=fac*uz(k,i)
2141             enddo
2142 C Compute the derivatives of uz
2143             uzder(1,1,1)= 0.0d0
2144             uzder(2,1,1)=-dc_norm(3,i+1)
2145             uzder(3,1,1)= dc_norm(2,i+1)
2146             uzder(1,2,1)= dc_norm(3,i+1)
2147             uzder(2,2,1)= 0.0d0
2148             uzder(3,2,1)=-dc_norm(1,i+1)
2149             uzder(1,3,1)=-dc_norm(2,i+1)
2150             uzder(2,3,1)= dc_norm(1,i+1)
2151             uzder(3,3,1)= 0.0d0
2152             uzder(1,1,2)= 0.0d0
2153             uzder(2,1,2)= dc_norm(3,i)
2154             uzder(3,1,2)=-dc_norm(2,i)
2155             uzder(1,2,2)=-dc_norm(3,i)
2156             uzder(2,2,2)= 0.0d0
2157             uzder(3,2,2)= dc_norm(1,i)
2158             uzder(1,3,2)= dc_norm(2,i)
2159             uzder(2,3,2)=-dc_norm(1,i)
2160             uzder(3,3,2)= 0.0d0
2161 C Compute the Y-axis
2162             facy=fac
2163             do k=1,3
2164               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2165             enddo
2166 C Compute the derivatives of uy
2167             do j=1,3
2168               do k=1,3
2169                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2170      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2171                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2172               enddo
2173               uyder(j,j,1)=uyder(j,j,1)-costh
2174               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2175             enddo
2176             do j=1,2
2177               do k=1,3
2178                 do l=1,3
2179                   uygrad(l,k,j,i)=uyder(l,k,j)
2180                   uzgrad(l,k,j,i)=uzder(l,k,j)
2181                 enddo
2182               enddo
2183             enddo
2184             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2185             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2186             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2187             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2188           endif
2189       enddo
2190       do i=1,nres-1
2191         vbld_inv_temp(1)=vbld_inv(i+1)
2192         if (i.lt.nres-1) then
2193           vbld_inv_temp(2)=vbld_inv(i+2)
2194           else
2195           vbld_inv_temp(2)=vbld_inv(i)
2196           endif
2197         do j=1,2
2198           do k=1,3
2199             do l=1,3
2200               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2201               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2202             enddo
2203           enddo
2204         enddo
2205       enddo
2206 #if defined(PARVEC) && defined(MPI)
2207       if (nfgtasks1.gt.1) then
2208         time00=MPI_Wtime()
2209 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2210 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2211 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2212         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2213      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2214      &   FG_COMM1,IERR)
2215         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2216      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2217      &   FG_COMM1,IERR)
2218         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2219      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2220      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2221         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2222      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2223      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2224         time_gather=time_gather+MPI_Wtime()-time00
2225       endif
2226 c      if (fg_rank.eq.0) then
2227 c        write (iout,*) "Arrays UY and UZ"
2228 c        do i=1,nres-1
2229 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2230 c     &     (uz(k,i),k=1,3)
2231 c        enddo
2232 c      endif
2233 #endif
2234       return
2235       end
2236 C-----------------------------------------------------------------------------
2237       subroutine check_vecgrad
2238       implicit real*8 (a-h,o-z)
2239       include 'DIMENSIONS'
2240       include 'COMMON.IOUNITS'
2241       include 'COMMON.GEO'
2242       include 'COMMON.VAR'
2243       include 'COMMON.LOCAL'
2244       include 'COMMON.CHAIN'
2245       include 'COMMON.VECTORS'
2246       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2247       dimension uyt(3,maxres),uzt(3,maxres)
2248       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2249       double precision delta /1.0d-7/
2250       call vec_and_deriv
2251 cd      do i=1,nres
2252 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2253 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2254 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2255 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2256 cd     &     (dc_norm(if90,i),if90=1,3)
2257 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2258 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2259 cd          write(iout,'(a)')
2260 cd      enddo
2261       do i=1,nres
2262         do j=1,2
2263           do k=1,3
2264             do l=1,3
2265               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2266               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2267             enddo
2268           enddo
2269         enddo
2270       enddo
2271       call vec_and_deriv
2272       do i=1,nres
2273         do j=1,3
2274           uyt(j,i)=uy(j,i)
2275           uzt(j,i)=uz(j,i)
2276         enddo
2277       enddo
2278       do i=1,nres
2279 cd        write (iout,*) 'i=',i
2280         do k=1,3
2281           erij(k)=dc_norm(k,i)
2282         enddo
2283         do j=1,3
2284           do k=1,3
2285             dc_norm(k,i)=erij(k)
2286           enddo
2287           dc_norm(j,i)=dc_norm(j,i)+delta
2288 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2289 c          do k=1,3
2290 c            dc_norm(k,i)=dc_norm(k,i)/fac
2291 c          enddo
2292 c          write (iout,*) (dc_norm(k,i),k=1,3)
2293 c          write (iout,*) (erij(k),k=1,3)
2294           call vec_and_deriv
2295           do k=1,3
2296             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2297             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2298             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2299             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2300           enddo
2301 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2302 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2303 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2304         enddo
2305         do k=1,3
2306           dc_norm(k,i)=erij(k)
2307         enddo
2308 cd        do k=1,3
2309 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2310 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2311 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2312 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2313 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2314 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2315 cd          write (iout,'(a)')
2316 cd        enddo
2317       enddo
2318       return
2319       end
2320 C--------------------------------------------------------------------------
2321       subroutine set_matrices
2322       implicit real*8 (a-h,o-z)
2323       include 'DIMENSIONS'
2324 #ifdef MPI
2325       include "mpif.h"
2326       include "COMMON.SETUP"
2327       integer IERR
2328       integer status(MPI_STATUS_SIZE)
2329 #endif
2330       include 'COMMON.IOUNITS'
2331       include 'COMMON.GEO'
2332       include 'COMMON.VAR'
2333       include 'COMMON.LOCAL'
2334       include 'COMMON.CHAIN'
2335       include 'COMMON.DERIV'
2336       include 'COMMON.INTERACT'
2337       include 'COMMON.CONTACTS'
2338       include 'COMMON.TORSION'
2339       include 'COMMON.VECTORS'
2340       include 'COMMON.FFIELD'
2341       double precision auxvec(2),auxmat(2,2)
2342 C
2343 C Compute the virtual-bond-torsional-angle dependent quantities needed
2344 C to calculate the el-loc multibody terms of various order.
2345 C
2346 #ifdef PARMAT
2347       do i=ivec_start+2,ivec_end+2
2348 #else
2349       do i=3,nres+1
2350 #endif
2351         if (i .lt. nres+1) then
2352           sin1=dsin(phi(i))
2353           cos1=dcos(phi(i))
2354           sintab(i-2)=sin1
2355           costab(i-2)=cos1
2356           obrot(1,i-2)=cos1
2357           obrot(2,i-2)=sin1
2358           sin2=dsin(2*phi(i))
2359           cos2=dcos(2*phi(i))
2360           sintab2(i-2)=sin2
2361           costab2(i-2)=cos2
2362           obrot2(1,i-2)=cos2
2363           obrot2(2,i-2)=sin2
2364           Ug(1,1,i-2)=-cos1
2365           Ug(1,2,i-2)=-sin1
2366           Ug(2,1,i-2)=-sin1
2367           Ug(2,2,i-2)= cos1
2368           Ug2(1,1,i-2)=-cos2
2369           Ug2(1,2,i-2)=-sin2
2370           Ug2(2,1,i-2)=-sin2
2371           Ug2(2,2,i-2)= cos2
2372         else
2373           costab(i-2)=1.0d0
2374           sintab(i-2)=0.0d0
2375           obrot(1,i-2)=1.0d0
2376           obrot(2,i-2)=0.0d0
2377           obrot2(1,i-2)=0.0d0
2378           obrot2(2,i-2)=0.0d0
2379           Ug(1,1,i-2)=1.0d0
2380           Ug(1,2,i-2)=0.0d0
2381           Ug(2,1,i-2)=0.0d0
2382           Ug(2,2,i-2)=1.0d0
2383           Ug2(1,1,i-2)=0.0d0
2384           Ug2(1,2,i-2)=0.0d0
2385           Ug2(2,1,i-2)=0.0d0
2386           Ug2(2,2,i-2)=0.0d0
2387         endif
2388         if (i .gt. 3 .and. i .lt. nres+1) then
2389           obrot_der(1,i-2)=-sin1
2390           obrot_der(2,i-2)= cos1
2391           Ugder(1,1,i-2)= sin1
2392           Ugder(1,2,i-2)=-cos1
2393           Ugder(2,1,i-2)=-cos1
2394           Ugder(2,2,i-2)=-sin1
2395           dwacos2=cos2+cos2
2396           dwasin2=sin2+sin2
2397           obrot2_der(1,i-2)=-dwasin2
2398           obrot2_der(2,i-2)= dwacos2
2399           Ug2der(1,1,i-2)= dwasin2
2400           Ug2der(1,2,i-2)=-dwacos2
2401           Ug2der(2,1,i-2)=-dwacos2
2402           Ug2der(2,2,i-2)=-dwasin2
2403         else
2404           obrot_der(1,i-2)=0.0d0
2405           obrot_der(2,i-2)=0.0d0
2406           Ugder(1,1,i-2)=0.0d0
2407           Ugder(1,2,i-2)=0.0d0
2408           Ugder(2,1,i-2)=0.0d0
2409           Ugder(2,2,i-2)=0.0d0
2410           obrot2_der(1,i-2)=0.0d0
2411           obrot2_der(2,i-2)=0.0d0
2412           Ug2der(1,1,i-2)=0.0d0
2413           Ug2der(1,2,i-2)=0.0d0
2414           Ug2der(2,1,i-2)=0.0d0
2415           Ug2der(2,2,i-2)=0.0d0
2416         endif
2417 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2418         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2419           iti = itortyp(itype(i-2))
2420         else
2421           iti=ntortyp
2422         endif
2423 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2424         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2425           iti1 = itortyp(itype(i-1))
2426         else
2427           iti1=ntortyp
2428         endif
2429 cd        write (iout,*) '*******i',i,' iti1',iti
2430 cd        write (iout,*) 'b1',b1(:,iti)
2431 cd        write (iout,*) 'b2',b2(:,iti)
2432 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2433 c        if (i .gt. iatel_s+2) then
2434         if (i .gt. nnt+2) then
2435           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2436           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2437           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2438      &    then
2439           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2440           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2441           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2442           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2443           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2444           endif
2445         else
2446           do k=1,2
2447             Ub2(k,i-2)=0.0d0
2448             Ctobr(k,i-2)=0.0d0
2449             Dtobr2(k,i-2)=0.0d0
2450             do l=1,2
2451               EUg(l,k,i-2)=0.0d0
2452               CUg(l,k,i-2)=0.0d0
2453               DUg(l,k,i-2)=0.0d0
2454               DtUg2(l,k,i-2)=0.0d0
2455             enddo
2456           enddo
2457         endif
2458         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2459         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2460         do k=1,2
2461           muder(k,i-2)=Ub2der(k,i-2)
2462         enddo
2463 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2464         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2465           if (itype(i-1).le.ntyp) then
2466             iti1 = itortyp(itype(i-1))
2467           else
2468             iti1=ntortyp
2469           endif
2470         else
2471           iti1=ntortyp
2472         endif
2473         do k=1,2
2474           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2475         enddo
2476 cd        write (iout,*) 'mu ',mu(:,i-2)
2477 cd        write (iout,*) 'mu1',mu1(:,i-2)
2478 cd        write (iout,*) 'mu2',mu2(:,i-2)
2479         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2480      &  then
2481         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2482         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2483         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2484         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2485         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2486 C Vectors and matrices dependent on a single virtual-bond dihedral.
2487         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2488         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2489         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2490         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2491         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2492         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2493         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2494         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2495         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2496         endif
2497       enddo
2498 C Matrices dependent on two consecutive virtual-bond dihedrals.
2499 C The order of matrices is from left to right.
2500       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2501      &then
2502 c      do i=max0(ivec_start,2),ivec_end
2503       do i=2,nres-1
2504         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2505         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2506         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2507         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2508         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2509         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2510         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2511         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2512       enddo
2513       endif
2514 #if defined(MPI) && defined(PARMAT)
2515 #ifdef DEBUG
2516 c      if (fg_rank.eq.0) then
2517         write (iout,*) "Arrays UG and UGDER before GATHER"
2518         do i=1,nres-1
2519           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2520      &     ((ug(l,k,i),l=1,2),k=1,2),
2521      &     ((ugder(l,k,i),l=1,2),k=1,2)
2522         enddo
2523         write (iout,*) "Arrays UG2 and UG2DER"
2524         do i=1,nres-1
2525           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2526      &     ((ug2(l,k,i),l=1,2),k=1,2),
2527      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2528         enddo
2529         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2530         do i=1,nres-1
2531           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2532      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2533      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2534         enddo
2535         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2536         do i=1,nres-1
2537           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2538      &     costab(i),sintab(i),costab2(i),sintab2(i)
2539         enddo
2540         write (iout,*) "Array MUDER"
2541         do i=1,nres-1
2542           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2543         enddo
2544 c      endif
2545 #endif
2546       if (nfgtasks.gt.1) then
2547         time00=MPI_Wtime()
2548 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2549 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2550 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2551 #ifdef MATGATHER
2552         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2571      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2572      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2573         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2574      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2575      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2576         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2577      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2578      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2579         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2580      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2581      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2582         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2583      &  then
2584         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2588      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2589      &   FG_COMM1,IERR)
2590         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2591      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2592      &   FG_COMM1,IERR)
2593        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2594      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2597      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2598      &   FG_COMM1,IERR)
2599         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2600      &   ivec_count(fg_rank1),
2601      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2605      &   FG_COMM1,IERR)
2606         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2611      &   FG_COMM1,IERR)
2612         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2614      &   FG_COMM1,IERR)
2615         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2622      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2623      &   FG_COMM1,IERR)
2624         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2625      &   ivec_count(fg_rank1),
2626      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2630      &   FG_COMM1,IERR)
2631        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2636      &   FG_COMM1,IERR)
2637        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2641      &   ivec_count(fg_rank1),
2642      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2643      &   FG_COMM1,IERR)
2644         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2645      &   ivec_count(fg_rank1),
2646      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2647      &   FG_COMM1,IERR)
2648         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2649      &   ivec_count(fg_rank1),
2650      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2651      &   MPI_MAT2,FG_COMM1,IERR)
2652         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2653      &   ivec_count(fg_rank1),
2654      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2655      &   MPI_MAT2,FG_COMM1,IERR)
2656         endif
2657 #else
2658 c Passes matrix info through the ring
2659       isend=fg_rank1
2660       irecv=fg_rank1-1
2661       if (irecv.lt.0) irecv=nfgtasks1-1
2662       iprev=irecv
2663       inext=fg_rank1+1
2664       if (inext.ge.nfgtasks1) inext=0
2665       do i=1,nfgtasks1-1
2666 c        write (iout,*) "isend",isend," irecv",irecv
2667 c        call flush(iout)
2668         lensend=lentyp(isend)
2669         lenrecv=lentyp(irecv)
2670 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2671 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2672 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2673 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2674 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2675 c        write (iout,*) "Gather ROTAT1"
2676 c        call flush(iout)
2677 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2678 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2679 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2680 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2681 c        write (iout,*) "Gather ROTAT2"
2682 c        call flush(iout)
2683         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2684      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2685      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2686      &   iprev,4400+irecv,FG_COMM,status,IERR)
2687 c        write (iout,*) "Gather ROTAT_OLD"
2688 c        call flush(iout)
2689         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2690      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2691      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2692      &   iprev,5500+irecv,FG_COMM,status,IERR)
2693 c        write (iout,*) "Gather PRECOMP11"
2694 c        call flush(iout)
2695         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2696      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2697      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2698      &   iprev,6600+irecv,FG_COMM,status,IERR)
2699 c        write (iout,*) "Gather PRECOMP12"
2700 c        call flush(iout)
2701         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2702      &  then
2703         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2704      &   MPI_ROTAT2(lensend),inext,7700+isend,
2705      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2706      &   iprev,7700+irecv,FG_COMM,status,IERR)
2707 c        write (iout,*) "Gather PRECOMP21"
2708 c        call flush(iout)
2709         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2710      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2711      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2712      &   iprev,8800+irecv,FG_COMM,status,IERR)
2713 c        write (iout,*) "Gather PRECOMP22"
2714 c        call flush(iout)
2715         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2716      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2717      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2718      &   MPI_PRECOMP23(lenrecv),
2719      &   iprev,9900+irecv,FG_COMM,status,IERR)
2720 c        write (iout,*) "Gather PRECOMP23"
2721 c        call flush(iout)
2722         endif
2723         isend=irecv
2724         irecv=irecv-1
2725         if (irecv.lt.0) irecv=nfgtasks1-1
2726       enddo
2727 #endif
2728         time_gather=time_gather+MPI_Wtime()-time00
2729       endif
2730 #ifdef DEBUG
2731 c      if (fg_rank.eq.0) then
2732         write (iout,*) "Arrays UG and UGDER"
2733         do i=1,nres-1
2734           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2735      &     ((ug(l,k,i),l=1,2),k=1,2),
2736      &     ((ugder(l,k,i),l=1,2),k=1,2)
2737         enddo
2738         write (iout,*) "Arrays UG2 and UG2DER"
2739         do i=1,nres-1
2740           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2741      &     ((ug2(l,k,i),l=1,2),k=1,2),
2742      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2743         enddo
2744         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2745         do i=1,nres-1
2746           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2747      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2748      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2749         enddo
2750         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2751         do i=1,nres-1
2752           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2753      &     costab(i),sintab(i),costab2(i),sintab2(i)
2754         enddo
2755         write (iout,*) "Array MUDER"
2756         do i=1,nres-1
2757           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2758         enddo
2759 c      endif
2760 #endif
2761 #endif
2762 cd      do i=1,nres
2763 cd        iti = itortyp(itype(i))
2764 cd        write (iout,*) i
2765 cd        do j=1,2
2766 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2767 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2768 cd        enddo
2769 cd      enddo
2770       return
2771       end
2772 C--------------------------------------------------------------------------
2773       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2774 C
2775 C This subroutine calculates the average interaction energy and its gradient
2776 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2777 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2778 C The potential depends both on the distance of peptide-group centers and on
2779 C the orientation of the CA-CA virtual bonds.
2780 C
2781       implicit real*8 (a-h,o-z)
2782 #ifdef MPI
2783       include 'mpif.h'
2784 #endif
2785       include 'DIMENSIONS'
2786       include 'COMMON.CONTROL'
2787       include 'COMMON.SETUP'
2788       include 'COMMON.IOUNITS'
2789       include 'COMMON.GEO'
2790       include 'COMMON.VAR'
2791       include 'COMMON.LOCAL'
2792       include 'COMMON.CHAIN'
2793       include 'COMMON.DERIV'
2794       include 'COMMON.INTERACT'
2795       include 'COMMON.CONTACTS'
2796       include 'COMMON.TORSION'
2797       include 'COMMON.VECTORS'
2798       include 'COMMON.FFIELD'
2799       include 'COMMON.TIME1'
2800       include 'COMMON.SPLITELE'
2801       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2802      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2803       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2804      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2805       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2806      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2807      &    num_conti,j1,j2
2808 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2809 #ifdef MOMENT
2810       double precision scal_el /1.0d0/
2811 #else
2812       double precision scal_el /0.5d0/
2813 #endif
2814 C 12/13/98
2815 C 13-go grudnia roku pamietnego...
2816       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2817      &                   0.0d0,1.0d0,0.0d0,
2818      &                   0.0d0,0.0d0,1.0d0/
2819 cd      write(iout,*) 'In EELEC'
2820 cd      do i=1,nloctyp
2821 cd        write(iout,*) 'Type',i
2822 cd        write(iout,*) 'B1',B1(:,i)
2823 cd        write(iout,*) 'B2',B2(:,i)
2824 cd        write(iout,*) 'CC',CC(:,:,i)
2825 cd        write(iout,*) 'DD',DD(:,:,i)
2826 cd        write(iout,*) 'EE',EE(:,:,i)
2827 cd      enddo
2828 cd      call check_vecgrad
2829 cd      stop
2830       if (icheckgrad.eq.1) then
2831         do i=1,nres-1
2832           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2833           do k=1,3
2834             dc_norm(k,i)=dc(k,i)*fac
2835           enddo
2836 c          write (iout,*) 'i',i,' fac',fac
2837         enddo
2838       endif
2839       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2840      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2841      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2842 c        call vec_and_deriv
2843 #ifdef TIMING
2844         time01=MPI_Wtime()
2845 #endif
2846         call set_matrices
2847 #ifdef TIMING
2848         time_mat=time_mat+MPI_Wtime()-time01
2849 #endif
2850       endif
2851 cd      do i=1,nres-1
2852 cd        write (iout,*) 'i=',i
2853 cd        do k=1,3
2854 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2855 cd        enddo
2856 cd        do k=1,3
2857 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2858 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2859 cd        enddo
2860 cd      enddo
2861       t_eelecij=0.0d0
2862       ees=0.0D0
2863       evdw1=0.0D0
2864       eel_loc=0.0d0
2865       eello_turn3=0.0d0
2866       eello_turn4=0.0d0
2867       ind=0
2868       do i=1,nres
2869         num_cont_hb(i)=0
2870       enddo
2871 cd      print '(a)','Enter EELEC'
2872 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2873       do i=1,nres
2874         gel_loc_loc(i)=0.0d0
2875         gcorr_loc(i)=0.0d0
2876       enddo
2877 c
2878 c
2879 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2880 C
2881 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2882 C
2883 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2884       do i=iturn3_start,iturn3_end
2885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2886      &  .or. itype(i+2).eq.ntyp1
2887      &  .or. itype(i+3).eq.ntyp1
2888      &  .or. itype(i-1).eq.ntyp1
2889      &  .or. itype(i+4).eq.ntyp1
2890      &  ) cycle
2891         dxi=dc(1,i)
2892         dyi=dc(2,i)
2893         dzi=dc(3,i)
2894         dx_normi=dc_norm(1,i)
2895         dy_normi=dc_norm(2,i)
2896         dz_normi=dc_norm(3,i)
2897         xmedi=c(1,i)+0.5d0*dxi
2898         ymedi=c(2,i)+0.5d0*dyi
2899         zmedi=c(3,i)+0.5d0*dzi
2900 C Return atom into box, boxxsize is size of box in x dimension
2901 c  184   continue
2902 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2903 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2904 C Condition for being inside the proper box
2905 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2906 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2907 c        go to 184
2908 c        endif
2909 c  185   continue
2910 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2911 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2912 cC Condition for being inside the proper box
2913 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2914 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2915 c        go to 185
2916 c        endif
2917 c  186   continue
2918 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2919 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2920 cC Condition for being inside the proper box
2921 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2922 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2923 c        go to 186
2924 c        endif
2925           xmedi=mod(xmedi,boxxsize)
2926           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2927           ymedi=mod(ymedi,boxysize)
2928           if (ymedi.lt.0) ymedi=ymedi+boxysize
2929           zmedi=mod(zmedi,boxzsize)
2930           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2931         num_conti=0
2932         call eelecij(i,i+2,ees,evdw1,eel_loc)
2933         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2934         num_cont_hb(i)=num_conti
2935       enddo
2936       do i=iturn4_start,iturn4_end
2937         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2938      &    .or. itype(i+3).eq.ntyp1
2939      &    .or. itype(i+4).eq.ntyp1
2940      &    .or. itype(i+5).eq.ntyp1
2941      &    .or. itype(i).eq.ntyp1
2942      &    .or. itype(i-1).eq.ntyp1
2943      &                             ) cycle
2944         dxi=dc(1,i)
2945         dyi=dc(2,i)
2946         dzi=dc(3,i)
2947         dx_normi=dc_norm(1,i)
2948         dy_normi=dc_norm(2,i)
2949         dz_normi=dc_norm(3,i)
2950         xmedi=c(1,i)+0.5d0*dxi
2951         ymedi=c(2,i)+0.5d0*dyi
2952         zmedi=c(3,i)+0.5d0*dzi
2953 C Return atom into box, boxxsize is size of box in x dimension
2954 c  194   continue
2955 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2956 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2957 C Condition for being inside the proper box
2958 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2959 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2960 c        go to 194
2961 c        endif
2962 c  195   continue
2963 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2964 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2965 C Condition for being inside the proper box
2966 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2967 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2968 c        go to 195
2969 c        endif
2970 c  196   continue
2971 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2972 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2973 C Condition for being inside the proper box
2974 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2975 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2976 c        go to 196
2977 c        endif
2978           xmedi=mod(xmedi,boxxsize)
2979           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2980           ymedi=mod(ymedi,boxysize)
2981           if (ymedi.lt.0) ymedi=ymedi+boxysize
2982           zmedi=mod(zmedi,boxzsize)
2983           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2984
2985         num_conti=num_cont_hb(i)
2986         call eelecij(i,i+3,ees,evdw1,eel_loc)
2987         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2988      &   call eturn4(i,eello_turn4)
2989         num_cont_hb(i)=num_conti
2990       enddo   ! i
2991 C Loop over all neighbouring boxes
2992       do xshift=-1,1
2993       do yshift=-1,1
2994       do zshift=-1,1
2995 c
2996 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2997 c
2998       do i=iatel_s,iatel_e
2999         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3000      &  .or. itype(i+2).eq.ntyp1
3001      &  .or. itype(i-1).eq.ntyp1
3002      &                ) cycle
3003         dxi=dc(1,i)
3004         dyi=dc(2,i)
3005         dzi=dc(3,i)
3006         dx_normi=dc_norm(1,i)
3007         dy_normi=dc_norm(2,i)
3008         dz_normi=dc_norm(3,i)
3009         xmedi=c(1,i)+0.5d0*dxi
3010         ymedi=c(2,i)+0.5d0*dyi
3011         zmedi=c(3,i)+0.5d0*dzi
3012           xmedi=mod(xmedi,boxxsize)
3013           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3014           ymedi=mod(ymedi,boxysize)
3015           if (ymedi.lt.0) ymedi=ymedi+boxysize
3016           zmedi=mod(zmedi,boxzsize)
3017           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3018           xmedi=xmedi+xshift*boxxsize
3019           ymedi=ymedi+yshift*boxysize
3020           zmedi=zmedi+zshift*boxzsize
3021
3022 C Return tom into box, boxxsize is size of box in x dimension
3023 c  164   continue
3024 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3025 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3026 C Condition for being inside the proper box
3027 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3028 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3029 c        go to 164
3030 c        endif
3031 c  165   continue
3032 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3033 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3034 C Condition for being inside the proper box
3035 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3036 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3037 c        go to 165
3038 c        endif
3039 c  166   continue
3040 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3041 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3042 cC Condition for being inside the proper box
3043 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3044 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3045 c        go to 166
3046 c        endif
3047
3048 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3049         num_conti=num_cont_hb(i)
3050         do j=ielstart(i),ielend(i)
3051 c          write (iout,*) i,j,itype(i),itype(j)
3052           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3053      & .or.itype(j+2).eq.ntyp1
3054      & .or.itype(j-1).eq.ntyp1
3055      &) cycle
3056           call eelecij(i,j,ees,evdw1,eel_loc)
3057         enddo ! j
3058         num_cont_hb(i)=num_conti
3059       enddo   ! i
3060       enddo   ! zshift
3061       enddo   ! yshift
3062       enddo   ! xshift
3063
3064 c      write (iout,*) "Number of loop steps in EELEC:",ind
3065 cd      do i=1,nres
3066 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3067 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3068 cd      enddo
3069 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3070 ccc      eel_loc=eel_loc+eello_turn3
3071 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3072       return
3073       end
3074 C-------------------------------------------------------------------------------
3075       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3076       implicit real*8 (a-h,o-z)
3077       include 'DIMENSIONS'
3078 #ifdef MPI
3079       include "mpif.h"
3080 #endif
3081       include 'COMMON.CONTROL'
3082       include 'COMMON.IOUNITS'
3083       include 'COMMON.GEO'
3084       include 'COMMON.VAR'
3085       include 'COMMON.LOCAL'
3086       include 'COMMON.CHAIN'
3087       include 'COMMON.DERIV'
3088       include 'COMMON.INTERACT'
3089       include 'COMMON.CONTACTS'
3090       include 'COMMON.TORSION'
3091       include 'COMMON.VECTORS'
3092       include 'COMMON.FFIELD'
3093       include 'COMMON.TIME1'
3094       include 'COMMON.SPLITELE'
3095       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3096      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3097       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3098      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3099       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3100      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3101      &    num_conti,j1,j2
3102 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3103 #ifdef MOMENT
3104       double precision scal_el /1.0d0/
3105 #else
3106       double precision scal_el /0.5d0/
3107 #endif
3108 C 12/13/98
3109 C 13-go grudnia roku pamietnego...
3110       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3111      &                   0.0d0,1.0d0,0.0d0,
3112      &                   0.0d0,0.0d0,1.0d0/
3113 c          time00=MPI_Wtime()
3114 cd      write (iout,*) "eelecij",i,j
3115 c          ind=ind+1
3116           iteli=itel(i)
3117           itelj=itel(j)
3118           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3119           aaa=app(iteli,itelj)
3120           bbb=bpp(iteli,itelj)
3121           ael6i=ael6(iteli,itelj)
3122           ael3i=ael3(iteli,itelj)
3123           dxj=dc(1,j)
3124           dyj=dc(2,j)
3125           dzj=dc(3,j)
3126           dx_normj=dc_norm(1,j)
3127           dy_normj=dc_norm(2,j)
3128           dz_normj=dc_norm(3,j)
3129 C          xj=c(1,j)+0.5D0*dxj-xmedi
3130 C          yj=c(2,j)+0.5D0*dyj-ymedi
3131 C          zj=c(3,j)+0.5D0*dzj-zmedi
3132           xj=c(1,j)+0.5D0*dxj
3133           yj=c(2,j)+0.5D0*dyj
3134           zj=c(3,j)+0.5D0*dzj
3135           xj=mod(xj,boxxsize)
3136           if (xj.lt.0) xj=xj+boxxsize
3137           yj=mod(yj,boxysize)
3138           if (yj.lt.0) yj=yj+boxysize
3139           zj=mod(zj,boxzsize)
3140           if (zj.lt.0) zj=zj+boxzsize
3141
3142 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3143 c  174   continue
3144 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3145 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3146 C Condition for being inside the proper box
3147 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3148 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3149 c        go to 174
3150 c        endif
3151 c  175   continue
3152 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3153 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3154 C Condition for being inside the proper box
3155 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3156 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3157 c        go to 175
3158 c        endif
3159 c  176   continue
3160 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3161 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3162 C Condition for being inside the proper box
3163 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3164 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3165 c        go to 176
3166 c        endif
3167 C        endif !endPBC condintion
3168         xj=xj-xmedi
3169         yj=yj-ymedi
3170         zj=zj-zmedi
3171           rij=xj*xj+yj*yj+zj*zj
3172
3173             sss=sscale(sqrt(rij))
3174             sssgrad=sscagrad(sqrt(rij))
3175 c            if (sss.gt.0.0d0) then
3176           rrmij=1.0D0/rij
3177           rij=dsqrt(rij)
3178           rmij=1.0D0/rij
3179           r3ij=rrmij*rmij
3180           r6ij=r3ij*r3ij
3181           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3182           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3183           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3184           fac=cosa-3.0D0*cosb*cosg
3185           ev1=aaa*r6ij*r6ij
3186 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3187           if (j.eq.i+2) ev1=scal_el*ev1
3188           ev2=bbb*r6ij
3189           fac3=ael6i*r6ij
3190           fac4=ael3i*r3ij
3191           evdwij=(ev1+ev2)
3192           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3193           el2=fac4*fac
3194 C MARYSIA
3195           eesij=(el1+el2)
3196 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3197           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3198           ees=ees+eesij
3199           evdw1=evdw1+evdwij*sss
3200 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3201 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3202 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3203 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3204
3205           if (energy_dec) then
3206               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3207      &'evdw1',i,j,evdwij
3208      &,iteli,itelj,aaa,evdw1
3209               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3210           endif
3211
3212 C
3213 C Calculate contributions to the Cartesian gradient.
3214 C
3215 #ifdef SPLITELE
3216           facvdw=-6*rrmij*(ev1+evdwij)*sss
3217           facel=-3*rrmij*(el1+eesij)
3218           fac1=fac
3219           erij(1)=xj*rmij
3220           erij(2)=yj*rmij
3221           erij(3)=zj*rmij
3222 *
3223 * Radial derivatives. First process both termini of the fragment (i,j)
3224 *
3225           ggg(1)=facel*xj
3226           ggg(2)=facel*yj
3227           ggg(3)=facel*zj
3228 c          do k=1,3
3229 c            ghalf=0.5D0*ggg(k)
3230 c            gelc(k,i)=gelc(k,i)+ghalf
3231 c            gelc(k,j)=gelc(k,j)+ghalf
3232 c          enddo
3233 c 9/28/08 AL Gradient compotents will be summed only at the end
3234           do k=1,3
3235             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3236             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3237           enddo
3238 *
3239 * Loop over residues i+1 thru j-1.
3240 *
3241 cgrad          do k=i+1,j-1
3242 cgrad            do l=1,3
3243 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3244 cgrad            enddo
3245 cgrad          enddo
3246           if (sss.gt.0.0) then
3247           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3248           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3249           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3250           else
3251           ggg(1)=0.0
3252           ggg(2)=0.0
3253           ggg(3)=0.0
3254           endif
3255 c          do k=1,3
3256 c            ghalf=0.5D0*ggg(k)
3257 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3258 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3259 c          enddo
3260 c 9/28/08 AL Gradient compotents will be summed only at the end
3261           do k=1,3
3262             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3263             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3264           enddo
3265 *
3266 * Loop over residues i+1 thru j-1.
3267 *
3268 cgrad          do k=i+1,j-1
3269 cgrad            do l=1,3
3270 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3271 cgrad            enddo
3272 cgrad          enddo
3273 #else
3274 C MARYSIA
3275           facvdw=(ev1+evdwij)*sss
3276           facel=(el1+eesij)
3277           fac1=fac
3278           fac=-3*rrmij*(facvdw+facvdw+facel)
3279           erij(1)=xj*rmij
3280           erij(2)=yj*rmij
3281           erij(3)=zj*rmij
3282 *
3283 * Radial derivatives. First process both termini of the fragment (i,j)
3284 *
3285           ggg(1)=fac*xj
3286           ggg(2)=fac*yj
3287           ggg(3)=fac*zj
3288 c          do k=1,3
3289 c            ghalf=0.5D0*ggg(k)
3290 c            gelc(k,i)=gelc(k,i)+ghalf
3291 c            gelc(k,j)=gelc(k,j)+ghalf
3292 c          enddo
3293 c 9/28/08 AL Gradient compotents will be summed only at the end
3294           do k=1,3
3295             gelc_long(k,j)=gelc(k,j)+ggg(k)
3296             gelc_long(k,i)=gelc(k,i)-ggg(k)
3297           enddo
3298 *
3299 * Loop over residues i+1 thru j-1.
3300 *
3301 cgrad          do k=i+1,j-1
3302 cgrad            do l=1,3
3303 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3304 cgrad            enddo
3305 cgrad          enddo
3306 c 9/28/08 AL Gradient compotents will be summed only at the end
3307           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3308           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3309           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3310           do k=1,3
3311             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3312             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3313           enddo
3314 #endif
3315 *
3316 * Angular part
3317 *
3318           ecosa=2.0D0*fac3*fac1+fac4
3319           fac4=-3.0D0*fac4
3320           fac3=-6.0D0*fac3
3321           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3322           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3323           do k=1,3
3324             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3325             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3326           enddo
3327 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3328 cd   &          (dcosg(k),k=1,3)
3329           do k=1,3
3330             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3331           enddo
3332 c          do k=1,3
3333 c            ghalf=0.5D0*ggg(k)
3334 c            gelc(k,i)=gelc(k,i)+ghalf
3335 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3336 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3337 c            gelc(k,j)=gelc(k,j)+ghalf
3338 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3339 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3340 c          enddo
3341 cgrad          do k=i+1,j-1
3342 cgrad            do l=1,3
3343 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3344 cgrad            enddo
3345 cgrad          enddo
3346           do k=1,3
3347             gelc(k,i)=gelc(k,i)
3348      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3349      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3350             gelc(k,j)=gelc(k,j)
3351      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3352      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3353             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3354             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3355           enddo
3356 C MARYSIA
3357 c          endif !sscale
3358           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3359      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3360      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3361 C
3362 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3363 C   energy of a peptide unit is assumed in the form of a second-order
3364 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3365 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3366 C   are computed for EVERY pair of non-contiguous peptide groups.
3367 C
3368           if (j.lt.nres-1) then
3369             j1=j+1
3370             j2=j-1
3371           else
3372             j1=j-1
3373             j2=j-2
3374           endif
3375           kkk=0
3376           do k=1,2
3377             do l=1,2
3378               kkk=kkk+1
3379               muij(kkk)=mu(k,i)*mu(l,j)
3380             enddo
3381           enddo
3382 cd         write (iout,*) 'EELEC: i',i,' j',j
3383 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3384 cd          write(iout,*) 'muij',muij
3385           ury=scalar(uy(1,i),erij)
3386           urz=scalar(uz(1,i),erij)
3387           vry=scalar(uy(1,j),erij)
3388           vrz=scalar(uz(1,j),erij)
3389           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3390           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3391           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3392           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3393           fac=dsqrt(-ael6i)*r3ij
3394           a22=a22*fac
3395           a23=a23*fac
3396           a32=a32*fac
3397           a33=a33*fac
3398 cd          write (iout,'(4i5,4f10.5)')
3399 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3400 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3401 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3402 cd     &      uy(:,j),uz(:,j)
3403 cd          write (iout,'(4f10.5)')
3404 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3405 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3406 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3407 cd           write (iout,'(9f10.5/)')
3408 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3409 C Derivatives of the elements of A in virtual-bond vectors
3410           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3411           do k=1,3
3412             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3413             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3414             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3415             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3416             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3417             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3418             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3419             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3420             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3421             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3422             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3423             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3424           enddo
3425 C Compute radial contributions to the gradient
3426           facr=-3.0d0*rrmij
3427           a22der=a22*facr
3428           a23der=a23*facr
3429           a32der=a32*facr
3430           a33der=a33*facr
3431           agg(1,1)=a22der*xj
3432           agg(2,1)=a22der*yj
3433           agg(3,1)=a22der*zj
3434           agg(1,2)=a23der*xj
3435           agg(2,2)=a23der*yj
3436           agg(3,2)=a23der*zj
3437           agg(1,3)=a32der*xj
3438           agg(2,3)=a32der*yj
3439           agg(3,3)=a32der*zj
3440           agg(1,4)=a33der*xj
3441           agg(2,4)=a33der*yj
3442           agg(3,4)=a33der*zj
3443 C Add the contributions coming from er
3444           fac3=-3.0d0*fac
3445           do k=1,3
3446             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3447             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3448             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3449             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3450           enddo
3451           do k=1,3
3452 C Derivatives in DC(i)
3453 cgrad            ghalf1=0.5d0*agg(k,1)
3454 cgrad            ghalf2=0.5d0*agg(k,2)
3455 cgrad            ghalf3=0.5d0*agg(k,3)
3456 cgrad            ghalf4=0.5d0*agg(k,4)
3457             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3458      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3459             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3460      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3461             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3462      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3463             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3464      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3465 C Derivatives in DC(i+1)
3466             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3467      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3468             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3469      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3470             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3471      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3472             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3473      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3474 C Derivatives in DC(j)
3475             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3476      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3477             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3478      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3479             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3480      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3481             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3482      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3483 C Derivatives in DC(j+1) or DC(nres-1)
3484             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3485      &      -3.0d0*vryg(k,3)*ury)
3486             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3487      &      -3.0d0*vrzg(k,3)*ury)
3488             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3489      &      -3.0d0*vryg(k,3)*urz)
3490             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3491      &      -3.0d0*vrzg(k,3)*urz)
3492 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3493 cgrad              do l=1,4
3494 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3495 cgrad              enddo
3496 cgrad            endif
3497           enddo
3498           acipa(1,1)=a22
3499           acipa(1,2)=a23
3500           acipa(2,1)=a32
3501           acipa(2,2)=a33
3502           a22=-a22
3503           a23=-a23
3504           do l=1,2
3505             do k=1,3
3506               agg(k,l)=-agg(k,l)
3507               aggi(k,l)=-aggi(k,l)
3508               aggi1(k,l)=-aggi1(k,l)
3509               aggj(k,l)=-aggj(k,l)
3510               aggj1(k,l)=-aggj1(k,l)
3511             enddo
3512           enddo
3513           if (j.lt.nres-1) then
3514             a22=-a22
3515             a32=-a32
3516             do l=1,3,2
3517               do k=1,3
3518                 agg(k,l)=-agg(k,l)
3519                 aggi(k,l)=-aggi(k,l)
3520                 aggi1(k,l)=-aggi1(k,l)
3521                 aggj(k,l)=-aggj(k,l)
3522                 aggj1(k,l)=-aggj1(k,l)
3523               enddo
3524             enddo
3525           else
3526             a22=-a22
3527             a23=-a23
3528             a32=-a32
3529             a33=-a33
3530             do l=1,4
3531               do k=1,3
3532                 agg(k,l)=-agg(k,l)
3533                 aggi(k,l)=-aggi(k,l)
3534                 aggi1(k,l)=-aggi1(k,l)
3535                 aggj(k,l)=-aggj(k,l)
3536                 aggj1(k,l)=-aggj1(k,l)
3537               enddo
3538             enddo
3539           endif
3540           ENDIF ! WCORR
3541           IF (wel_loc.gt.0.0d0) THEN
3542 C Contribution to the local-electrostatic energy coming from the i-j pair
3543           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3544      &     +a33*muij(4)
3545 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3546 c     &                     ' eel_loc_ij',eel_loc_ij
3547
3548           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3549      &            'eelloc',i,j,eel_loc_ij
3550 c           if (eel_loc_ij.ne.0)
3551 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3552 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3553
3554           eel_loc=eel_loc+eel_loc_ij
3555 C Partial derivatives in virtual-bond dihedral angles gamma
3556           if (i.gt.1)
3557      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3558      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3559      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3560           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3561      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3562      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3563 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3564           do l=1,3
3565             ggg(l)=agg(l,1)*muij(1)+
3566      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3567             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3568             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3569 cgrad            ghalf=0.5d0*ggg(l)
3570 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3571 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3572           enddo
3573 cgrad          do k=i+1,j2
3574 cgrad            do l=1,3
3575 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3576 cgrad            enddo
3577 cgrad          enddo
3578 C Remaining derivatives of eello
3579           do l=1,3
3580             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3581      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3582             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3583      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3584             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3585      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3586             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3587      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3588           enddo
3589           ENDIF
3590 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3591 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3592           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3593      &       .and. num_conti.le.maxconts) then
3594 c            write (iout,*) i,j," entered corr"
3595 C
3596 C Calculate the contact function. The ith column of the array JCONT will
3597 C contain the numbers of atoms that make contacts with the atom I (of numbers
3598 C greater than I). The arrays FACONT and GACONT will contain the values of
3599 C the contact function and its derivative.
3600 c           r0ij=1.02D0*rpp(iteli,itelj)
3601 c           r0ij=1.11D0*rpp(iteli,itelj)
3602             r0ij=2.20D0*rpp(iteli,itelj)
3603 c           r0ij=1.55D0*rpp(iteli,itelj)
3604             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3605             if (fcont.gt.0.0D0) then
3606               num_conti=num_conti+1
3607               if (num_conti.gt.maxconts) then
3608                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3609      &                         ' will skip next contacts for this conf.'
3610               else
3611                 jcont_hb(num_conti,i)=j
3612 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3613 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3614                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3615      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3616 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3617 C  terms.
3618                 d_cont(num_conti,i)=rij
3619 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3620 C     --- Electrostatic-interaction matrix ---
3621                 a_chuj(1,1,num_conti,i)=a22
3622                 a_chuj(1,2,num_conti,i)=a23
3623                 a_chuj(2,1,num_conti,i)=a32
3624                 a_chuj(2,2,num_conti,i)=a33
3625 C     --- Gradient of rij
3626                 do kkk=1,3
3627                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3628                 enddo
3629                 kkll=0
3630                 do k=1,2
3631                   do l=1,2
3632                     kkll=kkll+1
3633                     do m=1,3
3634                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3635                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3636                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3637                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3638                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3639                     enddo
3640                   enddo
3641                 enddo
3642                 ENDIF
3643                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3644 C Calculate contact energies
3645                 cosa4=4.0D0*cosa
3646                 wij=cosa-3.0D0*cosb*cosg
3647                 cosbg1=cosb+cosg
3648                 cosbg2=cosb-cosg
3649 c               fac3=dsqrt(-ael6i)/r0ij**3
3650                 fac3=dsqrt(-ael6i)*r3ij
3651 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3652                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3653                 if (ees0tmp.gt.0) then
3654                   ees0pij=dsqrt(ees0tmp)
3655                 else
3656                   ees0pij=0
3657                 endif
3658 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3659                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3660                 if (ees0tmp.gt.0) then
3661                   ees0mij=dsqrt(ees0tmp)
3662                 else
3663                   ees0mij=0
3664                 endif
3665 c               ees0mij=0.0D0
3666                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3667                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3668 C Diagnostics. Comment out or remove after debugging!
3669 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3670 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3671 c               ees0m(num_conti,i)=0.0D0
3672 C End diagnostics.
3673 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3674 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3675 C Angular derivatives of the contact function
3676                 ees0pij1=fac3/ees0pij
3677                 ees0mij1=fac3/ees0mij
3678                 fac3p=-3.0D0*fac3*rrmij
3679                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3680                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3681 c               ees0mij1=0.0D0
3682                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3683                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3684                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3685                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3686                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3687                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3688                 ecosap=ecosa1+ecosa2
3689                 ecosbp=ecosb1+ecosb2
3690                 ecosgp=ecosg1+ecosg2
3691                 ecosam=ecosa1-ecosa2
3692                 ecosbm=ecosb1-ecosb2
3693                 ecosgm=ecosg1-ecosg2
3694 C Diagnostics
3695 c               ecosap=ecosa1
3696 c               ecosbp=ecosb1
3697 c               ecosgp=ecosg1
3698 c               ecosam=0.0D0
3699 c               ecosbm=0.0D0
3700 c               ecosgm=0.0D0
3701 C End diagnostics
3702                 facont_hb(num_conti,i)=fcont
3703                 fprimcont=fprimcont/rij
3704 cd              facont_hb(num_conti,i)=1.0D0
3705 C Following line is for diagnostics.
3706 cd              fprimcont=0.0D0
3707                 do k=1,3
3708                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3709                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3710                 enddo
3711                 do k=1,3
3712                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3713                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3714                 enddo
3715                 gggp(1)=gggp(1)+ees0pijp*xj
3716                 gggp(2)=gggp(2)+ees0pijp*yj
3717                 gggp(3)=gggp(3)+ees0pijp*zj
3718                 gggm(1)=gggm(1)+ees0mijp*xj
3719                 gggm(2)=gggm(2)+ees0mijp*yj
3720                 gggm(3)=gggm(3)+ees0mijp*zj
3721 C Derivatives due to the contact function
3722                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3723                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3724                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3725                 do k=1,3
3726 c
3727 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3728 c          following the change of gradient-summation algorithm.
3729 c
3730 cgrad                  ghalfp=0.5D0*gggp(k)
3731 cgrad                  ghalfm=0.5D0*gggm(k)
3732                   gacontp_hb1(k,num_conti,i)=!ghalfp
3733      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3734      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3735                   gacontp_hb2(k,num_conti,i)=!ghalfp
3736      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3737      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3738                   gacontp_hb3(k,num_conti,i)=gggp(k)
3739                   gacontm_hb1(k,num_conti,i)=!ghalfm
3740      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3741      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3742                   gacontm_hb2(k,num_conti,i)=!ghalfm
3743      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3744      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3745                   gacontm_hb3(k,num_conti,i)=gggm(k)
3746                 enddo
3747 C Diagnostics. Comment out or remove after debugging!
3748 cdiag           do k=1,3
3749 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3750 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3751 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3752 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3753 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3754 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3755 cdiag           enddo
3756               ENDIF ! wcorr
3757               endif  ! num_conti.le.maxconts
3758             endif  ! fcont.gt.0
3759           endif    ! j.gt.i+1
3760           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3761             do k=1,4
3762               do l=1,3
3763                 ghalf=0.5d0*agg(l,k)
3764                 aggi(l,k)=aggi(l,k)+ghalf
3765                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3766                 aggj(l,k)=aggj(l,k)+ghalf
3767               enddo
3768             enddo
3769             if (j.eq.nres-1 .and. i.lt.j-2) then
3770               do k=1,4
3771                 do l=1,3
3772                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3773                 enddo
3774               enddo
3775             endif
3776           endif
3777 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3778       return
3779       end
3780 C-----------------------------------------------------------------------------
3781       subroutine eturn3(i,eello_turn3)
3782 C Third- and fourth-order contributions from turns
3783       implicit real*8 (a-h,o-z)
3784       include 'DIMENSIONS'
3785       include 'COMMON.IOUNITS'
3786       include 'COMMON.GEO'
3787       include 'COMMON.VAR'
3788       include 'COMMON.LOCAL'
3789       include 'COMMON.CHAIN'
3790       include 'COMMON.DERIV'
3791       include 'COMMON.INTERACT'
3792       include 'COMMON.CONTACTS'
3793       include 'COMMON.TORSION'
3794       include 'COMMON.VECTORS'
3795       include 'COMMON.FFIELD'
3796       include 'COMMON.CONTROL'
3797       dimension ggg(3)
3798       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3799      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3800      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3801       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3802      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3803       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3804      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3805      &    num_conti,j1,j2
3806       j=i+2
3807 c      write (iout,*) "eturn3",i,j,j1,j2
3808       a_temp(1,1)=a22
3809       a_temp(1,2)=a23
3810       a_temp(2,1)=a32
3811       a_temp(2,2)=a33
3812 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3813 C
3814 C               Third-order contributions
3815 C
3816 C                 (i+2)o----(i+3)
3817 C                      | |
3818 C                      | |
3819 C                 (i+1)o----i
3820 C
3821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3822 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3823         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3824         call transpose2(auxmat(1,1),auxmat1(1,1))
3825         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3826         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3827         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3828      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3829 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3830 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3831 cd     &    ' eello_turn3_num',4*eello_turn3_num
3832 C Derivatives in gamma(i)
3833         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3834         call transpose2(auxmat2(1,1),auxmat3(1,1))
3835         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3836         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3837 C Derivatives in gamma(i+1)
3838         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3839         call transpose2(auxmat2(1,1),auxmat3(1,1))
3840         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3841         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3842      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3843 C Cartesian derivatives
3844         do l=1,3
3845 c            ghalf1=0.5d0*agg(l,1)
3846 c            ghalf2=0.5d0*agg(l,2)
3847 c            ghalf3=0.5d0*agg(l,3)
3848 c            ghalf4=0.5d0*agg(l,4)
3849           a_temp(1,1)=aggi(l,1)!+ghalf1
3850           a_temp(1,2)=aggi(l,2)!+ghalf2
3851           a_temp(2,1)=aggi(l,3)!+ghalf3
3852           a_temp(2,2)=aggi(l,4)!+ghalf4
3853           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3854           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3855      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3856           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3857           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3858           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3859           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3860           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3861           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3862      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3863           a_temp(1,1)=aggj(l,1)!+ghalf1
3864           a_temp(1,2)=aggj(l,2)!+ghalf2
3865           a_temp(2,1)=aggj(l,3)!+ghalf3
3866           a_temp(2,2)=aggj(l,4)!+ghalf4
3867           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3868           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3869      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3870           a_temp(1,1)=aggj1(l,1)
3871           a_temp(1,2)=aggj1(l,2)
3872           a_temp(2,1)=aggj1(l,3)
3873           a_temp(2,2)=aggj1(l,4)
3874           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3875           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3876      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3877         enddo
3878       return
3879       end
3880 C-------------------------------------------------------------------------------
3881       subroutine eturn4(i,eello_turn4)
3882 C Third- and fourth-order contributions from turns
3883       implicit real*8 (a-h,o-z)
3884       include 'DIMENSIONS'
3885       include 'COMMON.IOUNITS'
3886       include 'COMMON.GEO'
3887       include 'COMMON.VAR'
3888       include 'COMMON.LOCAL'
3889       include 'COMMON.CHAIN'
3890       include 'COMMON.DERIV'
3891       include 'COMMON.INTERACT'
3892       include 'COMMON.CONTACTS'
3893       include 'COMMON.TORSION'
3894       include 'COMMON.VECTORS'
3895       include 'COMMON.FFIELD'
3896       include 'COMMON.CONTROL'
3897       dimension ggg(3)
3898       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3899      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3900      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3901       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3902      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3903       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3904      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3905      &    num_conti,j1,j2
3906       j=i+3
3907 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3908 C
3909 C               Fourth-order contributions
3910 C
3911 C                 (i+3)o----(i+4)
3912 C                     /  |
3913 C               (i+2)o   |
3914 C                     \  |
3915 C                 (i+1)o----i
3916 C
3917 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3918 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3919 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3920         a_temp(1,1)=a22
3921         a_temp(1,2)=a23
3922         a_temp(2,1)=a32
3923         a_temp(2,2)=a33
3924         iti1=itortyp(itype(i+1))
3925         iti2=itortyp(itype(i+2))
3926         iti3=itortyp(itype(i+3))
3927 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3928         call transpose2(EUg(1,1,i+1),e1t(1,1))
3929         call transpose2(Eug(1,1,i+2),e2t(1,1))
3930         call transpose2(Eug(1,1,i+3),e3t(1,1))
3931         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3932         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3933         s1=scalar2(b1(1,iti2),auxvec(1))
3934         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3935         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3936         s2=scalar2(b1(1,iti1),auxvec(1))
3937         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3938         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3939         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3940         eello_turn4=eello_turn4-(s1+s2+s3)
3941 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3942         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3943      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3944 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3945 cd     &    ' eello_turn4_num',8*eello_turn4_num
3946 C Derivatives in gamma(i)
3947         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3948         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3949         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3950         s1=scalar2(b1(1,iti2),auxvec(1))
3951         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3952         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3953         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3954 C Derivatives in gamma(i+1)
3955         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3956         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3957         s2=scalar2(b1(1,iti1),auxvec(1))
3958         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3959         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3960         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3961         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3962 C Derivatives in gamma(i+2)
3963         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3964         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3965         s1=scalar2(b1(1,iti2),auxvec(1))
3966         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3967         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3968         s2=scalar2(b1(1,iti1),auxvec(1))
3969         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3970         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3971         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3972         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3973 C Cartesian derivatives
3974 C Derivatives of this turn contributions in DC(i+2)
3975         if (j.lt.nres-1) then
3976           do l=1,3
3977             a_temp(1,1)=agg(l,1)
3978             a_temp(1,2)=agg(l,2)
3979             a_temp(2,1)=agg(l,3)
3980             a_temp(2,2)=agg(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             ggg(l)=-(s1+s2+s3)
3991             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3992           enddo
3993         endif
3994 C Remaining derivatives of this turn contribution
3995         do l=1,3
3996           a_temp(1,1)=aggi(l,1)
3997           a_temp(1,2)=aggi(l,2)
3998           a_temp(2,1)=aggi(l,3)
3999           a_temp(2,2)=aggi(l,4)
4000           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4001           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4002           s1=scalar2(b1(1,iti2),auxvec(1))
4003           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4004           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4005           s2=scalar2(b1(1,iti1),auxvec(1))
4006           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4007           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4008           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4009           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4010           a_temp(1,1)=aggi1(l,1)
4011           a_temp(1,2)=aggi1(l,2)
4012           a_temp(2,1)=aggi1(l,3)
4013           a_temp(2,2)=aggi1(l,4)
4014           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4015           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4016           s1=scalar2(b1(1,iti2),auxvec(1))
4017           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4018           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4019           s2=scalar2(b1(1,iti1),auxvec(1))
4020           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4021           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4022           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4023           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4024           a_temp(1,1)=aggj(l,1)
4025           a_temp(1,2)=aggj(l,2)
4026           a_temp(2,1)=aggj(l,3)
4027           a_temp(2,2)=aggj(l,4)
4028           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4029           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4030           s1=scalar2(b1(1,iti2),auxvec(1))
4031           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4032           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4033           s2=scalar2(b1(1,iti1),auxvec(1))
4034           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4035           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4036           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4037           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4038           a_temp(1,1)=aggj1(l,1)
4039           a_temp(1,2)=aggj1(l,2)
4040           a_temp(2,1)=aggj1(l,3)
4041           a_temp(2,2)=aggj1(l,4)
4042           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4043           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4044           s1=scalar2(b1(1,iti2),auxvec(1))
4045           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4046           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4047           s2=scalar2(b1(1,iti1),auxvec(1))
4048           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4049           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4050           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4051 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4052           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4053         enddo
4054       return
4055       end
4056 C-----------------------------------------------------------------------------
4057       subroutine vecpr(u,v,w)
4058       implicit real*8(a-h,o-z)
4059       dimension u(3),v(3),w(3)
4060       w(1)=u(2)*v(3)-u(3)*v(2)
4061       w(2)=-u(1)*v(3)+u(3)*v(1)
4062       w(3)=u(1)*v(2)-u(2)*v(1)
4063       return
4064       end
4065 C-----------------------------------------------------------------------------
4066       subroutine unormderiv(u,ugrad,unorm,ungrad)
4067 C This subroutine computes the derivatives of a normalized vector u, given
4068 C the derivatives computed without normalization conditions, ugrad. Returns
4069 C ungrad.
4070       implicit none
4071       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4072       double precision vec(3)
4073       double precision scalar
4074       integer i,j
4075 c      write (2,*) 'ugrad',ugrad
4076 c      write (2,*) 'u',u
4077       do i=1,3
4078         vec(i)=scalar(ugrad(1,i),u(1))
4079       enddo
4080 c      write (2,*) 'vec',vec
4081       do i=1,3
4082         do j=1,3
4083           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4084         enddo
4085       enddo
4086 c      write (2,*) 'ungrad',ungrad
4087       return
4088       end
4089 C-----------------------------------------------------------------------------
4090       subroutine escp_soft_sphere(evdw2,evdw2_14)
4091 C
4092 C This subroutine calculates the excluded-volume interaction energy between
4093 C peptide-group centers and side chains and its gradient in virtual-bond and
4094 C side-chain vectors.
4095 C
4096       implicit real*8 (a-h,o-z)
4097       include 'DIMENSIONS'
4098       include 'COMMON.GEO'
4099       include 'COMMON.VAR'
4100       include 'COMMON.LOCAL'
4101       include 'COMMON.CHAIN'
4102       include 'COMMON.DERIV'
4103       include 'COMMON.INTERACT'
4104       include 'COMMON.FFIELD'
4105       include 'COMMON.IOUNITS'
4106       include 'COMMON.CONTROL'
4107       dimension ggg(3)
4108       evdw2=0.0D0
4109       evdw2_14=0.0d0
4110       r0_scp=4.5d0
4111 cd    print '(a)','Enter ESCP'
4112 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4113       do xshift=-1,1
4114       do yshift=-1,1
4115       do zshift=-1,1
4116       do i=iatscp_s,iatscp_e
4117         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4118         iteli=itel(i)
4119         xi=0.5D0*(c(1,i)+c(1,i+1))
4120         yi=0.5D0*(c(2,i)+c(2,i+1))
4121         zi=0.5D0*(c(3,i)+c(3,i+1))
4122 C Return atom into box, boxxsize is size of box in x dimension
4123 c  134   continue
4124 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4125 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4126 C Condition for being inside the proper box
4127 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4128 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4129 c        go to 134
4130 c        endif
4131 c  135   continue
4132 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4133 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4134 C Condition for being inside the proper box
4135 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4136 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4137 c        go to 135
4138 c c       endif
4139 c  136   continue
4140 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4141 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4142 cC Condition for being inside the proper box
4143 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4144 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4145 c        go to 136
4146 c        endif
4147           xi=mod(xi,boxxsize)
4148           if (xi.lt.0) xi=xi+boxxsize
4149           yi=mod(yi,boxysize)
4150           if (yi.lt.0) yi=yi+boxysize
4151           zi=mod(zi,boxzsize)
4152           if (zi.lt.0) zi=zi+boxzsize
4153           xi=xi+xshift*boxxsize
4154           yi=yi+yshift*boxysize
4155           zi=zi+zshift*boxzsize
4156         do iint=1,nscp_gr(i)
4157
4158         do j=iscpstart(i,iint),iscpend(i,iint)
4159           if (itype(j).eq.ntyp1) cycle
4160           itypj=iabs(itype(j))
4161 C Uncomment following three lines for SC-p interactions
4162 c         xj=c(1,nres+j)-xi
4163 c         yj=c(2,nres+j)-yi
4164 c         zj=c(3,nres+j)-zi
4165 C Uncomment following three lines for Ca-p interactions
4166           xj=c(1,j)
4167           yj=c(2,j)
4168           zj=c(3,j)
4169 c  174   continue
4170 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4171 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4172 C Condition for being inside the proper box
4173 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4174 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4175 c        go to 174
4176 c        endif
4177 c  175   continue
4178 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4179 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4180 cC Condition for being inside the proper box
4181 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4182 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4183 c        go to 175
4184 c        endif
4185 c  176   continue
4186 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4187 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4188 C Condition for being inside the proper box
4189 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4190 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4191 c        go to 176
4192           xj=mod(xj,boxxsize)
4193           if (xj.lt.0) xj=xj+boxxsize
4194           yj=mod(yj,boxysize)
4195           if (yj.lt.0) yj=yj+boxysize
4196           zj=mod(zj,boxzsize)
4197           if (zj.lt.0) zj=zj+boxzsize
4198 c c       endif
4199           xj=xj-xi
4200           yj=yj-yi
4201           zj=zj-zi
4202           rij=xj*xj+yj*yj+zj*zj
4203
4204           r0ij=r0_scp
4205           r0ijsq=r0ij*r0ij
4206           if (rij.lt.r0ijsq) then
4207             evdwij=0.25d0*(rij-r0ijsq)**2
4208             fac=rij-r0ijsq
4209           else
4210             evdwij=0.0d0
4211             fac=0.0d0
4212           endif
4213           evdw2=evdw2+evdwij
4214 C
4215 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4216 C
4217           ggg(1)=xj*fac
4218           ggg(2)=yj*fac
4219           ggg(3)=zj*fac
4220 cgrad          if (j.lt.i) then
4221 cd          write (iout,*) 'j<i'
4222 C Uncomment following three lines for SC-p interactions
4223 c           do k=1,3
4224 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4225 c           enddo
4226 cgrad          else
4227 cd          write (iout,*) 'j>i'
4228 cgrad            do k=1,3
4229 cgrad              ggg(k)=-ggg(k)
4230 C Uncomment following line for SC-p interactions
4231 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4232 cgrad            enddo
4233 cgrad          endif
4234 cgrad          do k=1,3
4235 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4236 cgrad          enddo
4237 cgrad          kstart=min0(i+1,j)
4238 cgrad          kend=max0(i-1,j-1)
4239 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4240 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4241 cgrad          do k=kstart,kend
4242 cgrad            do l=1,3
4243 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4244 cgrad            enddo
4245 cgrad          enddo
4246           do k=1,3
4247             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4248             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4249           enddo
4250         enddo
4251
4252         enddo ! iint
4253       enddo ! i
4254       enddo !zshift
4255       enddo !yshift
4256       enddo !xshift
4257       return
4258       end
4259 C-----------------------------------------------------------------------------
4260       subroutine escp(evdw2,evdw2_14)
4261 C
4262 C This subroutine calculates the excluded-volume interaction energy between
4263 C peptide-group centers and side chains and its gradient in virtual-bond and
4264 C side-chain vectors.
4265 C
4266       implicit real*8 (a-h,o-z)
4267       include 'DIMENSIONS'
4268       include 'COMMON.GEO'
4269       include 'COMMON.VAR'
4270       include 'COMMON.LOCAL'
4271       include 'COMMON.CHAIN'
4272       include 'COMMON.DERIV'
4273       include 'COMMON.INTERACT'
4274       include 'COMMON.FFIELD'
4275       include 'COMMON.IOUNITS'
4276       include 'COMMON.CONTROL'
4277       include 'COMMON.SPLITELE'
4278       dimension ggg(3)
4279       evdw2=0.0D0
4280       evdw2_14=0.0d0
4281 cd    print '(a)','Enter ESCP'
4282 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4283       do xshift=-1,1
4284       do yshift=-1,1
4285       do zshift=-1,1
4286       do i=iatscp_s,iatscp_e
4287         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4288         iteli=itel(i)
4289         xi=0.5D0*(c(1,i)+c(1,i+1))
4290         yi=0.5D0*(c(2,i)+c(2,i+1))
4291         zi=0.5D0*(c(3,i)+c(3,i+1))
4292           xi=mod(xi,boxxsize)
4293           if (xi.lt.0) xi=xi+boxxsize
4294           yi=mod(yi,boxysize)
4295           if (yi.lt.0) yi=yi+boxysize
4296           zi=mod(zi,boxzsize)
4297           if (zi.lt.0) zi=zi+boxzsize
4298           xi=xi+xshift*boxxsize
4299           yi=yi+yshift*boxysize
4300           zi=zi+zshift*boxzsize
4301 C Return atom into box, boxxsize is size of box in x dimension
4302 c  134   continue
4303 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4304 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4305 C Condition for being inside the proper box
4306 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4307 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4308 c        go to 134
4309 c        endif
4310 c  135   continue
4311 c          print *,xi,boxxsize,"pierwszy"
4312
4313 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4314 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4315 C Condition for being inside the proper box
4316 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4317 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4318 c        go to 135
4319 c        endif
4320 c  136   continue
4321 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4322 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4323 C Condition for being inside the proper box
4324 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4325 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4326 c        go to 136
4327 c        endif
4328         do iint=1,nscp_gr(i)
4329
4330         do j=iscpstart(i,iint),iscpend(i,iint)
4331           itypj=iabs(itype(j))
4332           if (itypj.eq.ntyp1) cycle
4333 C Uncomment following three lines for SC-p interactions
4334 c         xj=c(1,nres+j)-xi
4335 c         yj=c(2,nres+j)-yi
4336 c         zj=c(3,nres+j)-zi
4337 C Uncomment following three lines for Ca-p interactions
4338           xj=c(1,j)
4339           yj=c(2,j)
4340           zj=c(3,j)
4341           xj=mod(xj,boxxsize)
4342           if (xj.lt.0) xj=xj+boxxsize
4343           yj=mod(yj,boxysize)
4344           if (yj.lt.0) yj=yj+boxysize
4345           zj=mod(zj,boxzsize)
4346           if (zj.lt.0) zj=zj+boxzsize
4347 c  174   continue
4348 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4349 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4350 C Condition for being inside the proper box
4351 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4352 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4353 c        go to 174
4354 c        endif
4355 c  175   continue
4356 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4357 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4358 cC Condition for being inside the proper box
4359 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4360 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4361 c        go to 175
4362 c        endif
4363 c  176   continue
4364 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4365 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4366 C Condition for being inside the proper box
4367 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4368 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4369 c        go to 176
4370 c        endif
4371           xj=xj-xi
4372           yj=yj-yi
4373           zj=zj-zi
4374           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4375           sss=sscale(1.0d0/(dsqrt(rrij)))
4376           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4377           if (sss.gt.0.0d0) then
4378           fac=rrij**expon2
4379           e1=fac*fac*aad(itypj,iteli)
4380           e2=fac*bad(itypj,iteli)
4381           if (iabs(j-i) .le. 2) then
4382             e1=scal14*e1
4383             e2=scal14*e2
4384             evdw2_14=evdw2_14+(e1+e2)*sss
4385           endif
4386           evdwij=e1+e2
4387           evdw2=evdw2+evdwij*sss
4388           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4389      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4390      &       bad(itypj,iteli)
4391 C
4392 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4393 C
4394           fac=-(evdwij+e1)*rrij*sss
4395           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4396           ggg(1)=xj*fac
4397           ggg(2)=yj*fac
4398           ggg(3)=zj*fac
4399 cgrad          if (j.lt.i) then
4400 cd          write (iout,*) 'j<i'
4401 C Uncomment following three lines for SC-p interactions
4402 c           do k=1,3
4403 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4404 c           enddo
4405 cgrad          else
4406 cd          write (iout,*) 'j>i'
4407 cgrad            do k=1,3
4408 cgrad              ggg(k)=-ggg(k)
4409 C Uncomment following line for SC-p interactions
4410 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4411 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4412 cgrad            enddo
4413 cgrad          endif
4414 cgrad          do k=1,3
4415 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4416 cgrad          enddo
4417 cgrad          kstart=min0(i+1,j)
4418 cgrad          kend=max0(i-1,j-1)
4419 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4420 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4421 cgrad          do k=kstart,kend
4422 cgrad            do l=1,3
4423 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4424 cgrad            enddo
4425 cgrad          enddo
4426           do k=1,3
4427             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4428             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4429           enddo
4430         endif !endif for sscale cutoff
4431         enddo ! j
4432
4433         enddo ! iint
4434       enddo ! i
4435       enddo !zshift
4436       enddo !yshift
4437       enddo !xshift
4438       do i=1,nct
4439         do j=1,3
4440           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4441           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4442           gradx_scp(j,i)=expon*gradx_scp(j,i)
4443         enddo
4444       enddo
4445 C******************************************************************************
4446 C
4447 C                              N O T E !!!
4448 C
4449 C To save time the factor EXPON has been extracted from ALL components
4450 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4451 C use!
4452 C
4453 C******************************************************************************
4454       return
4455       end
4456 C--------------------------------------------------------------------------
4457       subroutine edis(ehpb)
4458 C
4459 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4460 C
4461       implicit real*8 (a-h,o-z)
4462       include 'DIMENSIONS'
4463       include 'COMMON.SBRIDGE'
4464       include 'COMMON.CHAIN'
4465       include 'COMMON.DERIV'
4466       include 'COMMON.VAR'
4467       include 'COMMON.INTERACT'
4468       include 'COMMON.IOUNITS'
4469       dimension ggg(3)
4470       ehpb=0.0D0
4471 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4472 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4473       if (link_end.eq.0) return
4474       do i=link_start,link_end
4475 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4476 C CA-CA distance used in regularization of structure.
4477         ii=ihpb(i)
4478         jj=jhpb(i)
4479 C iii and jjj point to the residues for which the distance is assigned.
4480         if (ii.gt.nres) then
4481           iii=ii-nres
4482           jjj=jj-nres
4483         else
4484           iii=ii
4485           jjj=jj
4486         endif
4487 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4488 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4489 C    distance and angle dependent SS bond potential.
4490         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4491      & iabs(itype(jjj)).eq.1) then
4492           call ssbond_ene(iii,jjj,eij)
4493           ehpb=ehpb+2*eij
4494 cd          write (iout,*) "eij",eij
4495         else
4496 C Calculate the distance between the two points and its difference from the
4497 C target distance.
4498         dd=dist(ii,jj)
4499         rdis=dd-dhpb(i)
4500 C Get the force constant corresponding to this distance.
4501         waga=forcon(i)
4502 C Calculate the contribution to energy.
4503         ehpb=ehpb+waga*rdis*rdis
4504 C
4505 C Evaluate gradient.
4506 C
4507         fac=waga*rdis/dd
4508 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4509 cd   &   ' waga=',waga,' fac=',fac
4510         do j=1,3
4511           ggg(j)=fac*(c(j,jj)-c(j,ii))
4512         enddo
4513 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4514 C If this is a SC-SC distance, we need to calculate the contributions to the
4515 C Cartesian gradient in the SC vectors (ghpbx).
4516         if (iii.lt.ii) then
4517           do j=1,3
4518             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4519             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4520           enddo
4521         endif
4522 cgrad        do j=iii,jjj-1
4523 cgrad          do k=1,3
4524 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4525 cgrad          enddo
4526 cgrad        enddo
4527         do k=1,3
4528           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4529           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4530         enddo
4531         endif
4532       enddo
4533       ehpb=0.5D0*ehpb
4534       return
4535       end
4536 C--------------------------------------------------------------------------
4537       subroutine ssbond_ene(i,j,eij)
4538 C
4539 C Calculate the distance and angle dependent SS-bond potential energy
4540 C using a free-energy function derived based on RHF/6-31G** ab initio
4541 C calculations of diethyl disulfide.
4542 C
4543 C A. Liwo and U. Kozlowska, 11/24/03
4544 C
4545       implicit real*8 (a-h,o-z)
4546       include 'DIMENSIONS'
4547       include 'COMMON.SBRIDGE'
4548       include 'COMMON.CHAIN'
4549       include 'COMMON.DERIV'
4550       include 'COMMON.LOCAL'
4551       include 'COMMON.INTERACT'
4552       include 'COMMON.VAR'
4553       include 'COMMON.IOUNITS'
4554       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4555       itypi=iabs(itype(i))
4556       xi=c(1,nres+i)
4557       yi=c(2,nres+i)
4558       zi=c(3,nres+i)
4559       dxi=dc_norm(1,nres+i)
4560       dyi=dc_norm(2,nres+i)
4561       dzi=dc_norm(3,nres+i)
4562 c      dsci_inv=dsc_inv(itypi)
4563       dsci_inv=vbld_inv(nres+i)
4564       itypj=iabs(itype(j))
4565 c      dscj_inv=dsc_inv(itypj)
4566       dscj_inv=vbld_inv(nres+j)
4567       xj=c(1,nres+j)-xi
4568       yj=c(2,nres+j)-yi
4569       zj=c(3,nres+j)-zi
4570       dxj=dc_norm(1,nres+j)
4571       dyj=dc_norm(2,nres+j)
4572       dzj=dc_norm(3,nres+j)
4573       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4574       rij=dsqrt(rrij)
4575       erij(1)=xj*rij
4576       erij(2)=yj*rij
4577       erij(3)=zj*rij
4578       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4579       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4580       om12=dxi*dxj+dyi*dyj+dzi*dzj
4581       do k=1,3
4582         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4583         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4584       enddo
4585       rij=1.0d0/rij
4586       deltad=rij-d0cm
4587       deltat1=1.0d0-om1
4588       deltat2=1.0d0+om2
4589       deltat12=om2-om1+2.0d0
4590       cosphi=om12-om1*om2
4591       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4592      &  +akct*deltad*deltat12
4593      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4594 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4595 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4596 c     &  " deltat12",deltat12," eij",eij
4597       ed=2*akcm*deltad+akct*deltat12
4598       pom1=akct*deltad
4599       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4600       eom1=-2*akth*deltat1-pom1-om2*pom2
4601       eom2= 2*akth*deltat2+pom1-om1*pom2
4602       eom12=pom2
4603       do k=1,3
4604         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4605         ghpbx(k,i)=ghpbx(k,i)-ggk
4606      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4607      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4608         ghpbx(k,j)=ghpbx(k,j)+ggk
4609      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4610      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4611         ghpbc(k,i)=ghpbc(k,i)-ggk
4612         ghpbc(k,j)=ghpbc(k,j)+ggk
4613       enddo
4614 C
4615 C Calculate the components of the gradient in DC and X
4616 C
4617 cgrad      do k=i,j-1
4618 cgrad        do l=1,3
4619 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4620 cgrad        enddo
4621 cgrad      enddo
4622       return
4623       end
4624 C--------------------------------------------------------------------------
4625       subroutine ebond(estr)
4626 c
4627 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4628 c
4629       implicit real*8 (a-h,o-z)
4630       include 'DIMENSIONS'
4631       include 'COMMON.LOCAL'
4632       include 'COMMON.GEO'
4633       include 'COMMON.INTERACT'
4634       include 'COMMON.DERIV'
4635       include 'COMMON.VAR'
4636       include 'COMMON.CHAIN'
4637       include 'COMMON.IOUNITS'
4638       include 'COMMON.NAMES'
4639       include 'COMMON.FFIELD'
4640       include 'COMMON.CONTROL'
4641       include 'COMMON.SETUP'
4642       double precision u(3),ud(3)
4643       estr=0.0d0
4644       estr1=0.0d0
4645       do i=ibondp_start,ibondp_end
4646         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4647 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4648 c          do j=1,3
4649 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4650 c     &      *dc(j,i-1)/vbld(i)
4651 c          enddo
4652 c          if (energy_dec) write(iout,*)
4653 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4654 c        else
4655 C       Checking if it involves dummy (NH3+ or COO-) group
4656          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4657 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4658         diff = vbld(i)-vbldpDUM
4659          else
4660 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4661         diff = vbld(i)-vbldp0
4662          endif
4663         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4664      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4665         estr=estr+diff*diff
4666         do j=1,3
4667           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4668         enddo
4669 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4670 c        endif
4671       enddo
4672       estr=0.5d0*AKP*estr+estr1
4673 c
4674 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4675 c
4676       do i=ibond_start,ibond_end
4677         iti=iabs(itype(i))
4678         if (iti.ne.10 .and. iti.ne.ntyp1) then
4679           nbi=nbondterm(iti)
4680           if (nbi.eq.1) then
4681             diff=vbld(i+nres)-vbldsc0(1,iti)
4682             if (energy_dec) write (iout,*)
4683      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4684      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4685             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4686             do j=1,3
4687               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4688             enddo
4689           else
4690             do j=1,nbi
4691               diff=vbld(i+nres)-vbldsc0(j,iti)
4692               ud(j)=aksc(j,iti)*diff
4693               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4694             enddo
4695             uprod=u(1)
4696             do j=2,nbi
4697               uprod=uprod*u(j)
4698             enddo
4699             usum=0.0d0
4700             usumsqder=0.0d0
4701             do j=1,nbi
4702               uprod1=1.0d0
4703               uprod2=1.0d0
4704               do k=1,nbi
4705                 if (k.ne.j) then
4706                   uprod1=uprod1*u(k)
4707                   uprod2=uprod2*u(k)*u(k)
4708                 endif
4709               enddo
4710               usum=usum+uprod1
4711               usumsqder=usumsqder+ud(j)*uprod2
4712             enddo
4713             estr=estr+uprod/usum
4714             do j=1,3
4715              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4716             enddo
4717           endif
4718         endif
4719       enddo
4720       return
4721       end
4722 #ifdef CRYST_THETA
4723 C--------------------------------------------------------------------------
4724       subroutine ebend(etheta)
4725 C
4726 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4727 C angles gamma and its derivatives in consecutive thetas and gammas.
4728 C
4729       implicit real*8 (a-h,o-z)
4730       include 'DIMENSIONS'
4731       include 'COMMON.LOCAL'
4732       include 'COMMON.GEO'
4733       include 'COMMON.INTERACT'
4734       include 'COMMON.DERIV'
4735       include 'COMMON.VAR'
4736       include 'COMMON.CHAIN'
4737       include 'COMMON.IOUNITS'
4738       include 'COMMON.NAMES'
4739       include 'COMMON.FFIELD'
4740       include 'COMMON.CONTROL'
4741       common /calcthet/ term1,term2,termm,diffak,ratak,
4742      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4743      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4744       double precision y(2),z(2)
4745       delta=0.02d0*pi
4746 c      time11=dexp(-2*time)
4747 c      time12=1.0d0
4748       etheta=0.0D0
4749 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4750       do i=ithet_start,ithet_end
4751         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4752      &  .or.itype(i).eq.ntyp1) cycle
4753 C Zero the energy function and its derivative at 0 or pi.
4754         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4755         it=itype(i-1)
4756         ichir1=isign(1,itype(i-2))
4757         ichir2=isign(1,itype(i))
4758          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4759          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4760          if (itype(i-1).eq.10) then
4761           itype1=isign(10,itype(i-2))
4762           ichir11=isign(1,itype(i-2))
4763           ichir12=isign(1,itype(i-2))
4764           itype2=isign(10,itype(i))
4765           ichir21=isign(1,itype(i))
4766           ichir22=isign(1,itype(i))
4767          endif
4768
4769         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4770 #ifdef OSF
4771           phii=phi(i)
4772           if (phii.ne.phii) phii=150.0
4773 #else
4774           phii=phi(i)
4775 #endif
4776           y(1)=dcos(phii)
4777           y(2)=dsin(phii)
4778         else
4779           y(1)=0.0D0
4780           y(2)=0.0D0
4781         endif
4782         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4783 #ifdef OSF
4784           phii1=phi(i+1)
4785           if (phii1.ne.phii1) phii1=150.0
4786           phii1=pinorm(phii1)
4787           z(1)=cos(phii1)
4788 #else
4789           phii1=phi(i+1)
4790 #endif
4791           z(1)=dcos(phii1)
4792           z(2)=dsin(phii1)
4793         else
4794           z(1)=0.0D0
4795           z(2)=0.0D0
4796         endif
4797 C Calculate the "mean" value of theta from the part of the distribution
4798 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4799 C In following comments this theta will be referred to as t_c.
4800         thet_pred_mean=0.0d0
4801         do k=1,2
4802             athetk=athet(k,it,ichir1,ichir2)
4803             bthetk=bthet(k,it,ichir1,ichir2)
4804           if (it.eq.10) then
4805              athetk=athet(k,itype1,ichir11,ichir12)
4806              bthetk=bthet(k,itype2,ichir21,ichir22)
4807           endif
4808          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4809 c         write(iout,*) 'chuj tu', y(k),z(k)
4810         enddo
4811         dthett=thet_pred_mean*ssd
4812         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4813 C Derivatives of the "mean" values in gamma1 and gamma2.
4814         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4815      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4816          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4817      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4818          if (it.eq.10) then
4819       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4820      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4821         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4822      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4823          endif
4824         if (theta(i).gt.pi-delta) then
4825           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4826      &         E_tc0)
4827           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4828           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4829           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4830      &        E_theta)
4831           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4832      &        E_tc)
4833         else if (theta(i).lt.delta) then
4834           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4835           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4836           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4837      &        E_theta)
4838           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4839           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4840      &        E_tc)
4841         else
4842           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4843      &        E_theta,E_tc)
4844         endif
4845         etheta=etheta+ethetai
4846         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4847      &      'ebend',i,ethetai,theta(i),itype(i)
4848         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4849         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4850         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4851       enddo
4852 C Ufff.... We've done all this!!!
4853       return
4854       end
4855 C---------------------------------------------------------------------------
4856       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4857      &     E_tc)
4858       implicit real*8 (a-h,o-z)
4859       include 'DIMENSIONS'
4860       include 'COMMON.LOCAL'
4861       include 'COMMON.IOUNITS'
4862       common /calcthet/ term1,term2,termm,diffak,ratak,
4863      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4864      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4865 C Calculate the contributions to both Gaussian lobes.
4866 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4867 C The "polynomial part" of the "standard deviation" of this part of
4868 C the distributioni.
4869 ccc        write (iout,*) thetai,thet_pred_mean
4870         sig=polthet(3,it)
4871         do j=2,0,-1
4872           sig=sig*thet_pred_mean+polthet(j,it)
4873         enddo
4874 C Derivative of the "interior part" of the "standard deviation of the"
4875 C gamma-dependent Gaussian lobe in t_c.
4876         sigtc=3*polthet(3,it)
4877         do j=2,1,-1
4878           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4879         enddo
4880         sigtc=sig*sigtc
4881 C Set the parameters of both Gaussian lobes of the distribution.
4882 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4883         fac=sig*sig+sigc0(it)
4884         sigcsq=fac+fac
4885         sigc=1.0D0/sigcsq
4886 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4887         sigsqtc=-4.0D0*sigcsq*sigtc
4888 c       print *,i,sig,sigtc,sigsqtc
4889 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4890         sigtc=-sigtc/(fac*fac)
4891 C Following variable is sigma(t_c)**(-2)
4892         sigcsq=sigcsq*sigcsq
4893         sig0i=sig0(it)
4894         sig0inv=1.0D0/sig0i**2
4895         delthec=thetai-thet_pred_mean
4896         delthe0=thetai-theta0i
4897         term1=-0.5D0*sigcsq*delthec*delthec
4898         term2=-0.5D0*sig0inv*delthe0*delthe0
4899 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
4900 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4901 C NaNs in taking the logarithm. We extract the largest exponent which is added
4902 C to the energy (this being the log of the distribution) at the end of energy
4903 C term evaluation for this virtual-bond angle.
4904         if (term1.gt.term2) then
4905           termm=term1
4906           term2=dexp(term2-termm)
4907           term1=1.0d0
4908         else
4909           termm=term2
4910           term1=dexp(term1-termm)
4911           term2=1.0d0
4912         endif
4913 C The ratio between the gamma-independent and gamma-dependent lobes of
4914 C the distribution is a Gaussian function of thet_pred_mean too.
4915         diffak=gthet(2,it)-thet_pred_mean
4916         ratak=diffak/gthet(3,it)**2
4917         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4918 C Let's differentiate it in thet_pred_mean NOW.
4919         aktc=ak*ratak
4920 C Now put together the distribution terms to make complete distribution.
4921         termexp=term1+ak*term2
4922         termpre=sigc+ak*sig0i
4923 C Contribution of the bending energy from this theta is just the -log of
4924 C the sum of the contributions from the two lobes and the pre-exponential
4925 C factor. Simple enough, isn't it?
4926         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4927 C       write (iout,*) 'termexp',termexp,termm,termpre,i
4928 C NOW the derivatives!!!
4929 C 6/6/97 Take into account the deformation.
4930         E_theta=(delthec*sigcsq*term1
4931      &       +ak*delthe0*sig0inv*term2)/termexp
4932         E_tc=((sigtc+aktc*sig0i)/termpre
4933      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4934      &       aktc*term2)/termexp)
4935       return
4936       end
4937 c-----------------------------------------------------------------------------
4938       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4939       implicit real*8 (a-h,o-z)
4940       include 'DIMENSIONS'
4941       include 'COMMON.LOCAL'
4942       include 'COMMON.IOUNITS'
4943       common /calcthet/ term1,term2,termm,diffak,ratak,
4944      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4945      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4946       delthec=thetai-thet_pred_mean
4947       delthe0=thetai-theta0i
4948 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4949       t3 = thetai-thet_pred_mean
4950       t6 = t3**2
4951       t9 = term1
4952       t12 = t3*sigcsq
4953       t14 = t12+t6*sigsqtc
4954       t16 = 1.0d0
4955       t21 = thetai-theta0i
4956       t23 = t21**2
4957       t26 = term2
4958       t27 = t21*t26
4959       t32 = termexp
4960       t40 = t32**2
4961       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4962      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4963      & *(-t12*t9-ak*sig0inv*t27)
4964       return
4965       end
4966 #else
4967 C--------------------------------------------------------------------------
4968       subroutine ebend(etheta)
4969 C
4970 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4971 C angles gamma and its derivatives in consecutive thetas and gammas.
4972 C ab initio-derived potentials from
4973 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4974 C
4975       implicit real*8 (a-h,o-z)
4976       include 'DIMENSIONS'
4977       include 'COMMON.LOCAL'
4978       include 'COMMON.GEO'
4979       include 'COMMON.INTERACT'
4980       include 'COMMON.DERIV'
4981       include 'COMMON.VAR'
4982       include 'COMMON.CHAIN'
4983       include 'COMMON.IOUNITS'
4984       include 'COMMON.NAMES'
4985       include 'COMMON.FFIELD'
4986       include 'COMMON.CONTROL'
4987       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4988      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4989      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4990      & sinph1ph2(maxdouble,maxdouble)
4991       logical lprn /.false./, lprn1 /.false./
4992       etheta=0.0D0
4993       do i=ithet_start,ithet_end
4994 c        print *,i,itype(i-1),itype(i),itype(i-2)
4995         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4996      &  .or.itype(i).eq.ntyp1) cycle
4997 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4998
4999         if (iabs(itype(i+1)).eq.20) iblock=2
5000         if (iabs(itype(i+1)).ne.20) iblock=1
5001         dethetai=0.0d0
5002         dephii=0.0d0
5003         dephii1=0.0d0
5004         theti2=0.5d0*theta(i)
5005         ityp2=ithetyp((itype(i-1)))
5006         do k=1,nntheterm
5007           coskt(k)=dcos(k*theti2)
5008           sinkt(k)=dsin(k*theti2)
5009         enddo
5010         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5011 #ifdef OSF
5012           phii=phi(i)
5013           if (phii.ne.phii) phii=150.0
5014 #else
5015           phii=phi(i)
5016 #endif
5017           ityp1=ithetyp((itype(i-2)))
5018 C propagation of chirality for glycine type
5019           do k=1,nsingle
5020             cosph1(k)=dcos(k*phii)
5021             sinph1(k)=dsin(k*phii)
5022           enddo
5023         else
5024           phii=0.0d0
5025           ityp1=nthetyp+1
5026           do k=1,nsingle
5027             cosph1(k)=0.0d0
5028             sinph1(k)=0.0d0
5029           enddo
5030         endif
5031         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5032 #ifdef OSF
5033           phii1=phi(i+1)
5034           if (phii1.ne.phii1) phii1=150.0
5035           phii1=pinorm(phii1)
5036 #else
5037           phii1=phi(i+1)
5038 #endif
5039           ityp3=ithetyp((itype(i)))
5040           do k=1,nsingle
5041             cosph2(k)=dcos(k*phii1)
5042             sinph2(k)=dsin(k*phii1)
5043           enddo
5044         else
5045           phii1=0.0d0
5046           ityp3=nthetyp+1
5047           do k=1,nsingle
5048             cosph2(k)=0.0d0
5049             sinph2(k)=0.0d0
5050           enddo
5051         endif
5052         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5053         do k=1,ndouble
5054           do l=1,k-1
5055             ccl=cosph1(l)*cosph2(k-l)
5056             ssl=sinph1(l)*sinph2(k-l)
5057             scl=sinph1(l)*cosph2(k-l)
5058             csl=cosph1(l)*sinph2(k-l)
5059             cosph1ph2(l,k)=ccl-ssl
5060             cosph1ph2(k,l)=ccl+ssl
5061             sinph1ph2(l,k)=scl+csl
5062             sinph1ph2(k,l)=scl-csl
5063           enddo
5064         enddo
5065         if (lprn) then
5066         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5067      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5068         write (iout,*) "coskt and sinkt"
5069         do k=1,nntheterm
5070           write (iout,*) k,coskt(k),sinkt(k)
5071         enddo
5072         endif
5073         do k=1,ntheterm
5074           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5075           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5076      &      *coskt(k)
5077           if (lprn)
5078      &    write (iout,*) "k",k,"
5079      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5080      &     " ethetai",ethetai
5081         enddo
5082         if (lprn) then
5083         write (iout,*) "cosph and sinph"
5084         do k=1,nsingle
5085           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5086         enddo
5087         write (iout,*) "cosph1ph2 and sinph2ph2"
5088         do k=2,ndouble
5089           do l=1,k-1
5090             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5091      &         sinph1ph2(l,k),sinph1ph2(k,l)
5092           enddo
5093         enddo
5094         write(iout,*) "ethetai",ethetai
5095         endif
5096         do m=1,ntheterm2
5097           do k=1,nsingle
5098             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5099      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5100      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5101      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5102             ethetai=ethetai+sinkt(m)*aux
5103             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5104             dephii=dephii+k*sinkt(m)*(
5105      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5106      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5107             dephii1=dephii1+k*sinkt(m)*(
5108      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5109      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5110             if (lprn)
5111      &      write (iout,*) "m",m," k",k," bbthet",
5112      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5113      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5114      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5115      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5116           enddo
5117         enddo
5118         if (lprn)
5119      &  write(iout,*) "ethetai",ethetai
5120         do m=1,ntheterm3
5121           do k=2,ndouble
5122             do l=1,k-1
5123               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5124      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5125      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5126      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5127               ethetai=ethetai+sinkt(m)*aux
5128               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5129               dephii=dephii+l*sinkt(m)*(
5130      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5131      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5132      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5133      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5134               dephii1=dephii1+(k-l)*sinkt(m)*(
5135      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5136      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5137      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5138      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5139               if (lprn) then
5140               write (iout,*) "m",m," k",k," l",l," ffthet",
5141      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5142      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5143      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5144      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5145      &            " ethetai",ethetai
5146               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5147      &            cosph1ph2(k,l)*sinkt(m),
5148      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5149               endif
5150             enddo
5151           enddo
5152         enddo
5153 10      continue
5154 c        lprn1=.true.
5155         if (lprn1)
5156      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5157      &   i,theta(i)*rad2deg,phii*rad2deg,
5158      &   phii1*rad2deg,ethetai
5159 c        lprn1=.false.
5160         etheta=etheta+ethetai
5161         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5162         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5163         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5164       enddo
5165       return
5166       end
5167 #endif
5168 #ifdef CRYST_SC
5169 c-----------------------------------------------------------------------------
5170       subroutine esc(escloc)
5171 C Calculate the local energy of a side chain and its derivatives in the
5172 C corresponding virtual-bond valence angles THETA and the spherical angles
5173 C ALPHA and OMEGA.
5174       implicit real*8 (a-h,o-z)
5175       include 'DIMENSIONS'
5176       include 'COMMON.GEO'
5177       include 'COMMON.LOCAL'
5178       include 'COMMON.VAR'
5179       include 'COMMON.INTERACT'
5180       include 'COMMON.DERIV'
5181       include 'COMMON.CHAIN'
5182       include 'COMMON.IOUNITS'
5183       include 'COMMON.NAMES'
5184       include 'COMMON.FFIELD'
5185       include 'COMMON.CONTROL'
5186       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5187      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5188       common /sccalc/ time11,time12,time112,theti,it,nlobit
5189       delta=0.02d0*pi
5190       escloc=0.0D0
5191 c     write (iout,'(a)') 'ESC'
5192       do i=loc_start,loc_end
5193         it=itype(i)
5194         if (it.eq.ntyp1) cycle
5195         if (it.eq.10) goto 1
5196         nlobit=nlob(iabs(it))
5197 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5198 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5199         theti=theta(i+1)-pipol
5200         x(1)=dtan(theti)
5201         x(2)=alph(i)
5202         x(3)=omeg(i)
5203
5204         if (x(2).gt.pi-delta) then
5205           xtemp(1)=x(1)
5206           xtemp(2)=pi-delta
5207           xtemp(3)=x(3)
5208           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5209           xtemp(2)=pi
5210           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5211           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5212      &        escloci,dersc(2))
5213           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5214      &        ddersc0(1),dersc(1))
5215           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5216      &        ddersc0(3),dersc(3))
5217           xtemp(2)=pi-delta
5218           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5219           xtemp(2)=pi
5220           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5221           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5222      &            dersc0(2),esclocbi,dersc02)
5223           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5224      &            dersc12,dersc01)
5225           call splinthet(x(2),0.5d0*delta,ss,ssd)
5226           dersc0(1)=dersc01
5227           dersc0(2)=dersc02
5228           dersc0(3)=0.0d0
5229           do k=1,3
5230             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5231           enddo
5232           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5233 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5234 c    &             esclocbi,ss,ssd
5235           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5236 c         escloci=esclocbi
5237 c         write (iout,*) escloci
5238         else if (x(2).lt.delta) then
5239           xtemp(1)=x(1)
5240           xtemp(2)=delta
5241           xtemp(3)=x(3)
5242           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5243           xtemp(2)=0.0d0
5244           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5245           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5246      &        escloci,dersc(2))
5247           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5248      &        ddersc0(1),dersc(1))
5249           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5250      &        ddersc0(3),dersc(3))
5251           xtemp(2)=delta
5252           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5253           xtemp(2)=0.0d0
5254           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5255           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5256      &            dersc0(2),esclocbi,dersc02)
5257           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5258      &            dersc12,dersc01)
5259           dersc0(1)=dersc01
5260           dersc0(2)=dersc02
5261           dersc0(3)=0.0d0
5262           call splinthet(x(2),0.5d0*delta,ss,ssd)
5263           do k=1,3
5264             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5265           enddo
5266           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5267 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5268 c    &             esclocbi,ss,ssd
5269           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5270 c         write (iout,*) escloci
5271         else
5272           call enesc(x,escloci,dersc,ddummy,.false.)
5273         endif
5274
5275         escloc=escloc+escloci
5276         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5277      &     'escloc',i,escloci
5278 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5279
5280         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5281      &   wscloc*dersc(1)
5282         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5283         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5284     1   continue
5285       enddo
5286       return
5287       end
5288 C---------------------------------------------------------------------------
5289       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5290       implicit real*8 (a-h,o-z)
5291       include 'DIMENSIONS'
5292       include 'COMMON.GEO'
5293       include 'COMMON.LOCAL'
5294       include 'COMMON.IOUNITS'
5295       common /sccalc/ time11,time12,time112,theti,it,nlobit
5296       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5297       double precision contr(maxlob,-1:1)
5298       logical mixed
5299 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5300         escloc_i=0.0D0
5301         do j=1,3
5302           dersc(j)=0.0D0
5303           if (mixed) ddersc(j)=0.0d0
5304         enddo
5305         x3=x(3)
5306
5307 C Because of periodicity of the dependence of the SC energy in omega we have
5308 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5309 C To avoid underflows, first compute & store the exponents.
5310
5311         do iii=-1,1
5312
5313           x(3)=x3+iii*dwapi
5314
5315           do j=1,nlobit
5316             do k=1,3
5317               z(k)=x(k)-censc(k,j,it)
5318             enddo
5319             do k=1,3
5320               Axk=0.0D0
5321               do l=1,3
5322                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5323               enddo
5324               Ax(k,j,iii)=Axk
5325             enddo
5326             expfac=0.0D0
5327             do k=1,3
5328               expfac=expfac+Ax(k,j,iii)*z(k)
5329             enddo
5330             contr(j,iii)=expfac
5331           enddo ! j
5332
5333         enddo ! iii
5334
5335         x(3)=x3
5336 C As in the case of ebend, we want to avoid underflows in exponentiation and
5337 C subsequent NaNs and INFs in energy calculation.
5338 C Find the largest exponent
5339         emin=contr(1,-1)
5340         do iii=-1,1
5341           do j=1,nlobit
5342             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5343           enddo
5344         enddo
5345         emin=0.5D0*emin
5346 cd      print *,'it=',it,' emin=',emin
5347
5348 C Compute the contribution to SC energy and derivatives
5349         do iii=-1,1
5350
5351           do j=1,nlobit
5352 #ifdef OSF
5353             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5354             if(adexp.ne.adexp) adexp=1.0
5355             expfac=dexp(adexp)
5356 #else
5357             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5358 #endif
5359 cd          print *,'j=',j,' expfac=',expfac
5360             escloc_i=escloc_i+expfac
5361             do k=1,3
5362               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5363             enddo
5364             if (mixed) then
5365               do k=1,3,2
5366                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5367      &            +gaussc(k,2,j,it))*expfac
5368               enddo
5369             endif
5370           enddo
5371
5372         enddo ! iii
5373
5374         dersc(1)=dersc(1)/cos(theti)**2
5375         ddersc(1)=ddersc(1)/cos(theti)**2
5376         ddersc(3)=ddersc(3)
5377
5378         escloci=-(dlog(escloc_i)-emin)
5379         do j=1,3
5380           dersc(j)=dersc(j)/escloc_i
5381         enddo
5382         if (mixed) then
5383           do j=1,3,2
5384             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5385           enddo
5386         endif
5387       return
5388       end
5389 C------------------------------------------------------------------------------
5390       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5391       implicit real*8 (a-h,o-z)
5392       include 'DIMENSIONS'
5393       include 'COMMON.GEO'
5394       include 'COMMON.LOCAL'
5395       include 'COMMON.IOUNITS'
5396       common /sccalc/ time11,time12,time112,theti,it,nlobit
5397       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5398       double precision contr(maxlob)
5399       logical mixed
5400
5401       escloc_i=0.0D0
5402
5403       do j=1,3
5404         dersc(j)=0.0D0
5405       enddo
5406
5407       do j=1,nlobit
5408         do k=1,2
5409           z(k)=x(k)-censc(k,j,it)
5410         enddo
5411         z(3)=dwapi
5412         do k=1,3
5413           Axk=0.0D0
5414           do l=1,3
5415             Axk=Axk+gaussc(l,k,j,it)*z(l)
5416           enddo
5417           Ax(k,j)=Axk
5418         enddo
5419         expfac=0.0D0
5420         do k=1,3
5421           expfac=expfac+Ax(k,j)*z(k)
5422         enddo
5423         contr(j)=expfac
5424       enddo ! j
5425
5426 C As in the case of ebend, we want to avoid underflows in exponentiation and
5427 C subsequent NaNs and INFs in energy calculation.
5428 C Find the largest exponent
5429       emin=contr(1)
5430       do j=1,nlobit
5431         if (emin.gt.contr(j)) emin=contr(j)
5432       enddo
5433       emin=0.5D0*emin
5434
5435 C Compute the contribution to SC energy and derivatives
5436
5437       dersc12=0.0d0
5438       do j=1,nlobit
5439         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5440         escloc_i=escloc_i+expfac
5441         do k=1,2
5442           dersc(k)=dersc(k)+Ax(k,j)*expfac
5443         enddo
5444         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5445      &            +gaussc(1,2,j,it))*expfac
5446         dersc(3)=0.0d0
5447       enddo
5448
5449       dersc(1)=dersc(1)/cos(theti)**2
5450       dersc12=dersc12/cos(theti)**2
5451       escloci=-(dlog(escloc_i)-emin)
5452       do j=1,2
5453         dersc(j)=dersc(j)/escloc_i
5454       enddo
5455       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5456       return
5457       end
5458 #else
5459 c----------------------------------------------------------------------------------
5460       subroutine esc(escloc)
5461 C Calculate the local energy of a side chain and its derivatives in the
5462 C corresponding virtual-bond valence angles THETA and the spherical angles
5463 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5464 C added by Urszula Kozlowska. 07/11/2007
5465 C
5466       implicit real*8 (a-h,o-z)
5467       include 'DIMENSIONS'
5468       include 'COMMON.GEO'
5469       include 'COMMON.LOCAL'
5470       include 'COMMON.VAR'
5471       include 'COMMON.SCROT'
5472       include 'COMMON.INTERACT'
5473       include 'COMMON.DERIV'
5474       include 'COMMON.CHAIN'
5475       include 'COMMON.IOUNITS'
5476       include 'COMMON.NAMES'
5477       include 'COMMON.FFIELD'
5478       include 'COMMON.CONTROL'
5479       include 'COMMON.VECTORS'
5480       double precision x_prime(3),y_prime(3),z_prime(3)
5481      &    , sumene,dsc_i,dp2_i,x(65),
5482      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5483      &    de_dxx,de_dyy,de_dzz,de_dt
5484       double precision s1_t,s1_6_t,s2_t,s2_6_t
5485       double precision
5486      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5487      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5488      & dt_dCi(3),dt_dCi1(3)
5489       common /sccalc/ time11,time12,time112,theti,it,nlobit
5490       delta=0.02d0*pi
5491       escloc=0.0D0
5492       do i=loc_start,loc_end
5493         if (itype(i).eq.ntyp1) cycle
5494         costtab(i+1) =dcos(theta(i+1))
5495         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5496         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5497         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5498         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5499         cosfac=dsqrt(cosfac2)
5500         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5501         sinfac=dsqrt(sinfac2)
5502         it=iabs(itype(i))
5503         if (it.eq.10) goto 1
5504 c
5505 C  Compute the axes of tghe local cartesian coordinates system; store in
5506 c   x_prime, y_prime and z_prime
5507 c
5508         do j=1,3
5509           x_prime(j) = 0.00
5510           y_prime(j) = 0.00
5511           z_prime(j) = 0.00
5512         enddo
5513 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5514 C     &   dc_norm(3,i+nres)
5515         do j = 1,3
5516           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5517           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5518         enddo
5519         do j = 1,3
5520           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5521         enddo
5522 c       write (2,*) "i",i
5523 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5524 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5525 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5526 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5527 c      & " xy",scalar(x_prime(1),y_prime(1)),
5528 c      & " xz",scalar(x_prime(1),z_prime(1)),
5529 c      & " yy",scalar(y_prime(1),y_prime(1)),
5530 c      & " yz",scalar(y_prime(1),z_prime(1)),
5531 c      & " zz",scalar(z_prime(1),z_prime(1))
5532 c
5533 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5534 C to local coordinate system. Store in xx, yy, zz.
5535 c
5536         xx=0.0d0
5537         yy=0.0d0
5538         zz=0.0d0
5539         do j = 1,3
5540           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5541           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5542           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5543         enddo
5544
5545         xxtab(i)=xx
5546         yytab(i)=yy
5547         zztab(i)=zz
5548 C
5549 C Compute the energy of the ith side cbain
5550 C
5551 c        write (2,*) "xx",xx," yy",yy," zz",zz
5552         it=iabs(itype(i))
5553         do j = 1,65
5554           x(j) = sc_parmin(j,it)
5555         enddo
5556 #ifdef CHECK_COORD
5557 Cc diagnostics - remove later
5558         xx1 = dcos(alph(2))
5559         yy1 = dsin(alph(2))*dcos(omeg(2))
5560         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5561         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5562      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5563      &    xx1,yy1,zz1
5564 C,"  --- ", xx_w,yy_w,zz_w
5565 c end diagnostics
5566 #endif
5567         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5568      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5569      &   + x(10)*yy*zz
5570         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5571      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5572      & + x(20)*yy*zz
5573         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5574      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5575      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5576      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5577      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5578      &  +x(40)*xx*yy*zz
5579         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5580      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5581      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5582      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5583      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5584      &  +x(60)*xx*yy*zz
5585         dsc_i   = 0.743d0+x(61)
5586         dp2_i   = 1.9d0+x(62)
5587         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5588      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5589         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5590      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5591         s1=(1+x(63))/(0.1d0 + dscp1)
5592         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5593         s2=(1+x(65))/(0.1d0 + dscp2)
5594         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5595         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5596      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5597 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5598 c     &   sumene4,
5599 c     &   dscp1,dscp2,sumene
5600 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5601         escloc = escloc + sumene
5602 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5603 c     & ,zz,xx,yy
5604 c#define DEBUG
5605 #ifdef DEBUG
5606 C
5607 C This section to check the numerical derivatives of the energy of ith side
5608 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5609 C #define DEBUG in the code to turn it on.
5610 C
5611         write (2,*) "sumene               =",sumene
5612         aincr=1.0d-7
5613         xxsave=xx
5614         xx=xx+aincr
5615         write (2,*) xx,yy,zz
5616         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5617         de_dxx_num=(sumenep-sumene)/aincr
5618         xx=xxsave
5619         write (2,*) "xx+ sumene from enesc=",sumenep
5620         yysave=yy
5621         yy=yy+aincr
5622         write (2,*) xx,yy,zz
5623         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5624         de_dyy_num=(sumenep-sumene)/aincr
5625         yy=yysave
5626         write (2,*) "yy+ sumene from enesc=",sumenep
5627         zzsave=zz
5628         zz=zz+aincr
5629         write (2,*) xx,yy,zz
5630         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5631         de_dzz_num=(sumenep-sumene)/aincr
5632         zz=zzsave
5633         write (2,*) "zz+ sumene from enesc=",sumenep
5634         costsave=cost2tab(i+1)
5635         sintsave=sint2tab(i+1)
5636         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5637         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5638         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5639         de_dt_num=(sumenep-sumene)/aincr
5640         write (2,*) " t+ sumene from enesc=",sumenep
5641         cost2tab(i+1)=costsave
5642         sint2tab(i+1)=sintsave
5643 C End of diagnostics section.
5644 #endif
5645 C
5646 C Compute the gradient of esc
5647 C
5648 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5649         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5650         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5651         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5652         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5653         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5654         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5655         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5656         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5657         pom1=(sumene3*sint2tab(i+1)+sumene1)
5658      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5659         pom2=(sumene4*cost2tab(i+1)+sumene2)
5660      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5661         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5662         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5663      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5664      &  +x(40)*yy*zz
5665         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5666         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5667      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5668      &  +x(60)*yy*zz
5669         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5670      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5671      &        +(pom1+pom2)*pom_dx
5672 #ifdef DEBUG
5673         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5674 #endif
5675 C
5676         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5677         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5678      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5679      &  +x(40)*xx*zz
5680         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5681         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5682      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5683      &  +x(59)*zz**2 +x(60)*xx*zz
5684         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5685      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5686      &        +(pom1-pom2)*pom_dy
5687 #ifdef DEBUG
5688         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5689 #endif
5690 C
5691         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5692      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5693      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5694      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5695      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5696      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5697      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5698      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5699 #ifdef DEBUG
5700         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5701 #endif
5702 C
5703         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5704      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5705      &  +pom1*pom_dt1+pom2*pom_dt2
5706 #ifdef DEBUG
5707         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5708 #endif
5709 c#undef DEBUG
5710 c
5711 C
5712        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5713        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5714        cosfac2xx=cosfac2*xx
5715        sinfac2yy=sinfac2*yy
5716        do k = 1,3
5717          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5718      &      vbld_inv(i+1)
5719          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5720      &      vbld_inv(i)
5721          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5722          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5723 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5724 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5725 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5726 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5727          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5728          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5729          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5730          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5731          dZZ_Ci1(k)=0.0d0
5732          dZZ_Ci(k)=0.0d0
5733          do j=1,3
5734            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5735      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5736            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5737      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5738          enddo
5739
5740          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5741          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5742          dZZ_XYZ(k)=vbld_inv(i+nres)*
5743      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5744 c
5745          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5746          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5747        enddo
5748
5749        do k=1,3
5750          dXX_Ctab(k,i)=dXX_Ci(k)
5751          dXX_C1tab(k,i)=dXX_Ci1(k)
5752          dYY_Ctab(k,i)=dYY_Ci(k)
5753          dYY_C1tab(k,i)=dYY_Ci1(k)
5754          dZZ_Ctab(k,i)=dZZ_Ci(k)
5755          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5756          dXX_XYZtab(k,i)=dXX_XYZ(k)
5757          dYY_XYZtab(k,i)=dYY_XYZ(k)
5758          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5759        enddo
5760
5761        do k = 1,3
5762 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5763 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5764 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5765 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5766 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5767 c     &    dt_dci(k)
5768 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5769 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5770          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5771      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5772          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5773      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5774          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5775      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5776        enddo
5777 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5778 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5779
5780 C to check gradient call subroutine check_grad
5781
5782     1 continue
5783       enddo
5784       return
5785       end
5786 c------------------------------------------------------------------------------
5787       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5788       implicit none
5789       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5790      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5791       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5792      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5793      &   + x(10)*yy*zz
5794       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5795      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5796      & + x(20)*yy*zz
5797       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5798      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5799      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5800      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5801      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5802      &  +x(40)*xx*yy*zz
5803       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5804      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5805      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5806      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5807      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5808      &  +x(60)*xx*yy*zz
5809       dsc_i   = 0.743d0+x(61)
5810       dp2_i   = 1.9d0+x(62)
5811       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5812      &          *(xx*cost2+yy*sint2))
5813       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5814      &          *(xx*cost2-yy*sint2))
5815       s1=(1+x(63))/(0.1d0 + dscp1)
5816       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5817       s2=(1+x(65))/(0.1d0 + dscp2)
5818       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5819       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5820      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5821       enesc=sumene
5822       return
5823       end
5824 #endif
5825 c------------------------------------------------------------------------------
5826       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5827 C
5828 C This procedure calculates two-body contact function g(rij) and its derivative:
5829 C
5830 C           eps0ij                                     !       x < -1
5831 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5832 C            0                                         !       x > 1
5833 C
5834 C where x=(rij-r0ij)/delta
5835 C
5836 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5837 C
5838       implicit none
5839       double precision rij,r0ij,eps0ij,fcont,fprimcont
5840       double precision x,x2,x4,delta
5841 c     delta=0.02D0*r0ij
5842 c      delta=0.2D0*r0ij
5843       x=(rij-r0ij)/delta
5844       if (x.lt.-1.0D0) then
5845         fcont=eps0ij
5846         fprimcont=0.0D0
5847       else if (x.le.1.0D0) then
5848         x2=x*x
5849         x4=x2*x2
5850         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5851         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5852       else
5853         fcont=0.0D0
5854         fprimcont=0.0D0
5855       endif
5856       return
5857       end
5858 c------------------------------------------------------------------------------
5859       subroutine splinthet(theti,delta,ss,ssder)
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'COMMON.VAR'
5863       include 'COMMON.GEO'
5864       thetup=pi-delta
5865       thetlow=delta
5866       if (theti.gt.pipol) then
5867         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5868       else
5869         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5870         ssder=-ssder
5871       endif
5872       return
5873       end
5874 c------------------------------------------------------------------------------
5875       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5876       implicit none
5877       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5878       double precision ksi,ksi2,ksi3,a1,a2,a3
5879       a1=fprim0*delta/(f1-f0)
5880       a2=3.0d0-2.0d0*a1
5881       a3=a1-2.0d0
5882       ksi=(x-x0)/delta
5883       ksi2=ksi*ksi
5884       ksi3=ksi2*ksi
5885       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5886       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5887       return
5888       end
5889 c------------------------------------------------------------------------------
5890       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5891       implicit none
5892       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5893       double precision ksi,ksi2,ksi3,a1,a2,a3
5894       ksi=(x-x0)/delta
5895       ksi2=ksi*ksi
5896       ksi3=ksi2*ksi
5897       a1=fprim0x*delta
5898       a2=3*(f1x-f0x)-2*fprim0x*delta
5899       a3=fprim0x*delta-2*(f1x-f0x)
5900       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5901       return
5902       end
5903 C-----------------------------------------------------------------------------
5904 #ifdef CRYST_TOR
5905 C-----------------------------------------------------------------------------
5906       subroutine etor(etors,edihcnstr)
5907       implicit real*8 (a-h,o-z)
5908       include 'DIMENSIONS'
5909       include 'COMMON.VAR'
5910       include 'COMMON.GEO'
5911       include 'COMMON.LOCAL'
5912       include 'COMMON.TORSION'
5913       include 'COMMON.INTERACT'
5914       include 'COMMON.DERIV'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.NAMES'
5917       include 'COMMON.IOUNITS'
5918       include 'COMMON.FFIELD'
5919       include 'COMMON.TORCNSTR'
5920       include 'COMMON.CONTROL'
5921       logical lprn
5922 C Set lprn=.true. for debugging
5923       lprn=.false.
5924 c      lprn=.true.
5925       etors=0.0D0
5926       do i=iphi_start,iphi_end
5927       etors_ii=0.0D0
5928         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5929      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5930         itori=itortyp(itype(i-2))
5931         itori1=itortyp(itype(i-1))
5932         phii=phi(i)
5933         gloci=0.0D0
5934 C Proline-Proline pair is a special case...
5935         if (itori.eq.3 .and. itori1.eq.3) then
5936           if (phii.gt.-dwapi3) then
5937             cosphi=dcos(3*phii)
5938             fac=1.0D0/(1.0D0-cosphi)
5939             etorsi=v1(1,3,3)*fac
5940             etorsi=etorsi+etorsi
5941             etors=etors+etorsi-v1(1,3,3)
5942             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5943             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5944           endif
5945           do j=1,3
5946             v1ij=v1(j+1,itori,itori1)
5947             v2ij=v2(j+1,itori,itori1)
5948             cosphi=dcos(j*phii)
5949             sinphi=dsin(j*phii)
5950             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5951             if (energy_dec) etors_ii=etors_ii+
5952      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5953             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5954           enddo
5955         else
5956           do j=1,nterm_old
5957             v1ij=v1(j,itori,itori1)
5958             v2ij=v2(j,itori,itori1)
5959             cosphi=dcos(j*phii)
5960             sinphi=dsin(j*phii)
5961             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5962             if (energy_dec) etors_ii=etors_ii+
5963      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5964             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5965           enddo
5966         endif
5967         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5968              'etor',i,etors_ii
5969         if (lprn)
5970      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5971      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5972      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5973         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5974 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5975       enddo
5976 ! 6/20/98 - dihedral angle constraints
5977       edihcnstr=0.0d0
5978       do i=1,ndih_constr
5979         itori=idih_constr(i)
5980         phii=phi(itori)
5981         difi=phii-phi0(i)
5982         if (difi.gt.drange(i)) then
5983           difi=difi-drange(i)
5984           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5985           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5986         else if (difi.lt.-drange(i)) then
5987           difi=difi+drange(i)
5988           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5989           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5990         endif
5991 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5992 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5993       enddo
5994 !      write (iout,*) 'edihcnstr',edihcnstr
5995       return
5996       end
5997 c------------------------------------------------------------------------------
5998       subroutine etor_d(etors_d)
5999       etors_d=0.0d0
6000       return
6001       end
6002 c----------------------------------------------------------------------------
6003 #else
6004       subroutine etor(etors,edihcnstr)
6005       implicit real*8 (a-h,o-z)
6006       include 'DIMENSIONS'
6007       include 'COMMON.VAR'
6008       include 'COMMON.GEO'
6009       include 'COMMON.LOCAL'
6010       include 'COMMON.TORSION'
6011       include 'COMMON.INTERACT'
6012       include 'COMMON.DERIV'
6013       include 'COMMON.CHAIN'
6014       include 'COMMON.NAMES'
6015       include 'COMMON.IOUNITS'
6016       include 'COMMON.FFIELD'
6017       include 'COMMON.TORCNSTR'
6018       include 'COMMON.CONTROL'
6019       logical lprn
6020 C Set lprn=.true. for debugging
6021       lprn=.false.
6022 c     lprn=.true.
6023       etors=0.0D0
6024       do i=iphi_start,iphi_end
6025 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6026 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6027 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6028 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6029         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6030      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6031 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6032 C For introducing the NH3+ and COO- group please check the etor_d for reference
6033 C and guidance
6034         etors_ii=0.0D0
6035          if (iabs(itype(i)).eq.20) then
6036          iblock=2
6037          else
6038          iblock=1
6039          endif
6040         itori=itortyp(itype(i-2))
6041         itori1=itortyp(itype(i-1))
6042         phii=phi(i)
6043         gloci=0.0D0
6044 C Regular cosine and sine terms
6045         do j=1,nterm(itori,itori1,iblock)
6046           v1ij=v1(j,itori,itori1,iblock)
6047           v2ij=v2(j,itori,itori1,iblock)
6048           cosphi=dcos(j*phii)
6049           sinphi=dsin(j*phii)
6050           etors=etors+v1ij*cosphi+v2ij*sinphi
6051           if (energy_dec) etors_ii=etors_ii+
6052      &                v1ij*cosphi+v2ij*sinphi
6053           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6054         enddo
6055 C Lorentz terms
6056 C                         v1
6057 C  E = SUM ----------------------------------- - v1
6058 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6059 C
6060         cosphi=dcos(0.5d0*phii)
6061         sinphi=dsin(0.5d0*phii)
6062         do j=1,nlor(itori,itori1,iblock)
6063           vl1ij=vlor1(j,itori,itori1)
6064           vl2ij=vlor2(j,itori,itori1)
6065           vl3ij=vlor3(j,itori,itori1)
6066           pom=vl2ij*cosphi+vl3ij*sinphi
6067           pom1=1.0d0/(pom*pom+1.0d0)
6068           etors=etors+vl1ij*pom1
6069           if (energy_dec) etors_ii=etors_ii+
6070      &                vl1ij*pom1
6071           pom=-pom*pom1*pom1
6072           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6073         enddo
6074 C Subtract the constant term
6075         etors=etors-v0(itori,itori1,iblock)
6076           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6077      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6078         if (lprn)
6079      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6080      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6081      &  (v1(j,itori,itori1,iblock),j=1,6),
6082      &  (v2(j,itori,itori1,iblock),j=1,6)
6083         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6084 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6085       enddo
6086 ! 6/20/98 - dihedral angle constraints
6087       edihcnstr=0.0d0
6088 c      do i=1,ndih_constr
6089       do i=idihconstr_start,idihconstr_end
6090         itori=idih_constr(i)
6091         phii=phi(itori)
6092         difi=pinorm(phii-phi0(i))
6093         if (difi.gt.drange(i)) then
6094           difi=difi-drange(i)
6095           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6096           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6097         else if (difi.lt.-drange(i)) then
6098           difi=difi+drange(i)
6099           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6100           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6101         else
6102           difi=0.0
6103         endif
6104 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6105 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6106 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6107       enddo
6108 cd       write (iout,*) 'edihcnstr',edihcnstr
6109       return
6110       end
6111 c----------------------------------------------------------------------------
6112       subroutine etor_d(etors_d)
6113 C 6/23/01 Compute double torsional energy
6114       implicit real*8 (a-h,o-z)
6115       include 'DIMENSIONS'
6116       include 'COMMON.VAR'
6117       include 'COMMON.GEO'
6118       include 'COMMON.LOCAL'
6119       include 'COMMON.TORSION'
6120       include 'COMMON.INTERACT'
6121       include 'COMMON.DERIV'
6122       include 'COMMON.CHAIN'
6123       include 'COMMON.NAMES'
6124       include 'COMMON.IOUNITS'
6125       include 'COMMON.FFIELD'
6126       include 'COMMON.TORCNSTR'
6127       logical lprn
6128 C Set lprn=.true. for debugging
6129       lprn=.false.
6130 c     lprn=.true.
6131       etors_d=0.0D0
6132 c      write(iout,*) "a tu??"
6133       do i=iphid_start,iphid_end
6134 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6135 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6136 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6137 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6138 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6139          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6140      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6141      &  (itype(i+1).eq.ntyp1)) cycle
6142 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6143         itori=itortyp(itype(i-2))
6144         itori1=itortyp(itype(i-1))
6145         itori2=itortyp(itype(i))
6146         phii=phi(i)
6147         phii1=phi(i+1)
6148         gloci1=0.0D0
6149         gloci2=0.0D0
6150         iblock=1
6151         if (iabs(itype(i+1)).eq.20) iblock=2
6152 C Iblock=2 Proline type
6153 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6154 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6155 C        if (itype(i+1).eq.ntyp1) iblock=3
6156 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6157 C IS or IS NOT need for this
6158 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6159 C        is (itype(i-3).eq.ntyp1) ntblock=2
6160 C        ntblock is N-terminal blocking group
6161
6162 C Regular cosine and sine terms
6163         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6164 C Example of changes for NH3+ blocking group
6165 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6166 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6167           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6168           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6169           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6170           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6171           cosphi1=dcos(j*phii)
6172           sinphi1=dsin(j*phii)
6173           cosphi2=dcos(j*phii1)
6174           sinphi2=dsin(j*phii1)
6175           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6176      &     v2cij*cosphi2+v2sij*sinphi2
6177           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6178           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6179         enddo
6180         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6181           do l=1,k-1
6182             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6183             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6184             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6185             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6186             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6187             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6188             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6189             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6190             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6191      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6192             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6193      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6194             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6195      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6196           enddo
6197         enddo
6198         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6199         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6200       enddo
6201       return
6202       end
6203 #endif
6204 c------------------------------------------------------------------------------
6205       subroutine eback_sc_corr(esccor)
6206 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6207 c        conformational states; temporarily implemented as differences
6208 c        between UNRES torsional potentials (dependent on three types of
6209 c        residues) and the torsional potentials dependent on all 20 types
6210 c        of residues computed from AM1  energy surfaces of terminally-blocked
6211 c        amino-acid residues.
6212       implicit real*8 (a-h,o-z)
6213       include 'DIMENSIONS'
6214       include 'COMMON.VAR'
6215       include 'COMMON.GEO'
6216       include 'COMMON.LOCAL'
6217       include 'COMMON.TORSION'
6218       include 'COMMON.SCCOR'
6219       include 'COMMON.INTERACT'
6220       include 'COMMON.DERIV'
6221       include 'COMMON.CHAIN'
6222       include 'COMMON.NAMES'
6223       include 'COMMON.IOUNITS'
6224       include 'COMMON.FFIELD'
6225       include 'COMMON.CONTROL'
6226       logical lprn
6227 C Set lprn=.true. for debugging
6228       lprn=.false.
6229 c      lprn=.true.
6230 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6231       esccor=0.0D0
6232       do i=itau_start,itau_end
6233         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6234         esccor_ii=0.0D0
6235         isccori=isccortyp(itype(i-2))
6236         isccori1=isccortyp(itype(i-1))
6237 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6238         phii=phi(i)
6239         do intertyp=1,3 !intertyp
6240 cc Added 09 May 2012 (Adasko)
6241 cc  Intertyp means interaction type of backbone mainchain correlation:
6242 c   1 = SC...Ca...Ca...Ca
6243 c   2 = Ca...Ca...Ca...SC
6244 c   3 = SC...Ca...Ca...SCi
6245         gloci=0.0D0
6246         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6247      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6248      &      (itype(i-1).eq.ntyp1)))
6249      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6250      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6251      &     .or.(itype(i).eq.ntyp1)))
6252      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6253      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6254      &      (itype(i-3).eq.ntyp1)))) cycle
6255         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6256         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6257      & cycle
6258        do j=1,nterm_sccor(isccori,isccori1)
6259           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6260           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6261           cosphi=dcos(j*tauangle(intertyp,i))
6262           sinphi=dsin(j*tauangle(intertyp,i))
6263           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6264           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6265         enddo
6266 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6267         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6268         if (lprn)
6269      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6270      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6271      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6272      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6273         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6274        enddo !intertyp
6275       enddo
6276
6277       return
6278       end
6279 c----------------------------------------------------------------------------
6280       subroutine multibody(ecorr)
6281 C This subroutine calculates multi-body contributions to energy following
6282 C the idea of Skolnick et al. If side chains I and J make a contact and
6283 C at the same time side chains I+1 and J+1 make a contact, an extra
6284 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6285       implicit real*8 (a-h,o-z)
6286       include 'DIMENSIONS'
6287       include 'COMMON.IOUNITS'
6288       include 'COMMON.DERIV'
6289       include 'COMMON.INTERACT'
6290       include 'COMMON.CONTACTS'
6291       double precision gx(3),gx1(3)
6292       logical lprn
6293
6294 C Set lprn=.true. for debugging
6295       lprn=.false.
6296
6297       if (lprn) then
6298         write (iout,'(a)') 'Contact function values:'
6299         do i=nnt,nct-2
6300           write (iout,'(i2,20(1x,i2,f10.5))')
6301      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6302         enddo
6303       endif
6304       ecorr=0.0D0
6305       do i=nnt,nct
6306         do j=1,3
6307           gradcorr(j,i)=0.0D0
6308           gradxorr(j,i)=0.0D0
6309         enddo
6310       enddo
6311       do i=nnt,nct-2
6312
6313         DO ISHIFT = 3,4
6314
6315         i1=i+ishift
6316         num_conti=num_cont(i)
6317         num_conti1=num_cont(i1)
6318         do jj=1,num_conti
6319           j=jcont(jj,i)
6320           do kk=1,num_conti1
6321             j1=jcont(kk,i1)
6322             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6323 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6324 cd   &                   ' ishift=',ishift
6325 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6326 C The system gains extra energy.
6327               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6328             endif   ! j1==j+-ishift
6329           enddo     ! kk
6330         enddo       ! jj
6331
6332         ENDDO ! ISHIFT
6333
6334       enddo         ! i
6335       return
6336       end
6337 c------------------------------------------------------------------------------
6338       double precision function esccorr(i,j,k,l,jj,kk)
6339       implicit real*8 (a-h,o-z)
6340       include 'DIMENSIONS'
6341       include 'COMMON.IOUNITS'
6342       include 'COMMON.DERIV'
6343       include 'COMMON.INTERACT'
6344       include 'COMMON.CONTACTS'
6345       double precision gx(3),gx1(3)
6346       logical lprn
6347       lprn=.false.
6348       eij=facont(jj,i)
6349       ekl=facont(kk,k)
6350 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6351 C Calculate the multi-body contribution to energy.
6352 C Calculate multi-body contributions to the gradient.
6353 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6354 cd   & k,l,(gacont(m,kk,k),m=1,3)
6355       do m=1,3
6356         gx(m) =ekl*gacont(m,jj,i)
6357         gx1(m)=eij*gacont(m,kk,k)
6358         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6359         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6360         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6361         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6362       enddo
6363       do m=i,j-1
6364         do ll=1,3
6365           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6366         enddo
6367       enddo
6368       do m=k,l-1
6369         do ll=1,3
6370           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6371         enddo
6372       enddo
6373       esccorr=-eij*ekl
6374       return
6375       end
6376 c------------------------------------------------------------------------------
6377       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6378 C This subroutine calculates multi-body contributions to hydrogen-bonding
6379       implicit real*8 (a-h,o-z)
6380       include 'DIMENSIONS'
6381       include 'COMMON.IOUNITS'
6382 #ifdef MPI
6383       include "mpif.h"
6384       parameter (max_cont=maxconts)
6385       parameter (max_dim=26)
6386       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6387       double precision zapas(max_dim,maxconts,max_fg_procs),
6388      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6389       common /przechowalnia/ zapas
6390       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6391      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6392 #endif
6393       include 'COMMON.SETUP'
6394       include 'COMMON.FFIELD'
6395       include 'COMMON.DERIV'
6396       include 'COMMON.INTERACT'
6397       include 'COMMON.CONTACTS'
6398       include 'COMMON.CONTROL'
6399       include 'COMMON.LOCAL'
6400       double precision gx(3),gx1(3),time00
6401       logical lprn,ldone
6402
6403 C Set lprn=.true. for debugging
6404       lprn=.false.
6405 #ifdef MPI
6406       n_corr=0
6407       n_corr1=0
6408       if (nfgtasks.le.1) goto 30
6409       if (lprn) then
6410         write (iout,'(a)') 'Contact function values before RECEIVE:'
6411         do i=nnt,nct-2
6412           write (iout,'(2i3,50(1x,i2,f5.2))')
6413      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6414      &    j=1,num_cont_hb(i))
6415         enddo
6416       endif
6417       call flush(iout)
6418       do i=1,ntask_cont_from
6419         ncont_recv(i)=0
6420       enddo
6421       do i=1,ntask_cont_to
6422         ncont_sent(i)=0
6423       enddo
6424 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6425 c     & ntask_cont_to
6426 C Make the list of contacts to send to send to other procesors
6427 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6428 c      call flush(iout)
6429       do i=iturn3_start,iturn3_end
6430 c        write (iout,*) "make contact list turn3",i," num_cont",
6431 c     &    num_cont_hb(i)
6432         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6433       enddo
6434       do i=iturn4_start,iturn4_end
6435 c        write (iout,*) "make contact list turn4",i," num_cont",
6436 c     &   num_cont_hb(i)
6437         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6438       enddo
6439       do ii=1,nat_sent
6440         i=iat_sent(ii)
6441 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6442 c     &    num_cont_hb(i)
6443         do j=1,num_cont_hb(i)
6444         do k=1,4
6445           jjc=jcont_hb(j,i)
6446           iproc=iint_sent_local(k,jjc,ii)
6447 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6448           if (iproc.gt.0) then
6449             ncont_sent(iproc)=ncont_sent(iproc)+1
6450             nn=ncont_sent(iproc)
6451             zapas(1,nn,iproc)=i
6452             zapas(2,nn,iproc)=jjc
6453             zapas(3,nn,iproc)=facont_hb(j,i)
6454             zapas(4,nn,iproc)=ees0p(j,i)
6455             zapas(5,nn,iproc)=ees0m(j,i)
6456             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6457             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6458             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6459             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6460             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6461             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6462             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6463             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6464             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6465             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6466             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6467             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6468             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6469             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6470             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6471             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6472             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6473             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6474             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6475             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6476             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6477           endif
6478         enddo
6479         enddo
6480       enddo
6481       if (lprn) then
6482       write (iout,*)
6483      &  "Numbers of contacts to be sent to other processors",
6484      &  (ncont_sent(i),i=1,ntask_cont_to)
6485       write (iout,*) "Contacts sent"
6486       do ii=1,ntask_cont_to
6487         nn=ncont_sent(ii)
6488         iproc=itask_cont_to(ii)
6489         write (iout,*) nn," contacts to processor",iproc,
6490      &   " of CONT_TO_COMM group"
6491         do i=1,nn
6492           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6493         enddo
6494       enddo
6495       call flush(iout)
6496       endif
6497       CorrelType=477
6498       CorrelID=fg_rank+1
6499       CorrelType1=478
6500       CorrelID1=nfgtasks+fg_rank+1
6501       ireq=0
6502 C Receive the numbers of needed contacts from other processors
6503       do ii=1,ntask_cont_from
6504         iproc=itask_cont_from(ii)
6505         ireq=ireq+1
6506         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6507      &    FG_COMM,req(ireq),IERR)
6508       enddo
6509 c      write (iout,*) "IRECV ended"
6510 c      call flush(iout)
6511 C Send the number of contacts needed by other processors
6512       do ii=1,ntask_cont_to
6513         iproc=itask_cont_to(ii)
6514         ireq=ireq+1
6515         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6516      &    FG_COMM,req(ireq),IERR)
6517       enddo
6518 c      write (iout,*) "ISEND ended"
6519 c      write (iout,*) "number of requests (nn)",ireq
6520       call flush(iout)
6521       if (ireq.gt.0)
6522      &  call MPI_Waitall(ireq,req,status_array,ierr)
6523 c      write (iout,*)
6524 c     &  "Numbers of contacts to be received from other processors",
6525 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6526 c      call flush(iout)
6527 C Receive contacts
6528       ireq=0
6529       do ii=1,ntask_cont_from
6530         iproc=itask_cont_from(ii)
6531         nn=ncont_recv(ii)
6532 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6533 c     &   " of CONT_TO_COMM group"
6534         call flush(iout)
6535         if (nn.gt.0) then
6536           ireq=ireq+1
6537           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6538      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6539 c          write (iout,*) "ireq,req",ireq,req(ireq)
6540         endif
6541       enddo
6542 C Send the contacts to processors that need them
6543       do ii=1,ntask_cont_to
6544         iproc=itask_cont_to(ii)
6545         nn=ncont_sent(ii)
6546 c        write (iout,*) nn," contacts to processor",iproc,
6547 c     &   " of CONT_TO_COMM group"
6548         if (nn.gt.0) then
6549           ireq=ireq+1
6550           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6551      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6552 c          write (iout,*) "ireq,req",ireq,req(ireq)
6553 c          do i=1,nn
6554 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6555 c          enddo
6556         endif
6557       enddo
6558 c      write (iout,*) "number of requests (contacts)",ireq
6559 c      write (iout,*) "req",(req(i),i=1,4)
6560 c      call flush(iout)
6561       if (ireq.gt.0)
6562      & call MPI_Waitall(ireq,req,status_array,ierr)
6563       do iii=1,ntask_cont_from
6564         iproc=itask_cont_from(iii)
6565         nn=ncont_recv(iii)
6566         if (lprn) then
6567         write (iout,*) "Received",nn," contacts from processor",iproc,
6568      &   " of CONT_FROM_COMM group"
6569         call flush(iout)
6570         do i=1,nn
6571           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6572         enddo
6573         call flush(iout)
6574         endif
6575         do i=1,nn
6576           ii=zapas_recv(1,i,iii)
6577 c Flag the received contacts to prevent double-counting
6578           jj=-zapas_recv(2,i,iii)
6579 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6580 c          call flush(iout)
6581           nnn=num_cont_hb(ii)+1
6582           num_cont_hb(ii)=nnn
6583           jcont_hb(nnn,ii)=jj
6584           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6585           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6586           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6587           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6588           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6589           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6590           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6591           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6592           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6593           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6594           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6595           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6596           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6597           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6598           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6599           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6600           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6601           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6602           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6603           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6604           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6605           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6606           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6607           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6608         enddo
6609       enddo
6610       call flush(iout)
6611       if (lprn) then
6612         write (iout,'(a)') 'Contact function values after receive:'
6613         do i=nnt,nct-2
6614           write (iout,'(2i3,50(1x,i3,f5.2))')
6615      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6616      &    j=1,num_cont_hb(i))
6617         enddo
6618         call flush(iout)
6619       endif
6620    30 continue
6621 #endif
6622       if (lprn) then
6623         write (iout,'(a)') 'Contact function values:'
6624         do i=nnt,nct-2
6625           write (iout,'(2i3,50(1x,i3,f5.2))')
6626      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6627      &    j=1,num_cont_hb(i))
6628         enddo
6629       endif
6630       ecorr=0.0D0
6631 C Remove the loop below after debugging !!!
6632       do i=nnt,nct
6633         do j=1,3
6634           gradcorr(j,i)=0.0D0
6635           gradxorr(j,i)=0.0D0
6636         enddo
6637       enddo
6638 C Calculate the local-electrostatic correlation terms
6639       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6640         i1=i+1
6641         num_conti=num_cont_hb(i)
6642         num_conti1=num_cont_hb(i+1)
6643         do jj=1,num_conti
6644           j=jcont_hb(jj,i)
6645           jp=iabs(j)
6646           do kk=1,num_conti1
6647             j1=jcont_hb(kk,i1)
6648             jp1=iabs(j1)
6649 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6650 c     &         ' jj=',jj,' kk=',kk
6651             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6652      &          .or. j.lt.0 .and. j1.gt.0) .and.
6653      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6654 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6655 C The system gains extra energy.
6656               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6657               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6658      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6659               n_corr=n_corr+1
6660             else if (j1.eq.j) then
6661 C Contacts I-J and I-(J+1) occur simultaneously.
6662 C The system loses extra energy.
6663 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6664             endif
6665           enddo ! kk
6666           do kk=1,num_conti
6667             j1=jcont_hb(kk,i)
6668 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6669 c    &         ' jj=',jj,' kk=',kk
6670             if (j1.eq.j+1) then
6671 C Contacts I-J and (I+1)-J occur simultaneously.
6672 C The system loses extra energy.
6673 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6674             endif ! j1==j+1
6675           enddo ! kk
6676         enddo ! jj
6677       enddo ! i
6678       return
6679       end
6680 c------------------------------------------------------------------------------
6681       subroutine add_hb_contact(ii,jj,itask)
6682       implicit real*8 (a-h,o-z)
6683       include "DIMENSIONS"
6684       include "COMMON.IOUNITS"
6685       integer max_cont
6686       integer max_dim
6687       parameter (max_cont=maxconts)
6688       parameter (max_dim=26)
6689       include "COMMON.CONTACTS"
6690       double precision zapas(max_dim,maxconts,max_fg_procs),
6691      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6692       common /przechowalnia/ zapas
6693       integer i,j,ii,jj,iproc,itask(4),nn
6694 c      write (iout,*) "itask",itask
6695       do i=1,2
6696         iproc=itask(i)
6697         if (iproc.gt.0) then
6698           do j=1,num_cont_hb(ii)
6699             jjc=jcont_hb(j,ii)
6700 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6701             if (jjc.eq.jj) then
6702               ncont_sent(iproc)=ncont_sent(iproc)+1
6703               nn=ncont_sent(iproc)
6704               zapas(1,nn,iproc)=ii
6705               zapas(2,nn,iproc)=jjc
6706               zapas(3,nn,iproc)=facont_hb(j,ii)
6707               zapas(4,nn,iproc)=ees0p(j,ii)
6708               zapas(5,nn,iproc)=ees0m(j,ii)
6709               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6710               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6711               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6712               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6713               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6714               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6715               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6716               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6717               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6718               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6719               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6720               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6721               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6722               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6723               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6724               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6725               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6726               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6727               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6728               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6729               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6730               exit
6731             endif
6732           enddo
6733         endif
6734       enddo
6735       return
6736       end
6737 c------------------------------------------------------------------------------
6738       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6739      &  n_corr1)
6740 C This subroutine calculates multi-body contributions to hydrogen-bonding
6741       implicit real*8 (a-h,o-z)
6742       include 'DIMENSIONS'
6743       include 'COMMON.IOUNITS'
6744 #ifdef MPI
6745       include "mpif.h"
6746       parameter (max_cont=maxconts)
6747       parameter (max_dim=70)
6748       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6749       double precision zapas(max_dim,maxconts,max_fg_procs),
6750      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6751       common /przechowalnia/ zapas
6752       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6753      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6754 #endif
6755       include 'COMMON.SETUP'
6756       include 'COMMON.FFIELD'
6757       include 'COMMON.DERIV'
6758       include 'COMMON.LOCAL'
6759       include 'COMMON.INTERACT'
6760       include 'COMMON.CONTACTS'
6761       include 'COMMON.CHAIN'
6762       include 'COMMON.CONTROL'
6763       double precision gx(3),gx1(3)
6764       integer num_cont_hb_old(maxres)
6765       logical lprn,ldone
6766       double precision eello4,eello5,eelo6,eello_turn6
6767       external eello4,eello5,eello6,eello_turn6
6768 C Set lprn=.true. for debugging
6769       lprn=.false.
6770       eturn6=0.0d0
6771 #ifdef MPI
6772       do i=1,nres
6773         num_cont_hb_old(i)=num_cont_hb(i)
6774       enddo
6775       n_corr=0
6776       n_corr1=0
6777       if (nfgtasks.le.1) goto 30
6778       if (lprn) then
6779         write (iout,'(a)') 'Contact function values before RECEIVE:'
6780         do i=nnt,nct-2
6781           write (iout,'(2i3,50(1x,i2,f5.2))')
6782      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6783      &    j=1,num_cont_hb(i))
6784         enddo
6785       endif
6786       call flush(iout)
6787       do i=1,ntask_cont_from
6788         ncont_recv(i)=0
6789       enddo
6790       do i=1,ntask_cont_to
6791         ncont_sent(i)=0
6792       enddo
6793 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6794 c     & ntask_cont_to
6795 C Make the list of contacts to send to send to other procesors
6796       do i=iturn3_start,iturn3_end
6797 c        write (iout,*) "make contact list turn3",i," num_cont",
6798 c     &    num_cont_hb(i)
6799         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6800       enddo
6801       do i=iturn4_start,iturn4_end
6802 c        write (iout,*) "make contact list turn4",i," num_cont",
6803 c     &   num_cont_hb(i)
6804         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6805       enddo
6806       do ii=1,nat_sent
6807         i=iat_sent(ii)
6808 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6809 c     &    num_cont_hb(i)
6810         do j=1,num_cont_hb(i)
6811         do k=1,4
6812           jjc=jcont_hb(j,i)
6813           iproc=iint_sent_local(k,jjc,ii)
6814 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6815           if (iproc.ne.0) then
6816             ncont_sent(iproc)=ncont_sent(iproc)+1
6817             nn=ncont_sent(iproc)
6818             zapas(1,nn,iproc)=i
6819             zapas(2,nn,iproc)=jjc
6820             zapas(3,nn,iproc)=d_cont(j,i)
6821             ind=3
6822             do kk=1,3
6823               ind=ind+1
6824               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6825             enddo
6826             do kk=1,2
6827               do ll=1,2
6828                 ind=ind+1
6829                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6830               enddo
6831             enddo
6832             do jj=1,5
6833               do kk=1,3
6834                 do ll=1,2
6835                   do mm=1,2
6836                     ind=ind+1
6837                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6838                   enddo
6839                 enddo
6840               enddo
6841             enddo
6842           endif
6843         enddo
6844         enddo
6845       enddo
6846       if (lprn) then
6847       write (iout,*)
6848      &  "Numbers of contacts to be sent to other processors",
6849      &  (ncont_sent(i),i=1,ntask_cont_to)
6850       write (iout,*) "Contacts sent"
6851       do ii=1,ntask_cont_to
6852         nn=ncont_sent(ii)
6853         iproc=itask_cont_to(ii)
6854         write (iout,*) nn," contacts to processor",iproc,
6855      &   " of CONT_TO_COMM group"
6856         do i=1,nn
6857           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6858         enddo
6859       enddo
6860       call flush(iout)
6861       endif
6862       CorrelType=477
6863       CorrelID=fg_rank+1
6864       CorrelType1=478
6865       CorrelID1=nfgtasks+fg_rank+1
6866       ireq=0
6867 C Receive the numbers of needed contacts from other processors
6868       do ii=1,ntask_cont_from
6869         iproc=itask_cont_from(ii)
6870         ireq=ireq+1
6871         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6872      &    FG_COMM,req(ireq),IERR)
6873       enddo
6874 c      write (iout,*) "IRECV ended"
6875 c      call flush(iout)
6876 C Send the number of contacts needed by other processors
6877       do ii=1,ntask_cont_to
6878         iproc=itask_cont_to(ii)
6879         ireq=ireq+1
6880         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6881      &    FG_COMM,req(ireq),IERR)
6882       enddo
6883 c      write (iout,*) "ISEND ended"
6884 c      write (iout,*) "number of requests (nn)",ireq
6885       call flush(iout)
6886       if (ireq.gt.0)
6887      &  call MPI_Waitall(ireq,req,status_array,ierr)
6888 c      write (iout,*)
6889 c     &  "Numbers of contacts to be received from other processors",
6890 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6891 c      call flush(iout)
6892 C Receive contacts
6893       ireq=0
6894       do ii=1,ntask_cont_from
6895         iproc=itask_cont_from(ii)
6896         nn=ncont_recv(ii)
6897 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6898 c     &   " of CONT_TO_COMM group"
6899         call flush(iout)
6900         if (nn.gt.0) then
6901           ireq=ireq+1
6902           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6903      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6904 c          write (iout,*) "ireq,req",ireq,req(ireq)
6905         endif
6906       enddo
6907 C Send the contacts to processors that need them
6908       do ii=1,ntask_cont_to
6909         iproc=itask_cont_to(ii)
6910         nn=ncont_sent(ii)
6911 c        write (iout,*) nn," contacts to processor",iproc,
6912 c     &   " of CONT_TO_COMM group"
6913         if (nn.gt.0) then
6914           ireq=ireq+1
6915           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6916      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6917 c          write (iout,*) "ireq,req",ireq,req(ireq)
6918 c          do i=1,nn
6919 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6920 c          enddo
6921         endif
6922       enddo
6923 c      write (iout,*) "number of requests (contacts)",ireq
6924 c      write (iout,*) "req",(req(i),i=1,4)
6925 c      call flush(iout)
6926       if (ireq.gt.0)
6927      & call MPI_Waitall(ireq,req,status_array,ierr)
6928       do iii=1,ntask_cont_from
6929         iproc=itask_cont_from(iii)
6930         nn=ncont_recv(iii)
6931         if (lprn) then
6932         write (iout,*) "Received",nn," contacts from processor",iproc,
6933      &   " of CONT_FROM_COMM group"
6934         call flush(iout)
6935         do i=1,nn
6936           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6937         enddo
6938         call flush(iout)
6939         endif
6940         do i=1,nn
6941           ii=zapas_recv(1,i,iii)
6942 c Flag the received contacts to prevent double-counting
6943           jj=-zapas_recv(2,i,iii)
6944 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6945 c          call flush(iout)
6946           nnn=num_cont_hb(ii)+1
6947           num_cont_hb(ii)=nnn
6948           jcont_hb(nnn,ii)=jj
6949           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6950           ind=3
6951           do kk=1,3
6952             ind=ind+1
6953             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6954           enddo
6955           do kk=1,2
6956             do ll=1,2
6957               ind=ind+1
6958               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6959             enddo
6960           enddo
6961           do jj=1,5
6962             do kk=1,3
6963               do ll=1,2
6964                 do mm=1,2
6965                   ind=ind+1
6966                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6967                 enddo
6968               enddo
6969             enddo
6970           enddo
6971         enddo
6972       enddo
6973       call flush(iout)
6974       if (lprn) then
6975         write (iout,'(a)') 'Contact function values after receive:'
6976         do i=nnt,nct-2
6977           write (iout,'(2i3,50(1x,i3,5f6.3))')
6978      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6979      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6980         enddo
6981         call flush(iout)
6982       endif
6983    30 continue
6984 #endif
6985       if (lprn) then
6986         write (iout,'(a)') 'Contact function values:'
6987         do i=nnt,nct-2
6988           write (iout,'(2i3,50(1x,i2,5f6.3))')
6989      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6990      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6991         enddo
6992       endif
6993       ecorr=0.0D0
6994       ecorr5=0.0d0
6995       ecorr6=0.0d0
6996 C Remove the loop below after debugging !!!
6997       do i=nnt,nct
6998         do j=1,3
6999           gradcorr(j,i)=0.0D0
7000           gradxorr(j,i)=0.0D0
7001         enddo
7002       enddo
7003 C Calculate the dipole-dipole interaction energies
7004       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7005       do i=iatel_s,iatel_e+1
7006         num_conti=num_cont_hb(i)
7007         do jj=1,num_conti
7008           j=jcont_hb(jj,i)
7009 #ifdef MOMENT
7010           call dipole(i,j,jj)
7011 #endif
7012         enddo
7013       enddo
7014       endif
7015 C Calculate the local-electrostatic correlation terms
7016 c                write (iout,*) "gradcorr5 in eello5 before loop"
7017 c                do iii=1,nres
7018 c                  write (iout,'(i5,3f10.5)')
7019 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7020 c                enddo
7021       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7022 c        write (iout,*) "corr loop i",i
7023         i1=i+1
7024         num_conti=num_cont_hb(i)
7025         num_conti1=num_cont_hb(i+1)
7026         do jj=1,num_conti
7027           j=jcont_hb(jj,i)
7028           jp=iabs(j)
7029           do kk=1,num_conti1
7030             j1=jcont_hb(kk,i1)
7031             jp1=iabs(j1)
7032 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7033 c     &         ' jj=',jj,' kk=',kk
7034 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7035             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7036      &          .or. j.lt.0 .and. j1.gt.0) .and.
7037      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7038 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7039 C The system gains extra energy.
7040               n_corr=n_corr+1
7041               sqd1=dsqrt(d_cont(jj,i))
7042               sqd2=dsqrt(d_cont(kk,i1))
7043               sred_geom = sqd1*sqd2
7044               IF (sred_geom.lt.cutoff_corr) THEN
7045                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7046      &            ekont,fprimcont)
7047 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7048 cd     &         ' jj=',jj,' kk=',kk
7049                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7050                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7051                 do l=1,3
7052                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7053                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7054                 enddo
7055                 n_corr1=n_corr1+1
7056 cd               write (iout,*) 'sred_geom=',sred_geom,
7057 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7058 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7059 cd               write (iout,*) "g_contij",g_contij
7060 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7061 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7062                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7063                 if (wcorr4.gt.0.0d0)
7064      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7065                   if (energy_dec.and.wcorr4.gt.0.0d0)
7066      1                 write (iout,'(a6,4i5,0pf7.3)')
7067      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7068 c                write (iout,*) "gradcorr5 before eello5"
7069 c                do iii=1,nres
7070 c                  write (iout,'(i5,3f10.5)')
7071 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7072 c                enddo
7073                 if (wcorr5.gt.0.0d0)
7074      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7075 c                write (iout,*) "gradcorr5 after eello5"
7076 c                do iii=1,nres
7077 c                  write (iout,'(i5,3f10.5)')
7078 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7079 c                enddo
7080                   if (energy_dec.and.wcorr5.gt.0.0d0)
7081      1                 write (iout,'(a6,4i5,0pf7.3)')
7082      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7083 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7084 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7085                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7086      &               .or. wturn6.eq.0.0d0))then
7087 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7088                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7089                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7090      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7091 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7092 cd     &            'ecorr6=',ecorr6
7093 cd                write (iout,'(4e15.5)') sred_geom,
7094 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7095 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7096 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7097                 else if (wturn6.gt.0.0d0
7098      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7099 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7100                   eturn6=eturn6+eello_turn6(i,jj,kk)
7101                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7102      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7103 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7104                 endif
7105               ENDIF
7106 1111          continue
7107             endif
7108           enddo ! kk
7109         enddo ! jj
7110       enddo ! i
7111       do i=1,nres
7112         num_cont_hb(i)=num_cont_hb_old(i)
7113       enddo
7114 c                write (iout,*) "gradcorr5 in eello5"
7115 c                do iii=1,nres
7116 c                  write (iout,'(i5,3f10.5)')
7117 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7118 c                enddo
7119       return
7120       end
7121 c------------------------------------------------------------------------------
7122       subroutine add_hb_contact_eello(ii,jj,itask)
7123       implicit real*8 (a-h,o-z)
7124       include "DIMENSIONS"
7125       include "COMMON.IOUNITS"
7126       integer max_cont
7127       integer max_dim
7128       parameter (max_cont=maxconts)
7129       parameter (max_dim=70)
7130       include "COMMON.CONTACTS"
7131       double precision zapas(max_dim,maxconts,max_fg_procs),
7132      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7133       common /przechowalnia/ zapas
7134       integer i,j,ii,jj,iproc,itask(4),nn
7135 c      write (iout,*) "itask",itask
7136       do i=1,2
7137         iproc=itask(i)
7138         if (iproc.gt.0) then
7139           do j=1,num_cont_hb(ii)
7140             jjc=jcont_hb(j,ii)
7141 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7142             if (jjc.eq.jj) then
7143               ncont_sent(iproc)=ncont_sent(iproc)+1
7144               nn=ncont_sent(iproc)
7145               zapas(1,nn,iproc)=ii
7146               zapas(2,nn,iproc)=jjc
7147               zapas(3,nn,iproc)=d_cont(j,ii)
7148               ind=3
7149               do kk=1,3
7150                 ind=ind+1
7151                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7152               enddo
7153               do kk=1,2
7154                 do ll=1,2
7155                   ind=ind+1
7156                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7157                 enddo
7158               enddo
7159               do jj=1,5
7160                 do kk=1,3
7161                   do ll=1,2
7162                     do mm=1,2
7163                       ind=ind+1
7164                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7165                     enddo
7166                   enddo
7167                 enddo
7168               enddo
7169               exit
7170             endif
7171           enddo
7172         endif
7173       enddo
7174       return
7175       end
7176 c------------------------------------------------------------------------------
7177       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7178       implicit real*8 (a-h,o-z)
7179       include 'DIMENSIONS'
7180       include 'COMMON.IOUNITS'
7181       include 'COMMON.DERIV'
7182       include 'COMMON.INTERACT'
7183       include 'COMMON.CONTACTS'
7184       double precision gx(3),gx1(3)
7185       logical lprn
7186       lprn=.false.
7187       eij=facont_hb(jj,i)
7188       ekl=facont_hb(kk,k)
7189       ees0pij=ees0p(jj,i)
7190       ees0pkl=ees0p(kk,k)
7191       ees0mij=ees0m(jj,i)
7192       ees0mkl=ees0m(kk,k)
7193       ekont=eij*ekl
7194       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7195 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7196 C Following 4 lines for diagnostics.
7197 cd    ees0pkl=0.0D0
7198 cd    ees0pij=1.0D0
7199 cd    ees0mkl=0.0D0
7200 cd    ees0mij=1.0D0
7201 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7202 c     & 'Contacts ',i,j,
7203 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7204 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7205 c     & 'gradcorr_long'
7206 C Calculate the multi-body contribution to energy.
7207 c      ecorr=ecorr+ekont*ees
7208 C Calculate multi-body contributions to the gradient.
7209       coeffpees0pij=coeffp*ees0pij
7210       coeffmees0mij=coeffm*ees0mij
7211       coeffpees0pkl=coeffp*ees0pkl
7212       coeffmees0mkl=coeffm*ees0mkl
7213       do ll=1,3
7214 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7215         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7216      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7217      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7218         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7219      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7220      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7221 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7222         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7223      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7224      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7225         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7226      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7227      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7228         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7229      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7230      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7231         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7232         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7233         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7234      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7235      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7236         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7237         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7238 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7239       enddo
7240 c      write (iout,*)
7241 cgrad      do m=i+1,j-1
7242 cgrad        do ll=1,3
7243 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7244 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7245 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7246 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7247 cgrad        enddo
7248 cgrad      enddo
7249 cgrad      do m=k+1,l-1
7250 cgrad        do ll=1,3
7251 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7252 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7253 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7254 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7255 cgrad        enddo
7256 cgrad      enddo
7257 c      write (iout,*) "ehbcorr",ekont*ees
7258       ehbcorr=ekont*ees
7259       return
7260       end
7261 #ifdef MOMENT
7262 C---------------------------------------------------------------------------
7263       subroutine dipole(i,j,jj)
7264       implicit real*8 (a-h,o-z)
7265       include 'DIMENSIONS'
7266       include 'COMMON.IOUNITS'
7267       include 'COMMON.CHAIN'
7268       include 'COMMON.FFIELD'
7269       include 'COMMON.DERIV'
7270       include 'COMMON.INTERACT'
7271       include 'COMMON.CONTACTS'
7272       include 'COMMON.TORSION'
7273       include 'COMMON.VAR'
7274       include 'COMMON.GEO'
7275       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7276      &  auxmat(2,2)
7277       iti1 = itortyp(itype(i+1))
7278       if (j.lt.nres-1) then
7279         itj1 = itortyp(itype(j+1))
7280       else
7281         itj1=ntortyp
7282       endif
7283       do iii=1,2
7284         dipi(iii,1)=Ub2(iii,i)
7285         dipderi(iii)=Ub2der(iii,i)
7286         dipi(iii,2)=b1(iii,iti1)
7287         dipj(iii,1)=Ub2(iii,j)
7288         dipderj(iii)=Ub2der(iii,j)
7289         dipj(iii,2)=b1(iii,itj1)
7290       enddo
7291       kkk=0
7292       do iii=1,2
7293         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7294         do jjj=1,2
7295           kkk=kkk+1
7296           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7297         enddo
7298       enddo
7299       do kkk=1,5
7300         do lll=1,3
7301           mmm=0
7302           do iii=1,2
7303             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7304      &        auxvec(1))
7305             do jjj=1,2
7306               mmm=mmm+1
7307               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7308             enddo
7309           enddo
7310         enddo
7311       enddo
7312       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7313       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7314       do iii=1,2
7315         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7316       enddo
7317       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7318       do iii=1,2
7319         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7320       enddo
7321       return
7322       end
7323 #endif
7324 C---------------------------------------------------------------------------
7325       subroutine calc_eello(i,j,k,l,jj,kk)
7326 C
7327 C This subroutine computes matrices and vectors needed to calculate
7328 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7329 C
7330       implicit real*8 (a-h,o-z)
7331       include 'DIMENSIONS'
7332       include 'COMMON.IOUNITS'
7333       include 'COMMON.CHAIN'
7334       include 'COMMON.DERIV'
7335       include 'COMMON.INTERACT'
7336       include 'COMMON.CONTACTS'
7337       include 'COMMON.TORSION'
7338       include 'COMMON.VAR'
7339       include 'COMMON.GEO'
7340       include 'COMMON.FFIELD'
7341       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7342      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7343       logical lprn
7344       common /kutas/ lprn
7345 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7346 cd     & ' jj=',jj,' kk=',kk
7347 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7348 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7349 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7350       do iii=1,2
7351         do jjj=1,2
7352           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7353           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7354         enddo
7355       enddo
7356       call transpose2(aa1(1,1),aa1t(1,1))
7357       call transpose2(aa2(1,1),aa2t(1,1))
7358       do kkk=1,5
7359         do lll=1,3
7360           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7361      &      aa1tder(1,1,lll,kkk))
7362           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7363      &      aa2tder(1,1,lll,kkk))
7364         enddo
7365       enddo
7366       if (l.eq.j+1) then
7367 C parallel orientation of the two CA-CA-CA frames.
7368         if (i.gt.1) then
7369           iti=itortyp(itype(i))
7370         else
7371           iti=ntortyp
7372         endif
7373         itk1=itortyp(itype(k+1))
7374         itj=itortyp(itype(j))
7375         if (l.lt.nres-1) then
7376           itl1=itortyp(itype(l+1))
7377         else
7378           itl1=ntortyp
7379         endif
7380 C A1 kernel(j+1) A2T
7381 cd        do iii=1,2
7382 cd          write (iout,'(3f10.5,5x,3f10.5)')
7383 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7384 cd        enddo
7385         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7386      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7387      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7388 C Following matrices are needed only for 6-th order cumulants
7389         IF (wcorr6.gt.0.0d0) THEN
7390         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7391      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7392      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7393         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7394      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7395      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7396      &   ADtEAderx(1,1,1,1,1,1))
7397         lprn=.false.
7398         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7399      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7400      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7401      &   ADtEA1derx(1,1,1,1,1,1))
7402         ENDIF
7403 C End 6-th order cumulants
7404 cd        lprn=.false.
7405 cd        if (lprn) then
7406 cd        write (2,*) 'In calc_eello6'
7407 cd        do iii=1,2
7408 cd          write (2,*) 'iii=',iii
7409 cd          do kkk=1,5
7410 cd            write (2,*) 'kkk=',kkk
7411 cd            do jjj=1,2
7412 cd              write (2,'(3(2f10.5),5x)')
7413 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7414 cd            enddo
7415 cd          enddo
7416 cd        enddo
7417 cd        endif
7418         call transpose2(EUgder(1,1,k),auxmat(1,1))
7419         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7420         call transpose2(EUg(1,1,k),auxmat(1,1))
7421         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7422         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7423         do iii=1,2
7424           do kkk=1,5
7425             do lll=1,3
7426               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7427      &          EAEAderx(1,1,lll,kkk,iii,1))
7428             enddo
7429           enddo
7430         enddo
7431 C A1T kernel(i+1) A2
7432         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7433      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7434      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7435 C Following matrices are needed only for 6-th order cumulants
7436         IF (wcorr6.gt.0.0d0) THEN
7437         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7438      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7439      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7440         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7441      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7442      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7443      &   ADtEAderx(1,1,1,1,1,2))
7444         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7445      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7446      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7447      &   ADtEA1derx(1,1,1,1,1,2))
7448         ENDIF
7449 C End 6-th order cumulants
7450         call transpose2(EUgder(1,1,l),auxmat(1,1))
7451         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7452         call transpose2(EUg(1,1,l),auxmat(1,1))
7453         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7454         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7455         do iii=1,2
7456           do kkk=1,5
7457             do lll=1,3
7458               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7459      &          EAEAderx(1,1,lll,kkk,iii,2))
7460             enddo
7461           enddo
7462         enddo
7463 C AEAb1 and AEAb2
7464 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7465 C They are needed only when the fifth- or the sixth-order cumulants are
7466 C indluded.
7467         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7468         call transpose2(AEA(1,1,1),auxmat(1,1))
7469         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7470         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7471         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7472         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7473         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7474         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7475         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7476         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7477         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7478         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7479         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7480         call transpose2(AEA(1,1,2),auxmat(1,1))
7481         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7482         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7483         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7484         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7485         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7486         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7487         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7488         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7489         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7490         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7491         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7492 C Calculate the Cartesian derivatives of the vectors.
7493         do iii=1,2
7494           do kkk=1,5
7495             do lll=1,3
7496               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7497               call matvec2(auxmat(1,1),b1(1,iti),
7498      &          AEAb1derx(1,lll,kkk,iii,1,1))
7499               call matvec2(auxmat(1,1),Ub2(1,i),
7500      &          AEAb2derx(1,lll,kkk,iii,1,1))
7501               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7502      &          AEAb1derx(1,lll,kkk,iii,2,1))
7503               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7504      &          AEAb2derx(1,lll,kkk,iii,2,1))
7505               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7506               call matvec2(auxmat(1,1),b1(1,itj),
7507      &          AEAb1derx(1,lll,kkk,iii,1,2))
7508               call matvec2(auxmat(1,1),Ub2(1,j),
7509      &          AEAb2derx(1,lll,kkk,iii,1,2))
7510               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7511      &          AEAb1derx(1,lll,kkk,iii,2,2))
7512               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7513      &          AEAb2derx(1,lll,kkk,iii,2,2))
7514             enddo
7515           enddo
7516         enddo
7517         ENDIF
7518 C End vectors
7519       else
7520 C Antiparallel orientation of the two CA-CA-CA frames.
7521         if (i.gt.1) then
7522           iti=itortyp(itype(i))
7523         else
7524           iti=ntortyp
7525         endif
7526         itk1=itortyp(itype(k+1))
7527         itl=itortyp(itype(l))
7528         itj=itortyp(itype(j))
7529         if (j.lt.nres-1) then
7530           itj1=itortyp(itype(j+1))
7531         else
7532           itj1=ntortyp
7533         endif
7534 C A2 kernel(j-1)T A1T
7535         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7536      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7537      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7538 C Following matrices are needed only for 6-th order cumulants
7539         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7540      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7541         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7542      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7543      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7544         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7545      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7546      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7547      &   ADtEAderx(1,1,1,1,1,1))
7548         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7549      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7550      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7551      &   ADtEA1derx(1,1,1,1,1,1))
7552         ENDIF
7553 C End 6-th order cumulants
7554         call transpose2(EUgder(1,1,k),auxmat(1,1))
7555         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7556         call transpose2(EUg(1,1,k),auxmat(1,1))
7557         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7558         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7559         do iii=1,2
7560           do kkk=1,5
7561             do lll=1,3
7562               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7563      &          EAEAderx(1,1,lll,kkk,iii,1))
7564             enddo
7565           enddo
7566         enddo
7567 C A2T kernel(i+1)T A1
7568         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7569      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7570      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7571 C Following matrices are needed only for 6-th order cumulants
7572         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7573      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7574         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7575      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7576      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7577         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7578      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7579      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7580      &   ADtEAderx(1,1,1,1,1,2))
7581         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7582      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7583      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7584      &   ADtEA1derx(1,1,1,1,1,2))
7585         ENDIF
7586 C End 6-th order cumulants
7587         call transpose2(EUgder(1,1,j),auxmat(1,1))
7588         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7589         call transpose2(EUg(1,1,j),auxmat(1,1))
7590         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7591         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7592         do iii=1,2
7593           do kkk=1,5
7594             do lll=1,3
7595               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7596      &          EAEAderx(1,1,lll,kkk,iii,2))
7597             enddo
7598           enddo
7599         enddo
7600 C AEAb1 and AEAb2
7601 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7602 C They are needed only when the fifth- or the sixth-order cumulants are
7603 C indluded.
7604         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7605      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7606         call transpose2(AEA(1,1,1),auxmat(1,1))
7607         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7608         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7609         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7610         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7611         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7612         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7613         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7614         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7615         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7616         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7617         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7618         call transpose2(AEA(1,1,2),auxmat(1,1))
7619         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7620         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7621         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7622         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7623         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7624         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7625         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7626         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7627         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7628         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7629         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7630 C Calculate the Cartesian derivatives of the vectors.
7631         do iii=1,2
7632           do kkk=1,5
7633             do lll=1,3
7634               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7635               call matvec2(auxmat(1,1),b1(1,iti),
7636      &          AEAb1derx(1,lll,kkk,iii,1,1))
7637               call matvec2(auxmat(1,1),Ub2(1,i),
7638      &          AEAb2derx(1,lll,kkk,iii,1,1))
7639               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7640      &          AEAb1derx(1,lll,kkk,iii,2,1))
7641               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7642      &          AEAb2derx(1,lll,kkk,iii,2,1))
7643               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7644               call matvec2(auxmat(1,1),b1(1,itl),
7645      &          AEAb1derx(1,lll,kkk,iii,1,2))
7646               call matvec2(auxmat(1,1),Ub2(1,l),
7647      &          AEAb2derx(1,lll,kkk,iii,1,2))
7648               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7649      &          AEAb1derx(1,lll,kkk,iii,2,2))
7650               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7651      &          AEAb2derx(1,lll,kkk,iii,2,2))
7652             enddo
7653           enddo
7654         enddo
7655         ENDIF
7656 C End vectors
7657       endif
7658       return
7659       end
7660 C---------------------------------------------------------------------------
7661       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7662      &  KK,KKderg,AKA,AKAderg,AKAderx)
7663       implicit none
7664       integer nderg
7665       logical transp
7666       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7667      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7668      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7669       integer iii,kkk,lll
7670       integer jjj,mmm
7671       logical lprn
7672       common /kutas/ lprn
7673       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7674       do iii=1,nderg
7675         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7676      &    AKAderg(1,1,iii))
7677       enddo
7678 cd      if (lprn) write (2,*) 'In kernel'
7679       do kkk=1,5
7680 cd        if (lprn) write (2,*) 'kkk=',kkk
7681         do lll=1,3
7682           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7683      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7684 cd          if (lprn) then
7685 cd            write (2,*) 'lll=',lll
7686 cd            write (2,*) 'iii=1'
7687 cd            do jjj=1,2
7688 cd              write (2,'(3(2f10.5),5x)')
7689 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7690 cd            enddo
7691 cd          endif
7692           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7693      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7694 cd          if (lprn) then
7695 cd            write (2,*) 'lll=',lll
7696 cd            write (2,*) 'iii=2'
7697 cd            do jjj=1,2
7698 cd              write (2,'(3(2f10.5),5x)')
7699 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7700 cd            enddo
7701 cd          endif
7702         enddo
7703       enddo
7704       return
7705       end
7706 C---------------------------------------------------------------------------
7707       double precision function eello4(i,j,k,l,jj,kk)
7708       implicit real*8 (a-h,o-z)
7709       include 'DIMENSIONS'
7710       include 'COMMON.IOUNITS'
7711       include 'COMMON.CHAIN'
7712       include 'COMMON.DERIV'
7713       include 'COMMON.INTERACT'
7714       include 'COMMON.CONTACTS'
7715       include 'COMMON.TORSION'
7716       include 'COMMON.VAR'
7717       include 'COMMON.GEO'
7718       double precision pizda(2,2),ggg1(3),ggg2(3)
7719 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7720 cd        eello4=0.0d0
7721 cd        return
7722 cd      endif
7723 cd      print *,'eello4:',i,j,k,l,jj,kk
7724 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7725 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7726 cold      eij=facont_hb(jj,i)
7727 cold      ekl=facont_hb(kk,k)
7728 cold      ekont=eij*ekl
7729       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7730 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7731       gcorr_loc(k-1)=gcorr_loc(k-1)
7732      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7733       if (l.eq.j+1) then
7734         gcorr_loc(l-1)=gcorr_loc(l-1)
7735      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7736       else
7737         gcorr_loc(j-1)=gcorr_loc(j-1)
7738      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7739       endif
7740       do iii=1,2
7741         do kkk=1,5
7742           do lll=1,3
7743             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7744      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7745 cd            derx(lll,kkk,iii)=0.0d0
7746           enddo
7747         enddo
7748       enddo
7749 cd      gcorr_loc(l-1)=0.0d0
7750 cd      gcorr_loc(j-1)=0.0d0
7751 cd      gcorr_loc(k-1)=0.0d0
7752 cd      eel4=1.0d0
7753 cd      write (iout,*)'Contacts have occurred for peptide groups',
7754 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7755 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7756       if (j.lt.nres-1) then
7757         j1=j+1
7758         j2=j-1
7759       else
7760         j1=j-1
7761         j2=j-2
7762       endif
7763       if (l.lt.nres-1) then
7764         l1=l+1
7765         l2=l-1
7766       else
7767         l1=l-1
7768         l2=l-2
7769       endif
7770       do ll=1,3
7771 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7772 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7773         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7774         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7775 cgrad        ghalf=0.5d0*ggg1(ll)
7776         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7777         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7778         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7779         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7780         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7781         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7782 cgrad        ghalf=0.5d0*ggg2(ll)
7783         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7784         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7785         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7786         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7787         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7788         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7789       enddo
7790 cgrad      do m=i+1,j-1
7791 cgrad        do ll=1,3
7792 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7793 cgrad        enddo
7794 cgrad      enddo
7795 cgrad      do m=k+1,l-1
7796 cgrad        do ll=1,3
7797 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7798 cgrad        enddo
7799 cgrad      enddo
7800 cgrad      do m=i+2,j2
7801 cgrad        do ll=1,3
7802 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7803 cgrad        enddo
7804 cgrad      enddo
7805 cgrad      do m=k+2,l2
7806 cgrad        do ll=1,3
7807 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7808 cgrad        enddo
7809 cgrad      enddo
7810 cd      do iii=1,nres-3
7811 cd        write (2,*) iii,gcorr_loc(iii)
7812 cd      enddo
7813       eello4=ekont*eel4
7814 cd      write (2,*) 'ekont',ekont
7815 cd      write (iout,*) 'eello4',ekont*eel4
7816       return
7817       end
7818 C---------------------------------------------------------------------------
7819       double precision function eello5(i,j,k,l,jj,kk)
7820       implicit real*8 (a-h,o-z)
7821       include 'DIMENSIONS'
7822       include 'COMMON.IOUNITS'
7823       include 'COMMON.CHAIN'
7824       include 'COMMON.DERIV'
7825       include 'COMMON.INTERACT'
7826       include 'COMMON.CONTACTS'
7827       include 'COMMON.TORSION'
7828       include 'COMMON.VAR'
7829       include 'COMMON.GEO'
7830       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7831       double precision ggg1(3),ggg2(3)
7832 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7833 C                                                                              C
7834 C                            Parallel chains                                   C
7835 C                                                                              C
7836 C          o             o                   o             o                   C
7837 C         /l\           / \             \   / \           / \   /              C
7838 C        /   \         /   \             \ /   \         /   \ /               C
7839 C       j| o |l1       | o |              o| o |         | o |o                C
7840 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7841 C      \i/   \         /   \ /             /   \         /   \                 C
7842 C       o    k1             o                                                  C
7843 C         (I)          (II)                (III)          (IV)                 C
7844 C                                                                              C
7845 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7846 C                                                                              C
7847 C                            Antiparallel chains                               C
7848 C                                                                              C
7849 C          o             o                   o             o                   C
7850 C         /j\           / \             \   / \           / \   /              C
7851 C        /   \         /   \             \ /   \         /   \ /               C
7852 C      j1| o |l        | o |              o| o |         | o |o                C
7853 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7854 C      \i/   \         /   \ /             /   \         /   \                 C
7855 C       o     k1            o                                                  C
7856 C         (I)          (II)                (III)          (IV)                 C
7857 C                                                                              C
7858 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7859 C                                                                              C
7860 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7861 C                                                                              C
7862 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7863 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7864 cd        eello5=0.0d0
7865 cd        return
7866 cd      endif
7867 cd      write (iout,*)
7868 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7869 cd     &   ' and',k,l
7870       itk=itortyp(itype(k))
7871       itl=itortyp(itype(l))
7872       itj=itortyp(itype(j))
7873       eello5_1=0.0d0
7874       eello5_2=0.0d0
7875       eello5_3=0.0d0
7876       eello5_4=0.0d0
7877 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7878 cd     &   eel5_3_num,eel5_4_num)
7879       do iii=1,2
7880         do kkk=1,5
7881           do lll=1,3
7882             derx(lll,kkk,iii)=0.0d0
7883           enddo
7884         enddo
7885       enddo
7886 cd      eij=facont_hb(jj,i)
7887 cd      ekl=facont_hb(kk,k)
7888 cd      ekont=eij*ekl
7889 cd      write (iout,*)'Contacts have occurred for peptide groups',
7890 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7891 cd      goto 1111
7892 C Contribution from the graph I.
7893 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7894 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7895       call transpose2(EUg(1,1,k),auxmat(1,1))
7896       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7897       vv(1)=pizda(1,1)-pizda(2,2)
7898       vv(2)=pizda(1,2)+pizda(2,1)
7899       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7900      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7901 C Explicit gradient in virtual-dihedral angles.
7902       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7903      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7904      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7905       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7906       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7907       vv(1)=pizda(1,1)-pizda(2,2)
7908       vv(2)=pizda(1,2)+pizda(2,1)
7909       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7910      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7911      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7912       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7913       vv(1)=pizda(1,1)-pizda(2,2)
7914       vv(2)=pizda(1,2)+pizda(2,1)
7915       if (l.eq.j+1) then
7916         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7917      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7918      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7919       else
7920         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7921      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7922      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7923       endif
7924 C Cartesian gradient
7925       do iii=1,2
7926         do kkk=1,5
7927           do lll=1,3
7928             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7929      &        pizda(1,1))
7930             vv(1)=pizda(1,1)-pizda(2,2)
7931             vv(2)=pizda(1,2)+pizda(2,1)
7932             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7933      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7934      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7935           enddo
7936         enddo
7937       enddo
7938 c      goto 1112
7939 c1111  continue
7940 C Contribution from graph II
7941       call transpose2(EE(1,1,itk),auxmat(1,1))
7942       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7943       vv(1)=pizda(1,1)+pizda(2,2)
7944       vv(2)=pizda(2,1)-pizda(1,2)
7945       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7946      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7947 C Explicit gradient in virtual-dihedral angles.
7948       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7949      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7950       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7951       vv(1)=pizda(1,1)+pizda(2,2)
7952       vv(2)=pizda(2,1)-pizda(1,2)
7953       if (l.eq.j+1) then
7954         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7955      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7956      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7957       else
7958         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7959      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7960      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7961       endif
7962 C Cartesian gradient
7963       do iii=1,2
7964         do kkk=1,5
7965           do lll=1,3
7966             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7967      &        pizda(1,1))
7968             vv(1)=pizda(1,1)+pizda(2,2)
7969             vv(2)=pizda(2,1)-pizda(1,2)
7970             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7971      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7972      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7973           enddo
7974         enddo
7975       enddo
7976 cd      goto 1112
7977 cd1111  continue
7978       if (l.eq.j+1) then
7979 cd        goto 1110
7980 C Parallel orientation
7981 C Contribution from graph III
7982         call transpose2(EUg(1,1,l),auxmat(1,1))
7983         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7984         vv(1)=pizda(1,1)-pizda(2,2)
7985         vv(2)=pizda(1,2)+pizda(2,1)
7986         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7987      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7988 C Explicit gradient in virtual-dihedral angles.
7989         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7990      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7991      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7992         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7993         vv(1)=pizda(1,1)-pizda(2,2)
7994         vv(2)=pizda(1,2)+pizda(2,1)
7995         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7996      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7997      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7998         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7999         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8000         vv(1)=pizda(1,1)-pizda(2,2)
8001         vv(2)=pizda(1,2)+pizda(2,1)
8002         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8003      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8004      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8005 C Cartesian gradient
8006         do iii=1,2
8007           do kkk=1,5
8008             do lll=1,3
8009               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8010      &          pizda(1,1))
8011               vv(1)=pizda(1,1)-pizda(2,2)
8012               vv(2)=pizda(1,2)+pizda(2,1)
8013               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8014      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8015      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8016             enddo
8017           enddo
8018         enddo
8019 cd        goto 1112
8020 C Contribution from graph IV
8021 cd1110    continue
8022         call transpose2(EE(1,1,itl),auxmat(1,1))
8023         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8024         vv(1)=pizda(1,1)+pizda(2,2)
8025         vv(2)=pizda(2,1)-pizda(1,2)
8026         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8027      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8028 C Explicit gradient in virtual-dihedral angles.
8029         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8030      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8031         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8032         vv(1)=pizda(1,1)+pizda(2,2)
8033         vv(2)=pizda(2,1)-pizda(1,2)
8034         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8035      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8036      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8037 C Cartesian gradient
8038         do iii=1,2
8039           do kkk=1,5
8040             do lll=1,3
8041               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8042      &          pizda(1,1))
8043               vv(1)=pizda(1,1)+pizda(2,2)
8044               vv(2)=pizda(2,1)-pizda(1,2)
8045               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8046      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8047      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8048             enddo
8049           enddo
8050         enddo
8051       else
8052 C Antiparallel orientation
8053 C Contribution from graph III
8054 c        goto 1110
8055         call transpose2(EUg(1,1,j),auxmat(1,1))
8056         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8057         vv(1)=pizda(1,1)-pizda(2,2)
8058         vv(2)=pizda(1,2)+pizda(2,1)
8059         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8060      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8061 C Explicit gradient in virtual-dihedral angles.
8062         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8063      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8064      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8065         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8066         vv(1)=pizda(1,1)-pizda(2,2)
8067         vv(2)=pizda(1,2)+pizda(2,1)
8068         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8069      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8070      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8071         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8072         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8073         vv(1)=pizda(1,1)-pizda(2,2)
8074         vv(2)=pizda(1,2)+pizda(2,1)
8075         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8076      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8077      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8078 C Cartesian gradient
8079         do iii=1,2
8080           do kkk=1,5
8081             do lll=1,3
8082               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8083      &          pizda(1,1))
8084               vv(1)=pizda(1,1)-pizda(2,2)
8085               vv(2)=pizda(1,2)+pizda(2,1)
8086               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8087      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8088      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8089             enddo
8090           enddo
8091         enddo
8092 cd        goto 1112
8093 C Contribution from graph IV
8094 1110    continue
8095         call transpose2(EE(1,1,itj),auxmat(1,1))
8096         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8097         vv(1)=pizda(1,1)+pizda(2,2)
8098         vv(2)=pizda(2,1)-pizda(1,2)
8099         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8100      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8101 C Explicit gradient in virtual-dihedral angles.
8102         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8103      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8104         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8105         vv(1)=pizda(1,1)+pizda(2,2)
8106         vv(2)=pizda(2,1)-pizda(1,2)
8107         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8108      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8109      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8110 C Cartesian gradient
8111         do iii=1,2
8112           do kkk=1,5
8113             do lll=1,3
8114               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8115      &          pizda(1,1))
8116               vv(1)=pizda(1,1)+pizda(2,2)
8117               vv(2)=pizda(2,1)-pizda(1,2)
8118               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8119      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8120      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8121             enddo
8122           enddo
8123         enddo
8124       endif
8125 1112  continue
8126       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8127 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8128 cd        write (2,*) 'ijkl',i,j,k,l
8129 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8130 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8131 cd      endif
8132 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8133 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8134 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8135 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8136       if (j.lt.nres-1) then
8137         j1=j+1
8138         j2=j-1
8139       else
8140         j1=j-1
8141         j2=j-2
8142       endif
8143       if (l.lt.nres-1) then
8144         l1=l+1
8145         l2=l-1
8146       else
8147         l1=l-1
8148         l2=l-2
8149       endif
8150 cd      eij=1.0d0
8151 cd      ekl=1.0d0
8152 cd      ekont=1.0d0
8153 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8154 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8155 C        summed up outside the subrouine as for the other subroutines
8156 C        handling long-range interactions. The old code is commented out
8157 C        with "cgrad" to keep track of changes.
8158       do ll=1,3
8159 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8160 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8161         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8162         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8163 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8164 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8165 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8166 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8167 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8168 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8169 c     &   gradcorr5ij,
8170 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8171 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8172 cgrad        ghalf=0.5d0*ggg1(ll)
8173 cd        ghalf=0.0d0
8174         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8175         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8176         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8177         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8178         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8179         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8180 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8181 cgrad        ghalf=0.5d0*ggg2(ll)
8182 cd        ghalf=0.0d0
8183         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8184         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8185         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8186         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8187         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8188         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8189       enddo
8190 cd      goto 1112
8191 cgrad      do m=i+1,j-1
8192 cgrad        do ll=1,3
8193 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8194 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8195 cgrad        enddo
8196 cgrad      enddo
8197 cgrad      do m=k+1,l-1
8198 cgrad        do ll=1,3
8199 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8200 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8201 cgrad        enddo
8202 cgrad      enddo
8203 c1112  continue
8204 cgrad      do m=i+2,j2
8205 cgrad        do ll=1,3
8206 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8207 cgrad        enddo
8208 cgrad      enddo
8209 cgrad      do m=k+2,l2
8210 cgrad        do ll=1,3
8211 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8212 cgrad        enddo
8213 cgrad      enddo
8214 cd      do iii=1,nres-3
8215 cd        write (2,*) iii,g_corr5_loc(iii)
8216 cd      enddo
8217       eello5=ekont*eel5
8218 cd      write (2,*) 'ekont',ekont
8219 cd      write (iout,*) 'eello5',ekont*eel5
8220       return
8221       end
8222 c--------------------------------------------------------------------------
8223       double precision function eello6(i,j,k,l,jj,kk)
8224       implicit real*8 (a-h,o-z)
8225       include 'DIMENSIONS'
8226       include 'COMMON.IOUNITS'
8227       include 'COMMON.CHAIN'
8228       include 'COMMON.DERIV'
8229       include 'COMMON.INTERACT'
8230       include 'COMMON.CONTACTS'
8231       include 'COMMON.TORSION'
8232       include 'COMMON.VAR'
8233       include 'COMMON.GEO'
8234       include 'COMMON.FFIELD'
8235       double precision ggg1(3),ggg2(3)
8236 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8237 cd        eello6=0.0d0
8238 cd        return
8239 cd      endif
8240 cd      write (iout,*)
8241 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8242 cd     &   ' and',k,l
8243       eello6_1=0.0d0
8244       eello6_2=0.0d0
8245       eello6_3=0.0d0
8246       eello6_4=0.0d0
8247       eello6_5=0.0d0
8248       eello6_6=0.0d0
8249 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8250 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8251       do iii=1,2
8252         do kkk=1,5
8253           do lll=1,3
8254             derx(lll,kkk,iii)=0.0d0
8255           enddo
8256         enddo
8257       enddo
8258 cd      eij=facont_hb(jj,i)
8259 cd      ekl=facont_hb(kk,k)
8260 cd      ekont=eij*ekl
8261 cd      eij=1.0d0
8262 cd      ekl=1.0d0
8263 cd      ekont=1.0d0
8264       if (l.eq.j+1) then
8265         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8266         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8267         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8268         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8269         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8270         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8271       else
8272         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8273         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8274         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8275         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8276         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8277           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8278         else
8279           eello6_5=0.0d0
8280         endif
8281         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8282       endif
8283 C If turn contributions are considered, they will be handled separately.
8284       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8285 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8286 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8287 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8288 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8289 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8290 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8291 cd      goto 1112
8292       if (j.lt.nres-1) then
8293         j1=j+1
8294         j2=j-1
8295       else
8296         j1=j-1
8297         j2=j-2
8298       endif
8299       if (l.lt.nres-1) then
8300         l1=l+1
8301         l2=l-1
8302       else
8303         l1=l-1
8304         l2=l-2
8305       endif
8306       do ll=1,3
8307 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8308 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8309 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8310 cgrad        ghalf=0.5d0*ggg1(ll)
8311 cd        ghalf=0.0d0
8312         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8313         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8314         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8315         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8316         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8317         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8318         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8319         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8320 cgrad        ghalf=0.5d0*ggg2(ll)
8321 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8322 cd        ghalf=0.0d0
8323         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8324         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8325         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8326         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8327         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8328         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8329       enddo
8330 cd      goto 1112
8331 cgrad      do m=i+1,j-1
8332 cgrad        do ll=1,3
8333 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8334 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8335 cgrad        enddo
8336 cgrad      enddo
8337 cgrad      do m=k+1,l-1
8338 cgrad        do ll=1,3
8339 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8340 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8341 cgrad        enddo
8342 cgrad      enddo
8343 cgrad1112  continue
8344 cgrad      do m=i+2,j2
8345 cgrad        do ll=1,3
8346 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8347 cgrad        enddo
8348 cgrad      enddo
8349 cgrad      do m=k+2,l2
8350 cgrad        do ll=1,3
8351 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8352 cgrad        enddo
8353 cgrad      enddo
8354 cd      do iii=1,nres-3
8355 cd        write (2,*) iii,g_corr6_loc(iii)
8356 cd      enddo
8357       eello6=ekont*eel6
8358 cd      write (2,*) 'ekont',ekont
8359 cd      write (iout,*) 'eello6',ekont*eel6
8360       return
8361       end
8362 c--------------------------------------------------------------------------
8363       double precision function eello6_graph1(i,j,k,l,imat,swap)
8364       implicit real*8 (a-h,o-z)
8365       include 'DIMENSIONS'
8366       include 'COMMON.IOUNITS'
8367       include 'COMMON.CHAIN'
8368       include 'COMMON.DERIV'
8369       include 'COMMON.INTERACT'
8370       include 'COMMON.CONTACTS'
8371       include 'COMMON.TORSION'
8372       include 'COMMON.VAR'
8373       include 'COMMON.GEO'
8374       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8375       logical swap
8376       logical lprn
8377       common /kutas/ lprn
8378 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8379 C                                                                              C
8380 C      Parallel       Antiparallel                                             C
8381 C                                                                              C
8382 C          o             o                                                     C
8383 C         /l\           /j\                                                    C
8384 C        /   \         /   \                                                   C
8385 C       /| o |         | o |\                                                  C
8386 C     \ j|/k\|  /   \  |/k\|l /                                                C
8387 C      \ /   \ /     \ /   \ /                                                 C
8388 C       o     o       o     o                                                  C
8389 C       i             i                                                        C
8390 C                                                                              C
8391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8392       itk=itortyp(itype(k))
8393       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8394       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8395       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8396       call transpose2(EUgC(1,1,k),auxmat(1,1))
8397       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8398       vv1(1)=pizda1(1,1)-pizda1(2,2)
8399       vv1(2)=pizda1(1,2)+pizda1(2,1)
8400       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8401       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8402       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8403       s5=scalar2(vv(1),Dtobr2(1,i))
8404 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8405       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8406       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8407      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8408      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8409      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8410      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8411      & +scalar2(vv(1),Dtobr2der(1,i)))
8412       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8413       vv1(1)=pizda1(1,1)-pizda1(2,2)
8414       vv1(2)=pizda1(1,2)+pizda1(2,1)
8415       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8416       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8417       if (l.eq.j+1) then
8418         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8419      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8420      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8421      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8422      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8423       else
8424         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8425      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8426      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8427      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8428      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8429       endif
8430       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8431       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8432       vv1(1)=pizda1(1,1)-pizda1(2,2)
8433       vv1(2)=pizda1(1,2)+pizda1(2,1)
8434       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8435      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8436      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8437      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8438       do iii=1,2
8439         if (swap) then
8440           ind=3-iii
8441         else
8442           ind=iii
8443         endif
8444         do kkk=1,5
8445           do lll=1,3
8446             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8447             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8448             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8449             call transpose2(EUgC(1,1,k),auxmat(1,1))
8450             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8451      &        pizda1(1,1))
8452             vv1(1)=pizda1(1,1)-pizda1(2,2)
8453             vv1(2)=pizda1(1,2)+pizda1(2,1)
8454             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8455             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8456      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8457             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8458      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8459             s5=scalar2(vv(1),Dtobr2(1,i))
8460             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8461           enddo
8462         enddo
8463       enddo
8464       return
8465       end
8466 c----------------------------------------------------------------------------
8467       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8468       implicit real*8 (a-h,o-z)
8469       include 'DIMENSIONS'
8470       include 'COMMON.IOUNITS'
8471       include 'COMMON.CHAIN'
8472       include 'COMMON.DERIV'
8473       include 'COMMON.INTERACT'
8474       include 'COMMON.CONTACTS'
8475       include 'COMMON.TORSION'
8476       include 'COMMON.VAR'
8477       include 'COMMON.GEO'
8478       logical swap
8479       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8480      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8481       logical lprn
8482       common /kutas/ lprn
8483 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8484 C                                                                              C
8485 C      Parallel       Antiparallel                                             C
8486 C                                                                              C
8487 C          o             o                                                     C
8488 C     \   /l\           /j\   /                                                C
8489 C      \ /   \         /   \ /                                                 C
8490 C       o| o |         | o |o                                                  C
8491 C     \ j|/k\|      \  |/k\|l                                                  C
8492 C      \ /   \       \ /   \                                                   C
8493 C       o             o                                                        C
8494 C       i             i                                                        C
8495 C                                                                              C
8496 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8497 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8498 C AL 7/4/01 s1 would occur in the sixth-order moment,
8499 C           but not in a cluster cumulant
8500 #ifdef MOMENT
8501       s1=dip(1,jj,i)*dip(1,kk,k)
8502 #endif
8503       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8504       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8505       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8506       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8507       call transpose2(EUg(1,1,k),auxmat(1,1))
8508       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8509       vv(1)=pizda(1,1)-pizda(2,2)
8510       vv(2)=pizda(1,2)+pizda(2,1)
8511       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8512 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8513 #ifdef MOMENT
8514       eello6_graph2=-(s1+s2+s3+s4)
8515 #else
8516       eello6_graph2=-(s2+s3+s4)
8517 #endif
8518 c      eello6_graph2=-s3
8519 C Derivatives in gamma(i-1)
8520       if (i.gt.1) then
8521 #ifdef MOMENT
8522         s1=dipderg(1,jj,i)*dip(1,kk,k)
8523 #endif
8524         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8525         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8526         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8527         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8528 #ifdef MOMENT
8529         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8530 #else
8531         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8532 #endif
8533 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8534       endif
8535 C Derivatives in gamma(k-1)
8536 #ifdef MOMENT
8537       s1=dip(1,jj,i)*dipderg(1,kk,k)
8538 #endif
8539       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8540       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8541       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8542       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8543       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8544       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8545       vv(1)=pizda(1,1)-pizda(2,2)
8546       vv(2)=pizda(1,2)+pizda(2,1)
8547       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8548 #ifdef MOMENT
8549       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8550 #else
8551       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8552 #endif
8553 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8554 C Derivatives in gamma(j-1) or gamma(l-1)
8555       if (j.gt.1) then
8556 #ifdef MOMENT
8557         s1=dipderg(3,jj,i)*dip(1,kk,k)
8558 #endif
8559         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8560         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8561         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8562         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8563         vv(1)=pizda(1,1)-pizda(2,2)
8564         vv(2)=pizda(1,2)+pizda(2,1)
8565         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8566 #ifdef MOMENT
8567         if (swap) then
8568           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8569         else
8570           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8571         endif
8572 #endif
8573         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8574 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8575       endif
8576 C Derivatives in gamma(l-1) or gamma(j-1)
8577       if (l.gt.1) then
8578 #ifdef MOMENT
8579         s1=dip(1,jj,i)*dipderg(3,kk,k)
8580 #endif
8581         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8582         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8583         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8584         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8585         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8586         vv(1)=pizda(1,1)-pizda(2,2)
8587         vv(2)=pizda(1,2)+pizda(2,1)
8588         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8589 #ifdef MOMENT
8590         if (swap) then
8591           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8592         else
8593           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8594         endif
8595 #endif
8596         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8597 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8598       endif
8599 C Cartesian derivatives.
8600       if (lprn) then
8601         write (2,*) 'In eello6_graph2'
8602         do iii=1,2
8603           write (2,*) 'iii=',iii
8604           do kkk=1,5
8605             write (2,*) 'kkk=',kkk
8606             do jjj=1,2
8607               write (2,'(3(2f10.5),5x)')
8608      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8609             enddo
8610           enddo
8611         enddo
8612       endif
8613       do iii=1,2
8614         do kkk=1,5
8615           do lll=1,3
8616 #ifdef MOMENT
8617             if (iii.eq.1) then
8618               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8619             else
8620               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8621             endif
8622 #endif
8623             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8624      &        auxvec(1))
8625             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8626             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8627      &        auxvec(1))
8628             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8629             call transpose2(EUg(1,1,k),auxmat(1,1))
8630             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8631      &        pizda(1,1))
8632             vv(1)=pizda(1,1)-pizda(2,2)
8633             vv(2)=pizda(1,2)+pizda(2,1)
8634             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8635 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8636 #ifdef MOMENT
8637             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8638 #else
8639             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8640 #endif
8641             if (swap) then
8642               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8643             else
8644               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8645             endif
8646           enddo
8647         enddo
8648       enddo
8649       return
8650       end
8651 c----------------------------------------------------------------------------
8652       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8653       implicit real*8 (a-h,o-z)
8654       include 'DIMENSIONS'
8655       include 'COMMON.IOUNITS'
8656       include 'COMMON.CHAIN'
8657       include 'COMMON.DERIV'
8658       include 'COMMON.INTERACT'
8659       include 'COMMON.CONTACTS'
8660       include 'COMMON.TORSION'
8661       include 'COMMON.VAR'
8662       include 'COMMON.GEO'
8663       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8664       logical swap
8665 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8666 C                                                                              C
8667 C      Parallel       Antiparallel                                             C
8668 C                                                                              C
8669 C          o             o                                                     C
8670 C         /l\   /   \   /j\                                                    C
8671 C        /   \ /     \ /   \                                                   C
8672 C       /| o |o       o| o |\                                                  C
8673 C       j|/k\|  /      |/k\|l /                                                C
8674 C        /   \ /       /   \ /                                                 C
8675 C       /     o       /     o                                                  C
8676 C       i             i                                                        C
8677 C                                                                              C
8678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8679 C
8680 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8681 C           energy moment and not to the cluster cumulant.
8682       iti=itortyp(itype(i))
8683       if (j.lt.nres-1) then
8684         itj1=itortyp(itype(j+1))
8685       else
8686         itj1=ntortyp
8687       endif
8688       itk=itortyp(itype(k))
8689       itk1=itortyp(itype(k+1))
8690       if (l.lt.nres-1) then
8691         itl1=itortyp(itype(l+1))
8692       else
8693         itl1=ntortyp
8694       endif
8695 #ifdef MOMENT
8696       s1=dip(4,jj,i)*dip(4,kk,k)
8697 #endif
8698       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8699       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8700       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8701       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8702       call transpose2(EE(1,1,itk),auxmat(1,1))
8703       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8704       vv(1)=pizda(1,1)+pizda(2,2)
8705       vv(2)=pizda(2,1)-pizda(1,2)
8706       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8707 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8708 cd     & "sum",-(s2+s3+s4)
8709 #ifdef MOMENT
8710       eello6_graph3=-(s1+s2+s3+s4)
8711 #else
8712       eello6_graph3=-(s2+s3+s4)
8713 #endif
8714 c      eello6_graph3=-s4
8715 C Derivatives in gamma(k-1)
8716       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8717       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8718       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8719       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8720 C Derivatives in gamma(l-1)
8721       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8722       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8723       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8724       vv(1)=pizda(1,1)+pizda(2,2)
8725       vv(2)=pizda(2,1)-pizda(1,2)
8726       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8727       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8728 C Cartesian derivatives.
8729       do iii=1,2
8730         do kkk=1,5
8731           do lll=1,3
8732 #ifdef MOMENT
8733             if (iii.eq.1) then
8734               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8735             else
8736               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8737             endif
8738 #endif
8739             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8740      &        auxvec(1))
8741             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8742             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8743      &        auxvec(1))
8744             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8745             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8746      &        pizda(1,1))
8747             vv(1)=pizda(1,1)+pizda(2,2)
8748             vv(2)=pizda(2,1)-pizda(1,2)
8749             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8750 #ifdef MOMENT
8751             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8752 #else
8753             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8754 #endif
8755             if (swap) then
8756               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8757             else
8758               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8759             endif
8760 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8761           enddo
8762         enddo
8763       enddo
8764       return
8765       end
8766 c----------------------------------------------------------------------------
8767       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8768       implicit real*8 (a-h,o-z)
8769       include 'DIMENSIONS'
8770       include 'COMMON.IOUNITS'
8771       include 'COMMON.CHAIN'
8772       include 'COMMON.DERIV'
8773       include 'COMMON.INTERACT'
8774       include 'COMMON.CONTACTS'
8775       include 'COMMON.TORSION'
8776       include 'COMMON.VAR'
8777       include 'COMMON.GEO'
8778       include 'COMMON.FFIELD'
8779       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8780      & auxvec1(2),auxmat1(2,2)
8781       logical swap
8782 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8783 C                                                                              C
8784 C      Parallel       Antiparallel                                             C
8785 C                                                                              C
8786 C          o             o                                                     C
8787 C         /l\   /   \   /j\                                                    C
8788 C        /   \ /     \ /   \                                                   C
8789 C       /| o |o       o| o |\                                                  C
8790 C     \ j|/k\|      \  |/k\|l                                                  C
8791 C      \ /   \       \ /   \                                                   C
8792 C       o     \       o     \                                                  C
8793 C       i             i                                                        C
8794 C                                                                              C
8795 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8796 C
8797 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8798 C           energy moment and not to the cluster cumulant.
8799 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8800       iti=itortyp(itype(i))
8801       itj=itortyp(itype(j))
8802       if (j.lt.nres-1) then
8803         itj1=itortyp(itype(j+1))
8804       else
8805         itj1=ntortyp
8806       endif
8807       itk=itortyp(itype(k))
8808       if (k.lt.nres-1) then
8809         itk1=itortyp(itype(k+1))
8810       else
8811         itk1=ntortyp
8812       endif
8813       itl=itortyp(itype(l))
8814       if (l.lt.nres-1) then
8815         itl1=itortyp(itype(l+1))
8816       else
8817         itl1=ntortyp
8818       endif
8819 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8820 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8821 cd     & ' itl',itl,' itl1',itl1
8822 #ifdef MOMENT
8823       if (imat.eq.1) then
8824         s1=dip(3,jj,i)*dip(3,kk,k)
8825       else
8826         s1=dip(2,jj,j)*dip(2,kk,l)
8827       endif
8828 #endif
8829       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8830       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8831       if (j.eq.l+1) then
8832         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8833         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8834       else
8835         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8836         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8837       endif
8838       call transpose2(EUg(1,1,k),auxmat(1,1))
8839       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8840       vv(1)=pizda(1,1)-pizda(2,2)
8841       vv(2)=pizda(2,1)+pizda(1,2)
8842       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8843 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8844 #ifdef MOMENT
8845       eello6_graph4=-(s1+s2+s3+s4)
8846 #else
8847       eello6_graph4=-(s2+s3+s4)
8848 #endif
8849 C Derivatives in gamma(i-1)
8850       if (i.gt.1) then
8851 #ifdef MOMENT
8852         if (imat.eq.1) then
8853           s1=dipderg(2,jj,i)*dip(3,kk,k)
8854         else
8855           s1=dipderg(4,jj,j)*dip(2,kk,l)
8856         endif
8857 #endif
8858         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8859         if (j.eq.l+1) then
8860           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8861           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8862         else
8863           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8864           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8865         endif
8866         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8867         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8868 cd          write (2,*) 'turn6 derivatives'
8869 #ifdef MOMENT
8870           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8871 #else
8872           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8873 #endif
8874         else
8875 #ifdef MOMENT
8876           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8877 #else
8878           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8879 #endif
8880         endif
8881       endif
8882 C Derivatives in gamma(k-1)
8883 #ifdef MOMENT
8884       if (imat.eq.1) then
8885         s1=dip(3,jj,i)*dipderg(2,kk,k)
8886       else
8887         s1=dip(2,jj,j)*dipderg(4,kk,l)
8888       endif
8889 #endif
8890       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8891       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8892       if (j.eq.l+1) then
8893         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8894         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8895       else
8896         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8897         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8898       endif
8899       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8900       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8901       vv(1)=pizda(1,1)-pizda(2,2)
8902       vv(2)=pizda(2,1)+pizda(1,2)
8903       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8904       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8905 #ifdef MOMENT
8906         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8907 #else
8908         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8909 #endif
8910       else
8911 #ifdef MOMENT
8912         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8913 #else
8914         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8915 #endif
8916       endif
8917 C Derivatives in gamma(j-1) or gamma(l-1)
8918       if (l.eq.j+1 .and. l.gt.1) then
8919         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8920         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8921         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8922         vv(1)=pizda(1,1)-pizda(2,2)
8923         vv(2)=pizda(2,1)+pizda(1,2)
8924         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8925         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8926       else if (j.gt.1) then
8927         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8928         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8929         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8930         vv(1)=pizda(1,1)-pizda(2,2)
8931         vv(2)=pizda(2,1)+pizda(1,2)
8932         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8933         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8934           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8935         else
8936           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8937         endif
8938       endif
8939 C Cartesian derivatives.
8940       do iii=1,2
8941         do kkk=1,5
8942           do lll=1,3
8943 #ifdef MOMENT
8944             if (iii.eq.1) then
8945               if (imat.eq.1) then
8946                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8947               else
8948                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8949               endif
8950             else
8951               if (imat.eq.1) then
8952                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8953               else
8954                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8955               endif
8956             endif
8957 #endif
8958             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8959      &        auxvec(1))
8960             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8961             if (j.eq.l+1) then
8962               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8963      &          b1(1,itj1),auxvec(1))
8964               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8965             else
8966               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8967      &          b1(1,itl1),auxvec(1))
8968               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8969             endif
8970             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8971      &        pizda(1,1))
8972             vv(1)=pizda(1,1)-pizda(2,2)
8973             vv(2)=pizda(2,1)+pizda(1,2)
8974             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8975             if (swap) then
8976               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8977 #ifdef MOMENT
8978                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8979      &             -(s1+s2+s4)
8980 #else
8981                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8982      &             -(s2+s4)
8983 #endif
8984                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8985               else
8986 #ifdef MOMENT
8987                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8988 #else
8989                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8990 #endif
8991                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8992               endif
8993             else
8994 #ifdef MOMENT
8995               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8996 #else
8997               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8998 #endif
8999               if (l.eq.j+1) then
9000                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9001               else
9002                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9003               endif
9004             endif
9005           enddo
9006         enddo
9007       enddo
9008       return
9009       end
9010 c----------------------------------------------------------------------------
9011       double precision function eello_turn6(i,jj,kk)
9012       implicit real*8 (a-h,o-z)
9013       include 'DIMENSIONS'
9014       include 'COMMON.IOUNITS'
9015       include 'COMMON.CHAIN'
9016       include 'COMMON.DERIV'
9017       include 'COMMON.INTERACT'
9018       include 'COMMON.CONTACTS'
9019       include 'COMMON.TORSION'
9020       include 'COMMON.VAR'
9021       include 'COMMON.GEO'
9022       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9023      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9024      &  ggg1(3),ggg2(3)
9025       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9026      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9027 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9028 C           the respective energy moment and not to the cluster cumulant.
9029       s1=0.0d0
9030       s8=0.0d0
9031       s13=0.0d0
9032 c
9033       eello_turn6=0.0d0
9034       j=i+4
9035       k=i+1
9036       l=i+3
9037       iti=itortyp(itype(i))
9038       itk=itortyp(itype(k))
9039       itk1=itortyp(itype(k+1))
9040       itl=itortyp(itype(l))
9041       itj=itortyp(itype(j))
9042 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9043 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9044 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9045 cd        eello6=0.0d0
9046 cd        return
9047 cd      endif
9048 cd      write (iout,*)
9049 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9050 cd     &   ' and',k,l
9051 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9052       do iii=1,2
9053         do kkk=1,5
9054           do lll=1,3
9055             derx_turn(lll,kkk,iii)=0.0d0
9056           enddo
9057         enddo
9058       enddo
9059 cd      eij=1.0d0
9060 cd      ekl=1.0d0
9061 cd      ekont=1.0d0
9062       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9063 cd      eello6_5=0.0d0
9064 cd      write (2,*) 'eello6_5',eello6_5
9065 #ifdef MOMENT
9066       call transpose2(AEA(1,1,1),auxmat(1,1))
9067       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9068       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9069       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9070 #endif
9071       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9072       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9073       s2 = scalar2(b1(1,itk),vtemp1(1))
9074 #ifdef MOMENT
9075       call transpose2(AEA(1,1,2),atemp(1,1))
9076       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9077       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9078       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9079 #endif
9080       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9081       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9082       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9083 #ifdef MOMENT
9084       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9085       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9086       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9087       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9088       ss13 = scalar2(b1(1,itk),vtemp4(1))
9089       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9090 #endif
9091 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9092 c      s1=0.0d0
9093 c      s2=0.0d0
9094 c      s8=0.0d0
9095 c      s12=0.0d0
9096 c      s13=0.0d0
9097       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9098 C Derivatives in gamma(i+2)
9099       s1d =0.0d0
9100       s8d =0.0d0
9101 #ifdef MOMENT
9102       call transpose2(AEA(1,1,1),auxmatd(1,1))
9103       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9104       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9105       call transpose2(AEAderg(1,1,2),atempd(1,1))
9106       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9107       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9108 #endif
9109       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9110       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9111       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9112 c      s1d=0.0d0
9113 c      s2d=0.0d0
9114 c      s8d=0.0d0
9115 c      s12d=0.0d0
9116 c      s13d=0.0d0
9117       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9118 C Derivatives in gamma(i+3)
9119 #ifdef MOMENT
9120       call transpose2(AEA(1,1,1),auxmatd(1,1))
9121       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9122       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9123       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9124 #endif
9125       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9126       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9127       s2d = scalar2(b1(1,itk),vtemp1d(1))
9128 #ifdef MOMENT
9129       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9130       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9131 #endif
9132       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9133 #ifdef MOMENT
9134       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9135       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9136       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9137 #endif
9138 c      s1d=0.0d0
9139 c      s2d=0.0d0
9140 c      s8d=0.0d0
9141 c      s12d=0.0d0
9142 c      s13d=0.0d0
9143 #ifdef MOMENT
9144       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9145      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9146 #else
9147       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9148      &               -0.5d0*ekont*(s2d+s12d)
9149 #endif
9150 C Derivatives in gamma(i+4)
9151       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9152       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9153       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9154 #ifdef MOMENT
9155       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9156       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9157       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9158 #endif
9159 c      s1d=0.0d0
9160 c      s2d=0.0d0
9161 c      s8d=0.0d0
9162 C      s12d=0.0d0
9163 c      s13d=0.0d0
9164 #ifdef MOMENT
9165       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9166 #else
9167       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9168 #endif
9169 C Derivatives in gamma(i+5)
9170 #ifdef MOMENT
9171       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9172       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9173       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9174 #endif
9175       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9176       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9177       s2d = scalar2(b1(1,itk),vtemp1d(1))
9178 #ifdef MOMENT
9179       call transpose2(AEA(1,1,2),atempd(1,1))
9180       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9181       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9182 #endif
9183       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9184       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9185 #ifdef MOMENT
9186       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9187       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9188       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9189 #endif
9190 c      s1d=0.0d0
9191 c      s2d=0.0d0
9192 c      s8d=0.0d0
9193 c      s12d=0.0d0
9194 c      s13d=0.0d0
9195 #ifdef MOMENT
9196       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9197      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9198 #else
9199       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9200      &               -0.5d0*ekont*(s2d+s12d)
9201 #endif
9202 C Cartesian derivatives
9203       do iii=1,2
9204         do kkk=1,5
9205           do lll=1,3
9206 #ifdef MOMENT
9207             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9208             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9209             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9210 #endif
9211             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9212             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9213      &          vtemp1d(1))
9214             s2d = scalar2(b1(1,itk),vtemp1d(1))
9215 #ifdef MOMENT
9216             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9217             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9218             s8d = -(atempd(1,1)+atempd(2,2))*
9219      &           scalar2(cc(1,1,itl),vtemp2(1))
9220 #endif
9221             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9222      &           auxmatd(1,1))
9223             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9224             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9225 c      s1d=0.0d0
9226 c      s2d=0.0d0
9227 c      s8d=0.0d0
9228 c      s12d=0.0d0
9229 c      s13d=0.0d0
9230 #ifdef MOMENT
9231             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9232      &        - 0.5d0*(s1d+s2d)
9233 #else
9234             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9235      &        - 0.5d0*s2d
9236 #endif
9237 #ifdef MOMENT
9238             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9239      &        - 0.5d0*(s8d+s12d)
9240 #else
9241             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9242      &        - 0.5d0*s12d
9243 #endif
9244           enddo
9245         enddo
9246       enddo
9247 #ifdef MOMENT
9248       do kkk=1,5
9249         do lll=1,3
9250           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9251      &      achuj_tempd(1,1))
9252           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9253           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9254           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9255           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9256           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9257      &      vtemp4d(1))
9258           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9259           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9260           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9261         enddo
9262       enddo
9263 #endif
9264 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9265 cd     &  16*eel_turn6_num
9266 cd      goto 1112
9267       if (j.lt.nres-1) then
9268         j1=j+1
9269         j2=j-1
9270       else
9271         j1=j-1
9272         j2=j-2
9273       endif
9274       if (l.lt.nres-1) then
9275         l1=l+1
9276         l2=l-1
9277       else
9278         l1=l-1
9279         l2=l-2
9280       endif
9281       do ll=1,3
9282 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9283 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9284 cgrad        ghalf=0.5d0*ggg1(ll)
9285 cd        ghalf=0.0d0
9286         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9287         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9288         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9289      &    +ekont*derx_turn(ll,2,1)
9290         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9291         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9292      &    +ekont*derx_turn(ll,4,1)
9293         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9294         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9295         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9296 cgrad        ghalf=0.5d0*ggg2(ll)
9297 cd        ghalf=0.0d0
9298         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9299      &    +ekont*derx_turn(ll,2,2)
9300         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9301         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9302      &    +ekont*derx_turn(ll,4,2)
9303         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9304         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9305         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9306       enddo
9307 cd      goto 1112
9308 cgrad      do m=i+1,j-1
9309 cgrad        do ll=1,3
9310 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9311 cgrad        enddo
9312 cgrad      enddo
9313 cgrad      do m=k+1,l-1
9314 cgrad        do ll=1,3
9315 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9316 cgrad        enddo
9317 cgrad      enddo
9318 cgrad1112  continue
9319 cgrad      do m=i+2,j2
9320 cgrad        do ll=1,3
9321 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9322 cgrad        enddo
9323 cgrad      enddo
9324 cgrad      do m=k+2,l2
9325 cgrad        do ll=1,3
9326 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9327 cgrad        enddo
9328 cgrad      enddo
9329 cd      do iii=1,nres-3
9330 cd        write (2,*) iii,g_corr6_loc(iii)
9331 cd      enddo
9332       eello_turn6=ekont*eel_turn6
9333 cd      write (2,*) 'ekont',ekont
9334 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9335       return
9336       end
9337
9338 C-----------------------------------------------------------------------------
9339       double precision function scalar(u,v)
9340 !DIR$ INLINEALWAYS scalar
9341 #ifndef OSF
9342 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9343 #endif
9344       implicit none
9345       double precision u(3),v(3)
9346 cd      double precision sc
9347 cd      integer i
9348 cd      sc=0.0d0
9349 cd      do i=1,3
9350 cd        sc=sc+u(i)*v(i)
9351 cd      enddo
9352 cd      scalar=sc
9353
9354       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9355       return
9356       end
9357 crc-------------------------------------------------
9358       SUBROUTINE MATVEC2(A1,V1,V2)
9359 !DIR$ INLINEALWAYS MATVEC2
9360 #ifndef OSF
9361 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9362 #endif
9363       implicit real*8 (a-h,o-z)
9364       include 'DIMENSIONS'
9365       DIMENSION A1(2,2),V1(2),V2(2)
9366 c      DO 1 I=1,2
9367 c        VI=0.0
9368 c        DO 3 K=1,2
9369 c    3     VI=VI+A1(I,K)*V1(K)
9370 c        Vaux(I)=VI
9371 c    1 CONTINUE
9372
9373       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9374       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9375
9376       v2(1)=vaux1
9377       v2(2)=vaux2
9378       END
9379 C---------------------------------------
9380       SUBROUTINE MATMAT2(A1,A2,A3)
9381 #ifndef OSF
9382 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9383 #endif
9384       implicit real*8 (a-h,o-z)
9385       include 'DIMENSIONS'
9386       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9387 c      DIMENSION AI3(2,2)
9388 c        DO  J=1,2
9389 c          A3IJ=0.0
9390 c          DO K=1,2
9391 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9392 c          enddo
9393 c          A3(I,J)=A3IJ
9394 c       enddo
9395 c      enddo
9396
9397       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9398       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9399       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9400       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9401
9402       A3(1,1)=AI3_11
9403       A3(2,1)=AI3_21
9404       A3(1,2)=AI3_12
9405       A3(2,2)=AI3_22
9406       END
9407
9408 c-------------------------------------------------------------------------
9409       double precision function scalar2(u,v)
9410 !DIR$ INLINEALWAYS scalar2
9411       implicit none
9412       double precision u(2),v(2)
9413       double precision sc
9414       integer i
9415       scalar2=u(1)*v(1)+u(2)*v(2)
9416       return
9417       end
9418
9419 C-----------------------------------------------------------------------------
9420
9421       subroutine transpose2(a,at)
9422 !DIR$ INLINEALWAYS transpose2
9423 #ifndef OSF
9424 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9425 #endif
9426       implicit none
9427       double precision a(2,2),at(2,2)
9428       at(1,1)=a(1,1)
9429       at(1,2)=a(2,1)
9430       at(2,1)=a(1,2)
9431       at(2,2)=a(2,2)
9432       return
9433       end
9434 c--------------------------------------------------------------------------
9435       subroutine transpose(n,a,at)
9436       implicit none
9437       integer n,i,j
9438       double precision a(n,n),at(n,n)
9439       do i=1,n
9440         do j=1,n
9441           at(j,i)=a(i,j)
9442         enddo
9443       enddo
9444       return
9445       end
9446 C---------------------------------------------------------------------------
9447       subroutine prodmat3(a1,a2,kk,transp,prod)
9448 !DIR$ INLINEALWAYS prodmat3
9449 #ifndef OSF
9450 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9451 #endif
9452       implicit none
9453       integer i,j
9454       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9455       logical transp
9456 crc      double precision auxmat(2,2),prod_(2,2)
9457
9458       if (transp) then
9459 crc        call transpose2(kk(1,1),auxmat(1,1))
9460 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9461 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9462
9463            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9464      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9465            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9466      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9467            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9468      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9469            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9470      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9471
9472       else
9473 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9474 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9475
9476            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9477      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9478            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9479      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9480            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9481      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9482            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9483      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9484
9485       endif
9486 c      call transpose2(a2(1,1),a2t(1,1))
9487
9488 crc      print *,transp
9489 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9490 crc      print *,((prod(i,j),i=1,2),j=1,2)
9491
9492       return
9493       end
9494