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
1470         dxi=dc_norm(1,nres+i)
1471         dyi=dc_norm(2,nres+i)
1472         dzi=dc_norm(3,nres+i)
1473 c        dsci_inv=dsc_inv(itypi)
1474         dsci_inv=vbld_inv(i+nres)
1475 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1476 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1477 C
1478 C Calculate SC interaction energy.
1479 C
1480         do iint=1,nint_gr(i)
1481           do j=istart(i,iint),iend(i,iint)
1482             ind=ind+1
1483             itypj=iabs(itype(j))
1484             if (itypj.eq.ntyp1) cycle
1485 c            dscj_inv=dsc_inv(itypj)
1486             dscj_inv=vbld_inv(j+nres)
1487 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1488 c     &       1.0d0/vbld(j+nres)
1489 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1490             sig0ij=sigma(itypi,itypj)
1491             chi1=chi(itypi,itypj)
1492             chi2=chi(itypj,itypi)
1493             chi12=chi1*chi2
1494             chip1=chip(itypi)
1495             chip2=chip(itypj)
1496             chip12=chip1*chip2
1497             alf1=alp(itypi)
1498             alf2=alp(itypj)
1499             alf12=0.5D0*(alf1+alf2)
1500 C For diagnostics only!!!
1501 c           chi1=0.0D0
1502 c           chi2=0.0D0
1503 c           chi12=0.0D0
1504 c           chip1=0.0D0
1505 c           chip2=0.0D0
1506 c           chip12=0.0D0
1507 c           alf1=0.0D0
1508 c           alf2=0.0D0
1509 c           alf12=0.0D0
1510             xj=c(1,nres+j)
1511             yj=c(2,nres+j)
1512             zj=c(3,nres+j)
1513 C Return atom J into box the original box
1514 c  137   continue
1515 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1516 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1517 C Condition for being inside the proper box
1518 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1519 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1520 c        go to 137
1521 c        endif
1522 c  138   continue
1523 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1524 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1525 C Condition for being inside the proper box
1526 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1527 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1528 c        go to 138
1529 c        endif
1530 c  139   continue
1531 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1532 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1533 C Condition for being inside the proper box
1534 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1535 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1536 c        go to 139
1537 c        endif
1538           xj=mod(xj,boxxsize)
1539           if (xj.lt.0) xj=xj+boxxsize
1540           yj=mod(yj,boxysize)
1541           if (yj.lt.0) yj=yj+boxysize
1542           zj=mod(zj,boxzsize)
1543           if (zj.lt.0) zj=zj+boxzsize
1544             dxj=dc_norm(1,nres+j)
1545             dyj=dc_norm(2,nres+j)
1546             dzj=dc_norm(3,nres+j)
1547             xj=xj-xi
1548             yj=yj-yi
1549             zj=zj-zi
1550 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1551 c            write (iout,*) "j",j," dc_norm",
1552 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1553             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1554             rij=dsqrt(rrij)
1555             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1556             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1557
1558 c            write (iout,'(a7,4f8.3)')
1559 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1560             if (sss.gt.0.0d0) then
1561 C Calculate angle-dependent terms of energy and contributions to their
1562 C derivatives.
1563             call sc_angular
1564             sigsq=1.0D0/sigsq
1565             sig=sig0ij*dsqrt(sigsq)
1566             rij_shift=1.0D0/rij-sig+sig0ij
1567 c for diagnostics; uncomment
1568 c            rij_shift=1.2*sig0ij
1569 C I hate to put IF's in the loops, but here don't have another choice!!!!
1570             if (rij_shift.le.0.0D0) then
1571               evdw=1.0D20
1572 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1573 cd     &        restyp(itypi),i,restyp(itypj),j,
1574 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1575               return
1576             endif
1577             sigder=-sig*sigsq
1578 c---------------------------------------------------------------
1579             rij_shift=1.0D0/rij_shift
1580             fac=rij_shift**expon
1581             e1=fac*fac*aa(itypi,itypj)
1582             e2=fac*bb(itypi,itypj)
1583             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1584             eps2der=evdwij*eps3rt
1585             eps3der=evdwij*eps2rt
1586 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1587 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1588             evdwij=evdwij*eps2rt*eps3rt
1589             evdw=evdw+evdwij*sss
1590             if (lprn) then
1591             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1592             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1593             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1594      &        restyp(itypi),i,restyp(itypj),j,
1595      &        epsi,sigm,chi1,chi2,chip1,chip2,
1596      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1597      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1598      &        evdwij
1599             endif
1600
1601             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1602      &                        'evdw',i,j,evdwij
1603
1604 C Calculate gradient components.
1605             e1=e1*eps1*eps2rt**2*eps3rt**2
1606             fac=-expon*(e1+evdwij)*rij_shift
1607             sigder=fac*sigder
1608             fac=rij*fac
1609 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1610 c     &      evdwij,fac,sigma(itypi,itypj),expon
1611             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1612 c            fac=0.0d0
1613 C Calculate the radial part of the gradient
1614             gg(1)=xj*fac
1615             gg(2)=yj*fac
1616             gg(3)=zj*fac
1617 C Calculate angular part of the gradient.
1618             call sc_grad
1619             endif
1620           enddo      ! j
1621         enddo        ! iint
1622       enddo          ! i
1623       enddo          ! zshift
1624       enddo          ! yshift
1625       enddo          ! xshift
1626 c      write (iout,*) "Number of loop steps in EGB:",ind
1627 cccc      energy_dec=.false.
1628       return
1629       end
1630 C-----------------------------------------------------------------------------
1631       subroutine egbv(evdw)
1632 C
1633 C This subroutine calculates the interaction energy of nonbonded side chains
1634 C assuming the Gay-Berne-Vorobjev potential of interaction.
1635 C
1636       implicit real*8 (a-h,o-z)
1637       include 'DIMENSIONS'
1638       include 'COMMON.GEO'
1639       include 'COMMON.VAR'
1640       include 'COMMON.LOCAL'
1641       include 'COMMON.CHAIN'
1642       include 'COMMON.DERIV'
1643       include 'COMMON.NAMES'
1644       include 'COMMON.INTERACT'
1645       include 'COMMON.IOUNITS'
1646       include 'COMMON.CALC'
1647       common /srutu/ icall
1648       logical lprn
1649       evdw=0.0D0
1650 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1651       evdw=0.0D0
1652       lprn=.false.
1653 c     if (icall.eq.0) lprn=.true.
1654       ind=0
1655       do i=iatsc_s,iatsc_e
1656         itypi=iabs(itype(i))
1657         if (itypi.eq.ntyp1) cycle
1658         itypi1=iabs(itype(i+1))
1659         xi=c(1,nres+i)
1660         yi=c(2,nres+i)
1661         zi=c(3,nres+i)
1662         dxi=dc_norm(1,nres+i)
1663         dyi=dc_norm(2,nres+i)
1664         dzi=dc_norm(3,nres+i)
1665 c        dsci_inv=dsc_inv(itypi)
1666         dsci_inv=vbld_inv(i+nres)
1667 C
1668 C Calculate SC interaction energy.
1669 C
1670         do iint=1,nint_gr(i)
1671           do j=istart(i,iint),iend(i,iint)
1672             ind=ind+1
1673             itypj=iabs(itype(j))
1674             if (itypj.eq.ntyp1) cycle
1675 c            dscj_inv=dsc_inv(itypj)
1676             dscj_inv=vbld_inv(j+nres)
1677             sig0ij=sigma(itypi,itypj)
1678             r0ij=r0(itypi,itypj)
1679             chi1=chi(itypi,itypj)
1680             chi2=chi(itypj,itypi)
1681             chi12=chi1*chi2
1682             chip1=chip(itypi)
1683             chip2=chip(itypj)
1684             chip12=chip1*chip2
1685             alf1=alp(itypi)
1686             alf2=alp(itypj)
1687             alf12=0.5D0*(alf1+alf2)
1688 C For diagnostics only!!!
1689 c           chi1=0.0D0
1690 c           chi2=0.0D0
1691 c           chi12=0.0D0
1692 c           chip1=0.0D0
1693 c           chip2=0.0D0
1694 c           chip12=0.0D0
1695 c           alf1=0.0D0
1696 c           alf2=0.0D0
1697 c           alf12=0.0D0
1698             xj=c(1,nres+j)-xi
1699             yj=c(2,nres+j)-yi
1700             zj=c(3,nres+j)-zi
1701             dxj=dc_norm(1,nres+j)
1702             dyj=dc_norm(2,nres+j)
1703             dzj=dc_norm(3,nres+j)
1704             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1705             rij=dsqrt(rrij)
1706 C Calculate angle-dependent terms of energy and contributions to their
1707 C derivatives.
1708             call sc_angular
1709             sigsq=1.0D0/sigsq
1710             sig=sig0ij*dsqrt(sigsq)
1711             rij_shift=1.0D0/rij-sig+r0ij
1712 C I hate to put IF's in the loops, but here don't have another choice!!!!
1713             if (rij_shift.le.0.0D0) then
1714               evdw=1.0D20
1715               return
1716             endif
1717             sigder=-sig*sigsq
1718 c---------------------------------------------------------------
1719             rij_shift=1.0D0/rij_shift
1720             fac=rij_shift**expon
1721             e1=fac*fac*aa(itypi,itypj)
1722             e2=fac*bb(itypi,itypj)
1723             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1724             eps2der=evdwij*eps3rt
1725             eps3der=evdwij*eps2rt
1726             fac_augm=rrij**expon
1727             e_augm=augm(itypi,itypj)*fac_augm
1728             evdwij=evdwij*eps2rt*eps3rt
1729             evdw=evdw+evdwij+e_augm
1730             if (lprn) then
1731             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1732             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1733             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1734      &        restyp(itypi),i,restyp(itypj),j,
1735      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1736      &        chi1,chi2,chip1,chip2,
1737      &        eps1,eps2rt**2,eps3rt**2,
1738      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1739      &        evdwij+e_augm
1740             endif
1741 C Calculate gradient components.
1742             e1=e1*eps1*eps2rt**2*eps3rt**2
1743             fac=-expon*(e1+evdwij)*rij_shift
1744             sigder=fac*sigder
1745             fac=rij*fac-2*expon*rrij*e_augm
1746 C Calculate the radial part of the gradient
1747             gg(1)=xj*fac
1748             gg(2)=yj*fac
1749             gg(3)=zj*fac
1750 C Calculate angular part of the gradient.
1751             call sc_grad
1752           enddo      ! j
1753         enddo        ! iint
1754       enddo          ! i
1755       end
1756 C-----------------------------------------------------------------------------
1757       subroutine sc_angular
1758 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1759 C om12. Called by ebp, egb, and egbv.
1760       implicit none
1761       include 'COMMON.CALC'
1762       include 'COMMON.IOUNITS'
1763       erij(1)=xj*rij
1764       erij(2)=yj*rij
1765       erij(3)=zj*rij
1766       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1767       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1768       om12=dxi*dxj+dyi*dyj+dzi*dzj
1769       chiom12=chi12*om12
1770 C Calculate eps1(om12) and its derivative in om12
1771       faceps1=1.0D0-om12*chiom12
1772       faceps1_inv=1.0D0/faceps1
1773       eps1=dsqrt(faceps1_inv)
1774 C Following variable is eps1*deps1/dom12
1775       eps1_om12=faceps1_inv*chiom12
1776 c diagnostics only
1777 c      faceps1_inv=om12
1778 c      eps1=om12
1779 c      eps1_om12=1.0d0
1780 c      write (iout,*) "om12",om12," eps1",eps1
1781 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1782 C and om12.
1783       om1om2=om1*om2
1784       chiom1=chi1*om1
1785       chiom2=chi2*om2
1786       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1787       sigsq=1.0D0-facsig*faceps1_inv
1788       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1789       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1790       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1791 c diagnostics only
1792 c      sigsq=1.0d0
1793 c      sigsq_om1=0.0d0
1794 c      sigsq_om2=0.0d0
1795 c      sigsq_om12=0.0d0
1796 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1797 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1798 c     &    " eps1",eps1
1799 C Calculate eps2 and its derivatives in om1, om2, and om12.
1800       chipom1=chip1*om1
1801       chipom2=chip2*om2
1802       chipom12=chip12*om12
1803       facp=1.0D0-om12*chipom12
1804       facp_inv=1.0D0/facp
1805       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1806 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1807 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1808 C Following variable is the square root of eps2
1809       eps2rt=1.0D0-facp1*facp_inv
1810 C Following three variables are the derivatives of the square root of eps
1811 C in om1, om2, and om12.
1812       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1813       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1814       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1815 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1816       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1817 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1818 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1819 c     &  " eps2rt_om12",eps2rt_om12
1820 C Calculate whole angle-dependent part of epsilon and contributions
1821 C to its derivatives
1822       return
1823       end
1824 C----------------------------------------------------------------------------
1825       subroutine sc_grad
1826       implicit real*8 (a-h,o-z)
1827       include 'DIMENSIONS'
1828       include 'COMMON.CHAIN'
1829       include 'COMMON.DERIV'
1830       include 'COMMON.CALC'
1831       include 'COMMON.IOUNITS'
1832       double precision dcosom1(3),dcosom2(3)
1833 cc      print *,'sss=',sss
1834       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1835       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1836       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1837      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1838 c diagnostics only
1839 c      eom1=0.0d0
1840 c      eom2=0.0d0
1841 c      eom12=evdwij*eps1_om12
1842 c end diagnostics
1843 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1844 c     &  " sigder",sigder
1845 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1846 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1847       do k=1,3
1848         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1849         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1850       enddo
1851       do k=1,3
1852         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1853       enddo
1854 c      write (iout,*) "gg",(gg(k),k=1,3)
1855       do k=1,3
1856         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1857      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1858      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1859         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1860      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1861      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1862 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1863 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1864 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1865 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1866       enddo
1867 C
1868 C Calculate the components of the gradient in DC and X
1869 C
1870 cgrad      do k=i,j-1
1871 cgrad        do l=1,3
1872 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1873 cgrad        enddo
1874 cgrad      enddo
1875       do l=1,3
1876         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1877         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1878       enddo
1879       return
1880       end
1881 C-----------------------------------------------------------------------
1882       subroutine e_softsphere(evdw)
1883 C
1884 C This subroutine calculates the interaction energy of nonbonded side chains
1885 C assuming the LJ potential of interaction.
1886 C
1887       implicit real*8 (a-h,o-z)
1888       include 'DIMENSIONS'
1889       parameter (accur=1.0d-10)
1890       include 'COMMON.GEO'
1891       include 'COMMON.VAR'
1892       include 'COMMON.LOCAL'
1893       include 'COMMON.CHAIN'
1894       include 'COMMON.DERIV'
1895       include 'COMMON.INTERACT'
1896       include 'COMMON.TORSION'
1897       include 'COMMON.SBRIDGE'
1898       include 'COMMON.NAMES'
1899       include 'COMMON.IOUNITS'
1900       include 'COMMON.CONTACTS'
1901       dimension gg(3)
1902 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1903       evdw=0.0D0
1904       do i=iatsc_s,iatsc_e
1905         itypi=iabs(itype(i))
1906         if (itypi.eq.ntyp1) cycle
1907         itypi1=iabs(itype(i+1))
1908         xi=c(1,nres+i)
1909         yi=c(2,nres+i)
1910         zi=c(3,nres+i)
1911 C
1912 C Calculate SC interaction energy.
1913 C
1914         do iint=1,nint_gr(i)
1915 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1916 cd   &                  'iend=',iend(i,iint)
1917           do j=istart(i,iint),iend(i,iint)
1918             itypj=iabs(itype(j))
1919             if (itypj.eq.ntyp1) cycle
1920             xj=c(1,nres+j)-xi
1921             yj=c(2,nres+j)-yi
1922             zj=c(3,nres+j)-zi
1923             rij=xj*xj+yj*yj+zj*zj
1924 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1925             r0ij=r0(itypi,itypj)
1926             r0ijsq=r0ij*r0ij
1927 c            print *,i,j,r0ij,dsqrt(rij)
1928             if (rij.lt.r0ijsq) then
1929               evdwij=0.25d0*(rij-r0ijsq)**2
1930               fac=rij-r0ijsq
1931             else
1932               evdwij=0.0d0
1933               fac=0.0d0
1934             endif
1935             evdw=evdw+evdwij
1936 C
1937 C Calculate the components of the gradient in DC and X
1938 C
1939             gg(1)=xj*fac
1940             gg(2)=yj*fac
1941             gg(3)=zj*fac
1942             do k=1,3
1943               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1944               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1945               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1946               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1947             enddo
1948 cgrad            do k=i,j-1
1949 cgrad              do l=1,3
1950 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1951 cgrad              enddo
1952 cgrad            enddo
1953           enddo ! j
1954         enddo ! iint
1955       enddo ! i
1956       return
1957       end
1958 C--------------------------------------------------------------------------
1959       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1960      &              eello_turn4)
1961 C
1962 C Soft-sphere potential of p-p interaction
1963 C
1964       implicit real*8 (a-h,o-z)
1965       include 'DIMENSIONS'
1966       include 'COMMON.CONTROL'
1967       include 'COMMON.IOUNITS'
1968       include 'COMMON.GEO'
1969       include 'COMMON.VAR'
1970       include 'COMMON.LOCAL'
1971       include 'COMMON.CHAIN'
1972       include 'COMMON.DERIV'
1973       include 'COMMON.INTERACT'
1974       include 'COMMON.CONTACTS'
1975       include 'COMMON.TORSION'
1976       include 'COMMON.VECTORS'
1977       include 'COMMON.FFIELD'
1978       dimension ggg(3)
1979 cd      write(iout,*) 'In EELEC_soft_sphere'
1980       ees=0.0D0
1981       evdw1=0.0D0
1982       eel_loc=0.0d0
1983       eello_turn3=0.0d0
1984       eello_turn4=0.0d0
1985       ind=0
1986       do i=iatel_s,iatel_e
1987         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1988         dxi=dc(1,i)
1989         dyi=dc(2,i)
1990         dzi=dc(3,i)
1991         xmedi=c(1,i)+0.5d0*dxi
1992         ymedi=c(2,i)+0.5d0*dyi
1993         zmedi=c(3,i)+0.5d0*dzi
1994         num_conti=0
1995 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1996         do j=ielstart(i),ielend(i)
1997           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1998           ind=ind+1
1999           iteli=itel(i)
2000           itelj=itel(j)
2001           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2002           r0ij=rpp(iteli,itelj)
2003           r0ijsq=r0ij*r0ij
2004           dxj=dc(1,j)
2005           dyj=dc(2,j)
2006           dzj=dc(3,j)
2007           xj=c(1,j)+0.5D0*dxj-xmedi
2008           yj=c(2,j)+0.5D0*dyj-ymedi
2009           zj=c(3,j)+0.5D0*dzj-zmedi
2010           rij=xj*xj+yj*yj+zj*zj
2011           if (rij.lt.r0ijsq) then
2012             evdw1ij=0.25d0*(rij-r0ijsq)**2
2013             fac=rij-r0ijsq
2014           else
2015             evdw1ij=0.0d0
2016             fac=0.0d0
2017           endif
2018           evdw1=evdw1+evdw1ij
2019 C
2020 C Calculate contributions to the Cartesian gradient.
2021 C
2022           ggg(1)=fac*xj
2023           ggg(2)=fac*yj
2024           ggg(3)=fac*zj
2025           do k=1,3
2026             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2027             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2028           enddo
2029 *
2030 * Loop over residues i+1 thru j-1.
2031 *
2032 cgrad          do k=i+1,j-1
2033 cgrad            do l=1,3
2034 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2035 cgrad            enddo
2036 cgrad          enddo
2037         enddo ! j
2038       enddo   ! i
2039 cgrad      do i=nnt,nct-1
2040 cgrad        do k=1,3
2041 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2042 cgrad        enddo
2043 cgrad        do j=i+1,nct-1
2044 cgrad          do k=1,3
2045 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2046 cgrad          enddo
2047 cgrad        enddo
2048 cgrad      enddo
2049       return
2050       end
2051 c------------------------------------------------------------------------------
2052       subroutine vec_and_deriv
2053       implicit real*8 (a-h,o-z)
2054       include 'DIMENSIONS'
2055 #ifdef MPI
2056       include 'mpif.h'
2057 #endif
2058       include 'COMMON.IOUNITS'
2059       include 'COMMON.GEO'
2060       include 'COMMON.VAR'
2061       include 'COMMON.LOCAL'
2062       include 'COMMON.CHAIN'
2063       include 'COMMON.VECTORS'
2064       include 'COMMON.SETUP'
2065       include 'COMMON.TIME1'
2066       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2067 C Compute the local reference systems. For reference system (i), the
2068 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2069 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2070 #ifdef PARVEC
2071       do i=ivec_start,ivec_end
2072 #else
2073       do i=1,nres-1
2074 #endif
2075           if (i.eq.nres-1) then
2076 C Case of the last full residue
2077 C Compute the Z-axis
2078             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2079             costh=dcos(pi-theta(nres))
2080             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2081             do k=1,3
2082               uz(k,i)=fac*uz(k,i)
2083             enddo
2084 C Compute the derivatives of uz
2085             uzder(1,1,1)= 0.0d0
2086             uzder(2,1,1)=-dc_norm(3,i-1)
2087             uzder(3,1,1)= dc_norm(2,i-1)
2088             uzder(1,2,1)= dc_norm(3,i-1)
2089             uzder(2,2,1)= 0.0d0
2090             uzder(3,2,1)=-dc_norm(1,i-1)
2091             uzder(1,3,1)=-dc_norm(2,i-1)
2092             uzder(2,3,1)= dc_norm(1,i-1)
2093             uzder(3,3,1)= 0.0d0
2094             uzder(1,1,2)= 0.0d0
2095             uzder(2,1,2)= dc_norm(3,i)
2096             uzder(3,1,2)=-dc_norm(2,i)
2097             uzder(1,2,2)=-dc_norm(3,i)
2098             uzder(2,2,2)= 0.0d0
2099             uzder(3,2,2)= dc_norm(1,i)
2100             uzder(1,3,2)= dc_norm(2,i)
2101             uzder(2,3,2)=-dc_norm(1,i)
2102             uzder(3,3,2)= 0.0d0
2103 C Compute the Y-axis
2104             facy=fac
2105             do k=1,3
2106               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2107             enddo
2108 C Compute the derivatives of uy
2109             do j=1,3
2110               do k=1,3
2111                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2112      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2113                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2114               enddo
2115               uyder(j,j,1)=uyder(j,j,1)-costh
2116               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2117             enddo
2118             do j=1,2
2119               do k=1,3
2120                 do l=1,3
2121                   uygrad(l,k,j,i)=uyder(l,k,j)
2122                   uzgrad(l,k,j,i)=uzder(l,k,j)
2123                 enddo
2124               enddo
2125             enddo
2126             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2127             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2128             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2129             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2130           else
2131 C Other residues
2132 C Compute the Z-axis
2133             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2134             costh=dcos(pi-theta(i+2))
2135             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2136             do k=1,3
2137               uz(k,i)=fac*uz(k,i)
2138             enddo
2139 C Compute the derivatives of uz
2140             uzder(1,1,1)= 0.0d0
2141             uzder(2,1,1)=-dc_norm(3,i+1)
2142             uzder(3,1,1)= dc_norm(2,i+1)
2143             uzder(1,2,1)= dc_norm(3,i+1)
2144             uzder(2,2,1)= 0.0d0
2145             uzder(3,2,1)=-dc_norm(1,i+1)
2146             uzder(1,3,1)=-dc_norm(2,i+1)
2147             uzder(2,3,1)= dc_norm(1,i+1)
2148             uzder(3,3,1)= 0.0d0
2149             uzder(1,1,2)= 0.0d0
2150             uzder(2,1,2)= dc_norm(3,i)
2151             uzder(3,1,2)=-dc_norm(2,i)
2152             uzder(1,2,2)=-dc_norm(3,i)
2153             uzder(2,2,2)= 0.0d0
2154             uzder(3,2,2)= dc_norm(1,i)
2155             uzder(1,3,2)= dc_norm(2,i)
2156             uzder(2,3,2)=-dc_norm(1,i)
2157             uzder(3,3,2)= 0.0d0
2158 C Compute the Y-axis
2159             facy=fac
2160             do k=1,3
2161               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2162             enddo
2163 C Compute the derivatives of uy
2164             do j=1,3
2165               do k=1,3
2166                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2167      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2168                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2169               enddo
2170               uyder(j,j,1)=uyder(j,j,1)-costh
2171               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2172             enddo
2173             do j=1,2
2174               do k=1,3
2175                 do l=1,3
2176                   uygrad(l,k,j,i)=uyder(l,k,j)
2177                   uzgrad(l,k,j,i)=uzder(l,k,j)
2178                 enddo
2179               enddo
2180             enddo
2181             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2182             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2183             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2184             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2185           endif
2186       enddo
2187       do i=1,nres-1
2188         vbld_inv_temp(1)=vbld_inv(i+1)
2189         if (i.lt.nres-1) then
2190           vbld_inv_temp(2)=vbld_inv(i+2)
2191           else
2192           vbld_inv_temp(2)=vbld_inv(i)
2193           endif
2194         do j=1,2
2195           do k=1,3
2196             do l=1,3
2197               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2198               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2199             enddo
2200           enddo
2201         enddo
2202       enddo
2203 #if defined(PARVEC) && defined(MPI)
2204       if (nfgtasks1.gt.1) then
2205         time00=MPI_Wtime()
2206 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2207 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2208 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2209         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2210      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2211      &   FG_COMM1,IERR)
2212         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2213      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2214      &   FG_COMM1,IERR)
2215         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2216      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2217      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2218         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2219      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2220      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2221         time_gather=time_gather+MPI_Wtime()-time00
2222       endif
2223 c      if (fg_rank.eq.0) then
2224 c        write (iout,*) "Arrays UY and UZ"
2225 c        do i=1,nres-1
2226 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2227 c     &     (uz(k,i),k=1,3)
2228 c        enddo
2229 c      endif
2230 #endif
2231       return
2232       end
2233 C-----------------------------------------------------------------------------
2234       subroutine check_vecgrad
2235       implicit real*8 (a-h,o-z)
2236       include 'DIMENSIONS'
2237       include 'COMMON.IOUNITS'
2238       include 'COMMON.GEO'
2239       include 'COMMON.VAR'
2240       include 'COMMON.LOCAL'
2241       include 'COMMON.CHAIN'
2242       include 'COMMON.VECTORS'
2243       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2244       dimension uyt(3,maxres),uzt(3,maxres)
2245       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2246       double precision delta /1.0d-7/
2247       call vec_and_deriv
2248 cd      do i=1,nres
2249 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2250 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2251 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2252 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2253 cd     &     (dc_norm(if90,i),if90=1,3)
2254 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2255 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2256 cd          write(iout,'(a)')
2257 cd      enddo
2258       do i=1,nres
2259         do j=1,2
2260           do k=1,3
2261             do l=1,3
2262               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2263               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2264             enddo
2265           enddo
2266         enddo
2267       enddo
2268       call vec_and_deriv
2269       do i=1,nres
2270         do j=1,3
2271           uyt(j,i)=uy(j,i)
2272           uzt(j,i)=uz(j,i)
2273         enddo
2274       enddo
2275       do i=1,nres
2276 cd        write (iout,*) 'i=',i
2277         do k=1,3
2278           erij(k)=dc_norm(k,i)
2279         enddo
2280         do j=1,3
2281           do k=1,3
2282             dc_norm(k,i)=erij(k)
2283           enddo
2284           dc_norm(j,i)=dc_norm(j,i)+delta
2285 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2286 c          do k=1,3
2287 c            dc_norm(k,i)=dc_norm(k,i)/fac
2288 c          enddo
2289 c          write (iout,*) (dc_norm(k,i),k=1,3)
2290 c          write (iout,*) (erij(k),k=1,3)
2291           call vec_and_deriv
2292           do k=1,3
2293             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2294             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2295             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2296             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2297           enddo
2298 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2299 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2300 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2301         enddo
2302         do k=1,3
2303           dc_norm(k,i)=erij(k)
2304         enddo
2305 cd        do k=1,3
2306 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2307 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2308 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2309 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2310 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2311 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2312 cd          write (iout,'(a)')
2313 cd        enddo
2314       enddo
2315       return
2316       end
2317 C--------------------------------------------------------------------------
2318       subroutine set_matrices
2319       implicit real*8 (a-h,o-z)
2320       include 'DIMENSIONS'
2321 #ifdef MPI
2322       include "mpif.h"
2323       include "COMMON.SETUP"
2324       integer IERR
2325       integer status(MPI_STATUS_SIZE)
2326 #endif
2327       include 'COMMON.IOUNITS'
2328       include 'COMMON.GEO'
2329       include 'COMMON.VAR'
2330       include 'COMMON.LOCAL'
2331       include 'COMMON.CHAIN'
2332       include 'COMMON.DERIV'
2333       include 'COMMON.INTERACT'
2334       include 'COMMON.CONTACTS'
2335       include 'COMMON.TORSION'
2336       include 'COMMON.VECTORS'
2337       include 'COMMON.FFIELD'
2338       double precision auxvec(2),auxmat(2,2)
2339 C
2340 C Compute the virtual-bond-torsional-angle dependent quantities needed
2341 C to calculate the el-loc multibody terms of various order.
2342 C
2343 #ifdef PARMAT
2344       do i=ivec_start+2,ivec_end+2
2345 #else
2346       do i=3,nres+1
2347 #endif
2348         if (i .lt. nres+1) then
2349           sin1=dsin(phi(i))
2350           cos1=dcos(phi(i))
2351           sintab(i-2)=sin1
2352           costab(i-2)=cos1
2353           obrot(1,i-2)=cos1
2354           obrot(2,i-2)=sin1
2355           sin2=dsin(2*phi(i))
2356           cos2=dcos(2*phi(i))
2357           sintab2(i-2)=sin2
2358           costab2(i-2)=cos2
2359           obrot2(1,i-2)=cos2
2360           obrot2(2,i-2)=sin2
2361           Ug(1,1,i-2)=-cos1
2362           Ug(1,2,i-2)=-sin1
2363           Ug(2,1,i-2)=-sin1
2364           Ug(2,2,i-2)= cos1
2365           Ug2(1,1,i-2)=-cos2
2366           Ug2(1,2,i-2)=-sin2
2367           Ug2(2,1,i-2)=-sin2
2368           Ug2(2,2,i-2)= cos2
2369         else
2370           costab(i-2)=1.0d0
2371           sintab(i-2)=0.0d0
2372           obrot(1,i-2)=1.0d0
2373           obrot(2,i-2)=0.0d0
2374           obrot2(1,i-2)=0.0d0
2375           obrot2(2,i-2)=0.0d0
2376           Ug(1,1,i-2)=1.0d0
2377           Ug(1,2,i-2)=0.0d0
2378           Ug(2,1,i-2)=0.0d0
2379           Ug(2,2,i-2)=1.0d0
2380           Ug2(1,1,i-2)=0.0d0
2381           Ug2(1,2,i-2)=0.0d0
2382           Ug2(2,1,i-2)=0.0d0
2383           Ug2(2,2,i-2)=0.0d0
2384         endif
2385         if (i .gt. 3 .and. i .lt. nres+1) then
2386           obrot_der(1,i-2)=-sin1
2387           obrot_der(2,i-2)= cos1
2388           Ugder(1,1,i-2)= sin1
2389           Ugder(1,2,i-2)=-cos1
2390           Ugder(2,1,i-2)=-cos1
2391           Ugder(2,2,i-2)=-sin1
2392           dwacos2=cos2+cos2
2393           dwasin2=sin2+sin2
2394           obrot2_der(1,i-2)=-dwasin2
2395           obrot2_der(2,i-2)= dwacos2
2396           Ug2der(1,1,i-2)= dwasin2
2397           Ug2der(1,2,i-2)=-dwacos2
2398           Ug2der(2,1,i-2)=-dwacos2
2399           Ug2der(2,2,i-2)=-dwasin2
2400         else
2401           obrot_der(1,i-2)=0.0d0
2402           obrot_der(2,i-2)=0.0d0
2403           Ugder(1,1,i-2)=0.0d0
2404           Ugder(1,2,i-2)=0.0d0
2405           Ugder(2,1,i-2)=0.0d0
2406           Ugder(2,2,i-2)=0.0d0
2407           obrot2_der(1,i-2)=0.0d0
2408           obrot2_der(2,i-2)=0.0d0
2409           Ug2der(1,1,i-2)=0.0d0
2410           Ug2der(1,2,i-2)=0.0d0
2411           Ug2der(2,1,i-2)=0.0d0
2412           Ug2der(2,2,i-2)=0.0d0
2413         endif
2414 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2415         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2416           iti = itortyp(itype(i-2))
2417         else
2418           iti=ntortyp
2419         endif
2420 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2421         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2422           iti1 = itortyp(itype(i-1))
2423         else
2424           iti1=ntortyp
2425         endif
2426 cd        write (iout,*) '*******i',i,' iti1',iti
2427 cd        write (iout,*) 'b1',b1(:,iti)
2428 cd        write (iout,*) 'b2',b2(:,iti)
2429 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2430 c        if (i .gt. iatel_s+2) then
2431         if (i .gt. nnt+2) then
2432           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2433           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2434           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2435      &    then
2436           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2437           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2438           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2439           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2440           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2441           endif
2442         else
2443           do k=1,2
2444             Ub2(k,i-2)=0.0d0
2445             Ctobr(k,i-2)=0.0d0
2446             Dtobr2(k,i-2)=0.0d0
2447             do l=1,2
2448               EUg(l,k,i-2)=0.0d0
2449               CUg(l,k,i-2)=0.0d0
2450               DUg(l,k,i-2)=0.0d0
2451               DtUg2(l,k,i-2)=0.0d0
2452             enddo
2453           enddo
2454         endif
2455         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2456         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2457         do k=1,2
2458           muder(k,i-2)=Ub2der(k,i-2)
2459         enddo
2460 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2461         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2462           if (itype(i-1).le.ntyp) then
2463             iti1 = itortyp(itype(i-1))
2464           else
2465             iti1=ntortyp
2466           endif
2467         else
2468           iti1=ntortyp
2469         endif
2470         do k=1,2
2471           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2472         enddo
2473 cd        write (iout,*) 'mu ',mu(:,i-2)
2474 cd        write (iout,*) 'mu1',mu1(:,i-2)
2475 cd        write (iout,*) 'mu2',mu2(:,i-2)
2476         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2477      &  then
2478         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2479         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2480         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2481         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2482         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2483 C Vectors and matrices dependent on a single virtual-bond dihedral.
2484         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2485         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2486         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2487         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2488         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2489         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2490         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2491         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2492         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2493         endif
2494       enddo
2495 C Matrices dependent on two consecutive virtual-bond dihedrals.
2496 C The order of matrices is from left to right.
2497       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2498      &then
2499 c      do i=max0(ivec_start,2),ivec_end
2500       do i=2,nres-1
2501         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2502         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2503         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2504         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2505         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2506         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2507         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2508         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2509       enddo
2510       endif
2511 #if defined(MPI) && defined(PARMAT)
2512 #ifdef DEBUG
2513 c      if (fg_rank.eq.0) then
2514         write (iout,*) "Arrays UG and UGDER before GATHER"
2515         do i=1,nres-1
2516           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2517      &     ((ug(l,k,i),l=1,2),k=1,2),
2518      &     ((ugder(l,k,i),l=1,2),k=1,2)
2519         enddo
2520         write (iout,*) "Arrays UG2 and UG2DER"
2521         do i=1,nres-1
2522           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2523      &     ((ug2(l,k,i),l=1,2),k=1,2),
2524      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2525         enddo
2526         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2527         do i=1,nres-1
2528           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2529      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2530      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2531         enddo
2532         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2533         do i=1,nres-1
2534           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2535      &     costab(i),sintab(i),costab2(i),sintab2(i)
2536         enddo
2537         write (iout,*) "Array MUDER"
2538         do i=1,nres-1
2539           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2540         enddo
2541 c      endif
2542 #endif
2543       if (nfgtasks.gt.1) then
2544         time00=MPI_Wtime()
2545 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2546 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2547 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2548 #ifdef MATGATHER
2549         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2550      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2551      &   FG_COMM1,IERR)
2552         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2568      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2569      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2570         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2571      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2572      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2573         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2574      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2575      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2576         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2577      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2578      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2579         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2580      &  then
2581         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2582      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2583      &   FG_COMM1,IERR)
2584         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2588      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2589      &   FG_COMM1,IERR)
2590        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2591      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2592      &   FG_COMM1,IERR)
2593         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2594      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2597      &   ivec_count(fg_rank1),
2598      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2601      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2605      &   FG_COMM1,IERR)
2606         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2611      &   FG_COMM1,IERR)
2612         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2614      &   FG_COMM1,IERR)
2615         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2622      &   ivec_count(fg_rank1),
2623      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2624      &   FG_COMM1,IERR)
2625         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2626      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2627      &   FG_COMM1,IERR)
2628        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2630      &   FG_COMM1,IERR)
2631         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2638      &   ivec_count(fg_rank1),
2639      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2640      &   FG_COMM1,IERR)
2641         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2642      &   ivec_count(fg_rank1),
2643      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2644      &   FG_COMM1,IERR)
2645         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2646      &   ivec_count(fg_rank1),
2647      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2648      &   MPI_MAT2,FG_COMM1,IERR)
2649         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2650      &   ivec_count(fg_rank1),
2651      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2652      &   MPI_MAT2,FG_COMM1,IERR)
2653         endif
2654 #else
2655 c Passes matrix info through the ring
2656       isend=fg_rank1
2657       irecv=fg_rank1-1
2658       if (irecv.lt.0) irecv=nfgtasks1-1
2659       iprev=irecv
2660       inext=fg_rank1+1
2661       if (inext.ge.nfgtasks1) inext=0
2662       do i=1,nfgtasks1-1
2663 c        write (iout,*) "isend",isend," irecv",irecv
2664 c        call flush(iout)
2665         lensend=lentyp(isend)
2666         lenrecv=lentyp(irecv)
2667 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2668 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2669 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2670 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2671 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather ROTAT1"
2673 c        call flush(iout)
2674 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2675 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2676 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2677 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2678 c        write (iout,*) "Gather ROTAT2"
2679 c        call flush(iout)
2680         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2681      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2682      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2683      &   iprev,4400+irecv,FG_COMM,status,IERR)
2684 c        write (iout,*) "Gather ROTAT_OLD"
2685 c        call flush(iout)
2686         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2687      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2688      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2689      &   iprev,5500+irecv,FG_COMM,status,IERR)
2690 c        write (iout,*) "Gather PRECOMP11"
2691 c        call flush(iout)
2692         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2693      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2694      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2695      &   iprev,6600+irecv,FG_COMM,status,IERR)
2696 c        write (iout,*) "Gather PRECOMP12"
2697 c        call flush(iout)
2698         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2699      &  then
2700         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2701      &   MPI_ROTAT2(lensend),inext,7700+isend,
2702      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2703      &   iprev,7700+irecv,FG_COMM,status,IERR)
2704 c        write (iout,*) "Gather PRECOMP21"
2705 c        call flush(iout)
2706         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2707      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2708      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2709      &   iprev,8800+irecv,FG_COMM,status,IERR)
2710 c        write (iout,*) "Gather PRECOMP22"
2711 c        call flush(iout)
2712         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2713      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2714      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2715      &   MPI_PRECOMP23(lenrecv),
2716      &   iprev,9900+irecv,FG_COMM,status,IERR)
2717 c        write (iout,*) "Gather PRECOMP23"
2718 c        call flush(iout)
2719         endif
2720         isend=irecv
2721         irecv=irecv-1
2722         if (irecv.lt.0) irecv=nfgtasks1-1
2723       enddo
2724 #endif
2725         time_gather=time_gather+MPI_Wtime()-time00
2726       endif
2727 #ifdef DEBUG
2728 c      if (fg_rank.eq.0) then
2729         write (iout,*) "Arrays UG and UGDER"
2730         do i=1,nres-1
2731           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2732      &     ((ug(l,k,i),l=1,2),k=1,2),
2733      &     ((ugder(l,k,i),l=1,2),k=1,2)
2734         enddo
2735         write (iout,*) "Arrays UG2 and UG2DER"
2736         do i=1,nres-1
2737           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2738      &     ((ug2(l,k,i),l=1,2),k=1,2),
2739      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2740         enddo
2741         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2742         do i=1,nres-1
2743           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2744      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2745      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2746         enddo
2747         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2748         do i=1,nres-1
2749           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2750      &     costab(i),sintab(i),costab2(i),sintab2(i)
2751         enddo
2752         write (iout,*) "Array MUDER"
2753         do i=1,nres-1
2754           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2755         enddo
2756 c      endif
2757 #endif
2758 #endif
2759 cd      do i=1,nres
2760 cd        iti = itortyp(itype(i))
2761 cd        write (iout,*) i
2762 cd        do j=1,2
2763 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2764 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2765 cd        enddo
2766 cd      enddo
2767       return
2768       end
2769 C--------------------------------------------------------------------------
2770       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2771 C
2772 C This subroutine calculates the average interaction energy and its gradient
2773 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2774 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2775 C The potential depends both on the distance of peptide-group centers and on
2776 C the orientation of the CA-CA virtual bonds.
2777 C
2778       implicit real*8 (a-h,o-z)
2779 #ifdef MPI
2780       include 'mpif.h'
2781 #endif
2782       include 'DIMENSIONS'
2783       include 'COMMON.CONTROL'
2784       include 'COMMON.SETUP'
2785       include 'COMMON.IOUNITS'
2786       include 'COMMON.GEO'
2787       include 'COMMON.VAR'
2788       include 'COMMON.LOCAL'
2789       include 'COMMON.CHAIN'
2790       include 'COMMON.DERIV'
2791       include 'COMMON.INTERACT'
2792       include 'COMMON.CONTACTS'
2793       include 'COMMON.TORSION'
2794       include 'COMMON.VECTORS'
2795       include 'COMMON.FFIELD'
2796       include 'COMMON.TIME1'
2797       include 'COMMON.SPLITELE'
2798       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2799      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2800       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2801      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2802       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2803      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2804      &    num_conti,j1,j2
2805 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2806 #ifdef MOMENT
2807       double precision scal_el /1.0d0/
2808 #else
2809       double precision scal_el /0.5d0/
2810 #endif
2811 C 12/13/98
2812 C 13-go grudnia roku pamietnego...
2813       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2814      &                   0.0d0,1.0d0,0.0d0,
2815      &                   0.0d0,0.0d0,1.0d0/
2816 cd      write(iout,*) 'In EELEC'
2817 cd      do i=1,nloctyp
2818 cd        write(iout,*) 'Type',i
2819 cd        write(iout,*) 'B1',B1(:,i)
2820 cd        write(iout,*) 'B2',B2(:,i)
2821 cd        write(iout,*) 'CC',CC(:,:,i)
2822 cd        write(iout,*) 'DD',DD(:,:,i)
2823 cd        write(iout,*) 'EE',EE(:,:,i)
2824 cd      enddo
2825 cd      call check_vecgrad
2826 cd      stop
2827       if (icheckgrad.eq.1) then
2828         do i=1,nres-1
2829           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2830           do k=1,3
2831             dc_norm(k,i)=dc(k,i)*fac
2832           enddo
2833 c          write (iout,*) 'i',i,' fac',fac
2834         enddo
2835       endif
2836       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2837      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2838      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2839 c        call vec_and_deriv
2840 #ifdef TIMING
2841         time01=MPI_Wtime()
2842 #endif
2843         call set_matrices
2844 #ifdef TIMING
2845         time_mat=time_mat+MPI_Wtime()-time01
2846 #endif
2847       endif
2848 cd      do i=1,nres-1
2849 cd        write (iout,*) 'i=',i
2850 cd        do k=1,3
2851 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2852 cd        enddo
2853 cd        do k=1,3
2854 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2855 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2856 cd        enddo
2857 cd      enddo
2858       t_eelecij=0.0d0
2859       ees=0.0D0
2860       evdw1=0.0D0
2861       eel_loc=0.0d0
2862       eello_turn3=0.0d0
2863       eello_turn4=0.0d0
2864       ind=0
2865       do i=1,nres
2866         num_cont_hb(i)=0
2867       enddo
2868 cd      print '(a)','Enter EELEC'
2869 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2870       do i=1,nres
2871         gel_loc_loc(i)=0.0d0
2872         gcorr_loc(i)=0.0d0
2873       enddo
2874 c
2875 c
2876 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2877 C
2878 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2879 C
2880 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2881       do i=iturn3_start,iturn3_end
2882         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2883      &  .or. itype(i+2).eq.ntyp1
2884      &  .or. itype(i+3).eq.ntyp1
2885      &  .or. itype(i-1).eq.ntyp1
2886      &  .or. itype(i+4).eq.ntyp1
2887      &  ) cycle
2888         dxi=dc(1,i)
2889         dyi=dc(2,i)
2890         dzi=dc(3,i)
2891         dx_normi=dc_norm(1,i)
2892         dy_normi=dc_norm(2,i)
2893         dz_normi=dc_norm(3,i)
2894         xmedi=c(1,i)+0.5d0*dxi
2895         ymedi=c(2,i)+0.5d0*dyi
2896         zmedi=c(3,i)+0.5d0*dzi
2897 C Return atom into box, boxxsize is size of box in x dimension
2898 c  184   continue
2899 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2900 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2901 C Condition for being inside the proper box
2902 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2903 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2904 c        go to 184
2905 c        endif
2906 c  185   continue
2907 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2908 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2909 cC Condition for being inside the proper box
2910 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2911 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2912 c        go to 185
2913 c        endif
2914 c  186   continue
2915 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2916 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2917 cC Condition for being inside the proper box
2918 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2919 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2920 c        go to 186
2921 c        endif
2922           xmedi=mod(xmedi,boxxsize)
2923           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2924           ymedi=mod(ymedi,boxysize)
2925           if (ymedi.lt.0) ymedi=ymedi+boxysize
2926           zmedi=mod(zmedi,boxzsize)
2927           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2928         num_conti=0
2929         call eelecij(i,i+2,ees,evdw1,eel_loc)
2930         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2931         num_cont_hb(i)=num_conti
2932       enddo
2933       do i=iturn4_start,iturn4_end
2934         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2935      &    .or. itype(i+3).eq.ntyp1
2936      &    .or. itype(i+4).eq.ntyp1
2937      &    .or. itype(i+5).eq.ntyp1
2938      &    .or. itype(i).eq.ntyp1
2939      &    .or. itype(i-1).eq.ntyp1
2940      &                             ) cycle
2941         dxi=dc(1,i)
2942         dyi=dc(2,i)
2943         dzi=dc(3,i)
2944         dx_normi=dc_norm(1,i)
2945         dy_normi=dc_norm(2,i)
2946         dz_normi=dc_norm(3,i)
2947         xmedi=c(1,i)+0.5d0*dxi
2948         ymedi=c(2,i)+0.5d0*dyi
2949         zmedi=c(3,i)+0.5d0*dzi
2950 C Return atom into box, boxxsize is size of box in x dimension
2951 c  194   continue
2952 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2953 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2954 C Condition for being inside the proper box
2955 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2956 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2957 c        go to 194
2958 c        endif
2959 c  195   continue
2960 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2961 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2962 C Condition for being inside the proper box
2963 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2964 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2965 c        go to 195
2966 c        endif
2967 c  196   continue
2968 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2969 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2970 C Condition for being inside the proper box
2971 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2972 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2973 c        go to 196
2974 c        endif
2975           xmedi=mod(xmedi,boxxsize)
2976           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2977           ymedi=mod(ymedi,boxysize)
2978           if (ymedi.lt.0) ymedi=ymedi+boxysize
2979           zmedi=mod(zmedi,boxzsize)
2980           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2981
2982         num_conti=num_cont_hb(i)
2983         call eelecij(i,i+3,ees,evdw1,eel_loc)
2984         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2985      &   call eturn4(i,eello_turn4)
2986         num_cont_hb(i)=num_conti
2987       enddo   ! i
2988 C Loop over all neighbouring boxes
2989       do xshift=-1,1
2990       do yshift=-1,1
2991       do zshift=-1,1
2992 c
2993 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2994 c
2995       do i=iatel_s,iatel_e
2996         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2997      &  .or. itype(i+2).eq.ntyp1
2998      &  .or. itype(i-1).eq.ntyp1
2999      &                ) cycle
3000         dxi=dc(1,i)
3001         dyi=dc(2,i)
3002         dzi=dc(3,i)
3003         dx_normi=dc_norm(1,i)
3004         dy_normi=dc_norm(2,i)
3005         dz_normi=dc_norm(3,i)
3006         xmedi=c(1,i)+0.5d0*dxi
3007         ymedi=c(2,i)+0.5d0*dyi
3008         zmedi=c(3,i)+0.5d0*dzi
3009           xmedi=mod(xmedi,boxxsize)
3010           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3011           ymedi=mod(ymedi,boxysize)
3012           if (ymedi.lt.0) ymedi=ymedi+boxysize
3013           zmedi=mod(zmedi,boxzsize)
3014           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3015
3016 C Return atom into box, boxxsize is size of box in x dimension
3017 c  164   continue
3018 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3019 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3020 C Condition for being inside the proper box
3021 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3022 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3023 c        go to 164
3024 c        endif
3025 c  165   continue
3026 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3027 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3028 C Condition for being inside the proper box
3029 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3030 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3031 c        go to 165
3032 c        endif
3033 c  166   continue
3034 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3035 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3036 cC Condition for being inside the proper box
3037 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3038 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3039 c        go to 166
3040 c        endif
3041
3042 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3043         num_conti=num_cont_hb(i)
3044         do j=ielstart(i),ielend(i)
3045 c          write (iout,*) i,j,itype(i),itype(j)
3046           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3047      & .or.itype(j+2).eq.ntyp1
3048      & .or.itype(j-1).eq.ntyp1
3049      &) cycle
3050           call eelecij(i,j,ees,evdw1,eel_loc)
3051         enddo ! j
3052         num_cont_hb(i)=num_conti
3053       enddo   ! i
3054       enddo   ! zshift
3055       enddo   ! yshift
3056       enddo   ! xshift
3057
3058 c      write (iout,*) "Number of loop steps in EELEC:",ind
3059 cd      do i=1,nres
3060 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3061 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3062 cd      enddo
3063 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3064 ccc      eel_loc=eel_loc+eello_turn3
3065 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3066       return
3067       end
3068 C-------------------------------------------------------------------------------
3069       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3070       implicit real*8 (a-h,o-z)
3071       include 'DIMENSIONS'
3072 #ifdef MPI
3073       include "mpif.h"
3074 #endif
3075       include 'COMMON.CONTROL'
3076       include 'COMMON.IOUNITS'
3077       include 'COMMON.GEO'
3078       include 'COMMON.VAR'
3079       include 'COMMON.LOCAL'
3080       include 'COMMON.CHAIN'
3081       include 'COMMON.DERIV'
3082       include 'COMMON.INTERACT'
3083       include 'COMMON.CONTACTS'
3084       include 'COMMON.TORSION'
3085       include 'COMMON.VECTORS'
3086       include 'COMMON.FFIELD'
3087       include 'COMMON.TIME1'
3088       include 'COMMON.SPLITELE'
3089       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3090      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3091       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3092      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3093       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3094      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3095      &    num_conti,j1,j2
3096 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3097 #ifdef MOMENT
3098       double precision scal_el /1.0d0/
3099 #else
3100       double precision scal_el /0.5d0/
3101 #endif
3102 C 12/13/98
3103 C 13-go grudnia roku pamietnego...
3104       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3105      &                   0.0d0,1.0d0,0.0d0,
3106      &                   0.0d0,0.0d0,1.0d0/
3107 c          time00=MPI_Wtime()
3108 cd      write (iout,*) "eelecij",i,j
3109 c          ind=ind+1
3110           iteli=itel(i)
3111           itelj=itel(j)
3112           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3113           aaa=app(iteli,itelj)
3114           bbb=bpp(iteli,itelj)
3115           ael6i=ael6(iteli,itelj)
3116           ael3i=ael3(iteli,itelj)
3117           dxj=dc(1,j)
3118           dyj=dc(2,j)
3119           dzj=dc(3,j)
3120           dx_normj=dc_norm(1,j)
3121           dy_normj=dc_norm(2,j)
3122           dz_normj=dc_norm(3,j)
3123 C          xj=c(1,j)+0.5D0*dxj-xmedi
3124 C          yj=c(2,j)+0.5D0*dyj-ymedi
3125 C          zj=c(3,j)+0.5D0*dzj-zmedi
3126           xj=c(1,j)+0.5D0*dxj
3127           yj=c(2,j)+0.5D0*dyj
3128           zj=c(3,j)+0.5D0*dzj
3129           xj=mod(xj,boxxsize)
3130           if (xj.lt.0) xj=xj+boxxsize
3131           yj=mod(yj,boxysize)
3132           if (yj.lt.0) yj=yj+boxysize
3133           zj=mod(zj,boxzsize)
3134           if (zj.lt.0) zj=zj+boxzsize
3135
3136 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3137 c  174   continue
3138 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3139 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3140 C Condition for being inside the proper box
3141 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3142 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3143 c        go to 174
3144 c        endif
3145 c  175   continue
3146 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3147 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3148 C Condition for being inside the proper box
3149 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3150 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3151 c        go to 175
3152 c        endif
3153 c  176   continue
3154 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3155 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3156 C Condition for being inside the proper box
3157 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3158 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3159 c        go to 176
3160 c        endif
3161 C        endif !endPBC condintion
3162         xj=xj-xmedi
3163         yj=yj-ymedi
3164         zj=zj-zmedi
3165           rij=xj*xj+yj*yj+zj*zj
3166
3167             sss=sscale(sqrt(rij))
3168             sssgrad=sscagrad(sqrt(rij))
3169 c            if (sss.gt.0.0d0) then
3170           rrmij=1.0D0/rij
3171           rij=dsqrt(rij)
3172           rmij=1.0D0/rij
3173           r3ij=rrmij*rmij
3174           r6ij=r3ij*r3ij
3175           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3176           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3177           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3178           fac=cosa-3.0D0*cosb*cosg
3179           ev1=aaa*r6ij*r6ij
3180 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3181           if (j.eq.i+2) ev1=scal_el*ev1
3182           ev2=bbb*r6ij
3183           fac3=ael6i*r6ij
3184           fac4=ael3i*r3ij
3185           evdwij=(ev1+ev2)
3186           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3187           el2=fac4*fac
3188 C MARYSIA
3189           eesij=(el1+el2)
3190 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3191           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3192           ees=ees+eesij
3193           evdw1=evdw1+evdwij*sss
3194 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3195 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3196 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3197 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3198
3199           if (energy_dec) then
3200               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3201      &'evdw1',i,j,evdwij
3202      &,iteli,itelj,aaa,evdw1
3203               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3204           endif
3205
3206 C
3207 C Calculate contributions to the Cartesian gradient.
3208 C
3209 #ifdef SPLITELE
3210           facvdw=-6*rrmij*(ev1+evdwij)*sss
3211           facel=-3*rrmij*(el1+eesij)
3212           fac1=fac
3213           erij(1)=xj*rmij
3214           erij(2)=yj*rmij
3215           erij(3)=zj*rmij
3216 *
3217 * Radial derivatives. First process both termini of the fragment (i,j)
3218 *
3219           ggg(1)=facel*xj
3220           ggg(2)=facel*yj
3221           ggg(3)=facel*zj
3222 c          do k=1,3
3223 c            ghalf=0.5D0*ggg(k)
3224 c            gelc(k,i)=gelc(k,i)+ghalf
3225 c            gelc(k,j)=gelc(k,j)+ghalf
3226 c          enddo
3227 c 9/28/08 AL Gradient compotents will be summed only at the end
3228           do k=1,3
3229             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3230             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3231           enddo
3232 *
3233 * Loop over residues i+1 thru j-1.
3234 *
3235 cgrad          do k=i+1,j-1
3236 cgrad            do l=1,3
3237 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3238 cgrad            enddo
3239 cgrad          enddo
3240           if (sss.gt.0.0) then
3241           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3242           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3243           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3244           else
3245           ggg(1)=0.0
3246           ggg(2)=0.0
3247           ggg(3)=0.0
3248           endif
3249 c          do k=1,3
3250 c            ghalf=0.5D0*ggg(k)
3251 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3252 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3253 c          enddo
3254 c 9/28/08 AL Gradient compotents will be summed only at the end
3255           do k=1,3
3256             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3257             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3258           enddo
3259 *
3260 * Loop over residues i+1 thru j-1.
3261 *
3262 cgrad          do k=i+1,j-1
3263 cgrad            do l=1,3
3264 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3265 cgrad            enddo
3266 cgrad          enddo
3267 #else
3268 C MARYSIA
3269           facvdw=(ev1+evdwij)*sss
3270           facel=(el1+eesij)
3271           fac1=fac
3272           fac=-3*rrmij*(facvdw+facvdw+facel)
3273           erij(1)=xj*rmij
3274           erij(2)=yj*rmij
3275           erij(3)=zj*rmij
3276 *
3277 * Radial derivatives. First process both termini of the fragment (i,j)
3278 *
3279           ggg(1)=fac*xj
3280           ggg(2)=fac*yj
3281           ggg(3)=fac*zj
3282 c          do k=1,3
3283 c            ghalf=0.5D0*ggg(k)
3284 c            gelc(k,i)=gelc(k,i)+ghalf
3285 c            gelc(k,j)=gelc(k,j)+ghalf
3286 c          enddo
3287 c 9/28/08 AL Gradient compotents will be summed only at the end
3288           do k=1,3
3289             gelc_long(k,j)=gelc(k,j)+ggg(k)
3290             gelc_long(k,i)=gelc(k,i)-ggg(k)
3291           enddo
3292 *
3293 * Loop over residues i+1 thru j-1.
3294 *
3295 cgrad          do k=i+1,j-1
3296 cgrad            do l=1,3
3297 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3298 cgrad            enddo
3299 cgrad          enddo
3300 c 9/28/08 AL Gradient compotents will be summed only at the end
3301           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3302           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3303           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3304           do k=1,3
3305             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3306             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3307           enddo
3308 #endif
3309 *
3310 * Angular part
3311 *
3312           ecosa=2.0D0*fac3*fac1+fac4
3313           fac4=-3.0D0*fac4
3314           fac3=-6.0D0*fac3
3315           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3316           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3317           do k=1,3
3318             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3319             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3320           enddo
3321 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3322 cd   &          (dcosg(k),k=1,3)
3323           do k=1,3
3324             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3325           enddo
3326 c          do k=1,3
3327 c            ghalf=0.5D0*ggg(k)
3328 c            gelc(k,i)=gelc(k,i)+ghalf
3329 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3330 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3331 c            gelc(k,j)=gelc(k,j)+ghalf
3332 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3333 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3334 c          enddo
3335 cgrad          do k=i+1,j-1
3336 cgrad            do l=1,3
3337 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3338 cgrad            enddo
3339 cgrad          enddo
3340           do k=1,3
3341             gelc(k,i)=gelc(k,i)
3342      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3343      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3344             gelc(k,j)=gelc(k,j)
3345      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3346      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3347             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3348             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3349           enddo
3350 C MARYSIA
3351 c          endif !sscale
3352           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3353      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3354      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3355 C
3356 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3357 C   energy of a peptide unit is assumed in the form of a second-order
3358 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3359 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3360 C   are computed for EVERY pair of non-contiguous peptide groups.
3361 C
3362           if (j.lt.nres-1) then
3363             j1=j+1
3364             j2=j-1
3365           else
3366             j1=j-1
3367             j2=j-2
3368           endif
3369           kkk=0
3370           do k=1,2
3371             do l=1,2
3372               kkk=kkk+1
3373               muij(kkk)=mu(k,i)*mu(l,j)
3374             enddo
3375           enddo
3376 cd         write (iout,*) 'EELEC: i',i,' j',j
3377 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3378 cd          write(iout,*) 'muij',muij
3379           ury=scalar(uy(1,i),erij)
3380           urz=scalar(uz(1,i),erij)
3381           vry=scalar(uy(1,j),erij)
3382           vrz=scalar(uz(1,j),erij)
3383           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3384           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3385           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3386           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3387           fac=dsqrt(-ael6i)*r3ij
3388           a22=a22*fac
3389           a23=a23*fac
3390           a32=a32*fac
3391           a33=a33*fac
3392 cd          write (iout,'(4i5,4f10.5)')
3393 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3394 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3395 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3396 cd     &      uy(:,j),uz(:,j)
3397 cd          write (iout,'(4f10.5)')
3398 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3399 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3400 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3401 cd           write (iout,'(9f10.5/)')
3402 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3403 C Derivatives of the elements of A in virtual-bond vectors
3404           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3405           do k=1,3
3406             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3407             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3408             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3409             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3410             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3411             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3412             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3413             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3414             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3415             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3416             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3417             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3418           enddo
3419 C Compute radial contributions to the gradient
3420           facr=-3.0d0*rrmij
3421           a22der=a22*facr
3422           a23der=a23*facr
3423           a32der=a32*facr
3424           a33der=a33*facr
3425           agg(1,1)=a22der*xj
3426           agg(2,1)=a22der*yj
3427           agg(3,1)=a22der*zj
3428           agg(1,2)=a23der*xj
3429           agg(2,2)=a23der*yj
3430           agg(3,2)=a23der*zj
3431           agg(1,3)=a32der*xj
3432           agg(2,3)=a32der*yj
3433           agg(3,3)=a32der*zj
3434           agg(1,4)=a33der*xj
3435           agg(2,4)=a33der*yj
3436           agg(3,4)=a33der*zj
3437 C Add the contributions coming from er
3438           fac3=-3.0d0*fac
3439           do k=1,3
3440             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3441             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3442             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3443             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3444           enddo
3445           do k=1,3
3446 C Derivatives in DC(i)
3447 cgrad            ghalf1=0.5d0*agg(k,1)
3448 cgrad            ghalf2=0.5d0*agg(k,2)
3449 cgrad            ghalf3=0.5d0*agg(k,3)
3450 cgrad            ghalf4=0.5d0*agg(k,4)
3451             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3452      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3453             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3454      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3455             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3456      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3457             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3458      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3459 C Derivatives in DC(i+1)
3460             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3461      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3462             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3463      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3464             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3465      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3466             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3467      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3468 C Derivatives in DC(j)
3469             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3470      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3471             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3472      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3473             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3474      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3475             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3476      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3477 C Derivatives in DC(j+1) or DC(nres-1)
3478             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3479      &      -3.0d0*vryg(k,3)*ury)
3480             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3481      &      -3.0d0*vrzg(k,3)*ury)
3482             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3483      &      -3.0d0*vryg(k,3)*urz)
3484             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3485      &      -3.0d0*vrzg(k,3)*urz)
3486 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3487 cgrad              do l=1,4
3488 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3489 cgrad              enddo
3490 cgrad            endif
3491           enddo
3492           acipa(1,1)=a22
3493           acipa(1,2)=a23
3494           acipa(2,1)=a32
3495           acipa(2,2)=a33
3496           a22=-a22
3497           a23=-a23
3498           do l=1,2
3499             do k=1,3
3500               agg(k,l)=-agg(k,l)
3501               aggi(k,l)=-aggi(k,l)
3502               aggi1(k,l)=-aggi1(k,l)
3503               aggj(k,l)=-aggj(k,l)
3504               aggj1(k,l)=-aggj1(k,l)
3505             enddo
3506           enddo
3507           if (j.lt.nres-1) then
3508             a22=-a22
3509             a32=-a32
3510             do l=1,3,2
3511               do k=1,3
3512                 agg(k,l)=-agg(k,l)
3513                 aggi(k,l)=-aggi(k,l)
3514                 aggi1(k,l)=-aggi1(k,l)
3515                 aggj(k,l)=-aggj(k,l)
3516                 aggj1(k,l)=-aggj1(k,l)
3517               enddo
3518             enddo
3519           else
3520             a22=-a22
3521             a23=-a23
3522             a32=-a32
3523             a33=-a33
3524             do l=1,4
3525               do k=1,3
3526                 agg(k,l)=-agg(k,l)
3527                 aggi(k,l)=-aggi(k,l)
3528                 aggi1(k,l)=-aggi1(k,l)
3529                 aggj(k,l)=-aggj(k,l)
3530                 aggj1(k,l)=-aggj1(k,l)
3531               enddo
3532             enddo
3533           endif
3534           ENDIF ! WCORR
3535           IF (wel_loc.gt.0.0d0) THEN
3536 C Contribution to the local-electrostatic energy coming from the i-j pair
3537           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3538      &     +a33*muij(4)
3539 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3540 c     &                     ' eel_loc_ij',eel_loc_ij
3541
3542           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3543      &            'eelloc',i,j,eel_loc_ij
3544 c           if (eel_loc_ij.ne.0)
3545 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3546 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3547
3548           eel_loc=eel_loc+eel_loc_ij
3549 C Partial derivatives in virtual-bond dihedral angles gamma
3550           if (i.gt.1)
3551      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3552      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3553      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3554           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3555      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3556      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3557 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3558           do l=1,3
3559             ggg(l)=agg(l,1)*muij(1)+
3560      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3561             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3562             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3563 cgrad            ghalf=0.5d0*ggg(l)
3564 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3565 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3566           enddo
3567 cgrad          do k=i+1,j2
3568 cgrad            do l=1,3
3569 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3570 cgrad            enddo
3571 cgrad          enddo
3572 C Remaining derivatives of eello
3573           do l=1,3
3574             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3575      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3576             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3577      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3578             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3579      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3580             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3581      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3582           enddo
3583           ENDIF
3584 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3585 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3586           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3587      &       .and. num_conti.le.maxconts) then
3588 c            write (iout,*) i,j," entered corr"
3589 C
3590 C Calculate the contact function. The ith column of the array JCONT will
3591 C contain the numbers of atoms that make contacts with the atom I (of numbers
3592 C greater than I). The arrays FACONT and GACONT will contain the values of
3593 C the contact function and its derivative.
3594 c           r0ij=1.02D0*rpp(iteli,itelj)
3595 c           r0ij=1.11D0*rpp(iteli,itelj)
3596             r0ij=2.20D0*rpp(iteli,itelj)
3597 c           r0ij=1.55D0*rpp(iteli,itelj)
3598             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3599             if (fcont.gt.0.0D0) then
3600               num_conti=num_conti+1
3601               if (num_conti.gt.maxconts) then
3602                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3603      &                         ' will skip next contacts for this conf.'
3604               else
3605                 jcont_hb(num_conti,i)=j
3606 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3607 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3608                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3609      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3610 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3611 C  terms.
3612                 d_cont(num_conti,i)=rij
3613 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3614 C     --- Electrostatic-interaction matrix ---
3615                 a_chuj(1,1,num_conti,i)=a22
3616                 a_chuj(1,2,num_conti,i)=a23
3617                 a_chuj(2,1,num_conti,i)=a32
3618                 a_chuj(2,2,num_conti,i)=a33
3619 C     --- Gradient of rij
3620                 do kkk=1,3
3621                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3622                 enddo
3623                 kkll=0
3624                 do k=1,2
3625                   do l=1,2
3626                     kkll=kkll+1
3627                     do m=1,3
3628                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3629                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3630                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3631                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3632                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3633                     enddo
3634                   enddo
3635                 enddo
3636                 ENDIF
3637                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3638 C Calculate contact energies
3639                 cosa4=4.0D0*cosa
3640                 wij=cosa-3.0D0*cosb*cosg
3641                 cosbg1=cosb+cosg
3642                 cosbg2=cosb-cosg
3643 c               fac3=dsqrt(-ael6i)/r0ij**3
3644                 fac3=dsqrt(-ael6i)*r3ij
3645 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3646                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3647                 if (ees0tmp.gt.0) then
3648                   ees0pij=dsqrt(ees0tmp)
3649                 else
3650                   ees0pij=0
3651                 endif
3652 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3653                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3654                 if (ees0tmp.gt.0) then
3655                   ees0mij=dsqrt(ees0tmp)
3656                 else
3657                   ees0mij=0
3658                 endif
3659 c               ees0mij=0.0D0
3660                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3661                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3662 C Diagnostics. Comment out or remove after debugging!
3663 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3664 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3665 c               ees0m(num_conti,i)=0.0D0
3666 C End diagnostics.
3667 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3668 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3669 C Angular derivatives of the contact function
3670                 ees0pij1=fac3/ees0pij
3671                 ees0mij1=fac3/ees0mij
3672                 fac3p=-3.0D0*fac3*rrmij
3673                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3674                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3675 c               ees0mij1=0.0D0
3676                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3677                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3678                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3679                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3680                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3681                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3682                 ecosap=ecosa1+ecosa2
3683                 ecosbp=ecosb1+ecosb2
3684                 ecosgp=ecosg1+ecosg2
3685                 ecosam=ecosa1-ecosa2
3686                 ecosbm=ecosb1-ecosb2
3687                 ecosgm=ecosg1-ecosg2
3688 C Diagnostics
3689 c               ecosap=ecosa1
3690 c               ecosbp=ecosb1
3691 c               ecosgp=ecosg1
3692 c               ecosam=0.0D0
3693 c               ecosbm=0.0D0
3694 c               ecosgm=0.0D0
3695 C End diagnostics
3696                 facont_hb(num_conti,i)=fcont
3697                 fprimcont=fprimcont/rij
3698 cd              facont_hb(num_conti,i)=1.0D0
3699 C Following line is for diagnostics.
3700 cd              fprimcont=0.0D0
3701                 do k=1,3
3702                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3703                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3704                 enddo
3705                 do k=1,3
3706                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3707                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3708                 enddo
3709                 gggp(1)=gggp(1)+ees0pijp*xj
3710                 gggp(2)=gggp(2)+ees0pijp*yj
3711                 gggp(3)=gggp(3)+ees0pijp*zj
3712                 gggm(1)=gggm(1)+ees0mijp*xj
3713                 gggm(2)=gggm(2)+ees0mijp*yj
3714                 gggm(3)=gggm(3)+ees0mijp*zj
3715 C Derivatives due to the contact function
3716                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3717                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3718                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3719                 do k=1,3
3720 c
3721 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3722 c          following the change of gradient-summation algorithm.
3723 c
3724 cgrad                  ghalfp=0.5D0*gggp(k)
3725 cgrad                  ghalfm=0.5D0*gggm(k)
3726                   gacontp_hb1(k,num_conti,i)=!ghalfp
3727      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3728      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3729                   gacontp_hb2(k,num_conti,i)=!ghalfp
3730      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3731      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3732                   gacontp_hb3(k,num_conti,i)=gggp(k)
3733                   gacontm_hb1(k,num_conti,i)=!ghalfm
3734      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3735      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3736                   gacontm_hb2(k,num_conti,i)=!ghalfm
3737      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3738      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3739                   gacontm_hb3(k,num_conti,i)=gggm(k)
3740                 enddo
3741 C Diagnostics. Comment out or remove after debugging!
3742 cdiag           do k=1,3
3743 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3744 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3745 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3746 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3747 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3748 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3749 cdiag           enddo
3750               ENDIF ! wcorr
3751               endif  ! num_conti.le.maxconts
3752             endif  ! fcont.gt.0
3753           endif    ! j.gt.i+1
3754           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3755             do k=1,4
3756               do l=1,3
3757                 ghalf=0.5d0*agg(l,k)
3758                 aggi(l,k)=aggi(l,k)+ghalf
3759                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3760                 aggj(l,k)=aggj(l,k)+ghalf
3761               enddo
3762             enddo
3763             if (j.eq.nres-1 .and. i.lt.j-2) then
3764               do k=1,4
3765                 do l=1,3
3766                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3767                 enddo
3768               enddo
3769             endif
3770           endif
3771 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3772       return
3773       end
3774 C-----------------------------------------------------------------------------
3775       subroutine eturn3(i,eello_turn3)
3776 C Third- and fourth-order contributions from turns
3777       implicit real*8 (a-h,o-z)
3778       include 'DIMENSIONS'
3779       include 'COMMON.IOUNITS'
3780       include 'COMMON.GEO'
3781       include 'COMMON.VAR'
3782       include 'COMMON.LOCAL'
3783       include 'COMMON.CHAIN'
3784       include 'COMMON.DERIV'
3785       include 'COMMON.INTERACT'
3786       include 'COMMON.CONTACTS'
3787       include 'COMMON.TORSION'
3788       include 'COMMON.VECTORS'
3789       include 'COMMON.FFIELD'
3790       include 'COMMON.CONTROL'
3791       dimension ggg(3)
3792       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3793      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3794      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3795       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3796      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3797       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3798      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3799      &    num_conti,j1,j2
3800       j=i+2
3801 c      write (iout,*) "eturn3",i,j,j1,j2
3802       a_temp(1,1)=a22
3803       a_temp(1,2)=a23
3804       a_temp(2,1)=a32
3805       a_temp(2,2)=a33
3806 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3807 C
3808 C               Third-order contributions
3809 C
3810 C                 (i+2)o----(i+3)
3811 C                      | |
3812 C                      | |
3813 C                 (i+1)o----i
3814 C
3815 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3816 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3817         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3818         call transpose2(auxmat(1,1),auxmat1(1,1))
3819         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3820         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3821         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3822      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3823 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3824 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3825 cd     &    ' eello_turn3_num',4*eello_turn3_num
3826 C Derivatives in gamma(i)
3827         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3828         call transpose2(auxmat2(1,1),auxmat3(1,1))
3829         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3830         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3831 C Derivatives in gamma(i+1)
3832         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3833         call transpose2(auxmat2(1,1),auxmat3(1,1))
3834         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3835         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3836      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3837 C Cartesian derivatives
3838         do l=1,3
3839 c            ghalf1=0.5d0*agg(l,1)
3840 c            ghalf2=0.5d0*agg(l,2)
3841 c            ghalf3=0.5d0*agg(l,3)
3842 c            ghalf4=0.5d0*agg(l,4)
3843           a_temp(1,1)=aggi(l,1)!+ghalf1
3844           a_temp(1,2)=aggi(l,2)!+ghalf2
3845           a_temp(2,1)=aggi(l,3)!+ghalf3
3846           a_temp(2,2)=aggi(l,4)!+ghalf4
3847           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3848           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3849      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3850           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3851           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3852           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3853           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3854           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3855           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3856      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3857           a_temp(1,1)=aggj(l,1)!+ghalf1
3858           a_temp(1,2)=aggj(l,2)!+ghalf2
3859           a_temp(2,1)=aggj(l,3)!+ghalf3
3860           a_temp(2,2)=aggj(l,4)!+ghalf4
3861           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3862           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3863      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3864           a_temp(1,1)=aggj1(l,1)
3865           a_temp(1,2)=aggj1(l,2)
3866           a_temp(2,1)=aggj1(l,3)
3867           a_temp(2,2)=aggj1(l,4)
3868           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3869           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3870      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3871         enddo
3872       return
3873       end
3874 C-------------------------------------------------------------------------------
3875       subroutine eturn4(i,eello_turn4)
3876 C Third- and fourth-order contributions from turns
3877       implicit real*8 (a-h,o-z)
3878       include 'DIMENSIONS'
3879       include 'COMMON.IOUNITS'
3880       include 'COMMON.GEO'
3881       include 'COMMON.VAR'
3882       include 'COMMON.LOCAL'
3883       include 'COMMON.CHAIN'
3884       include 'COMMON.DERIV'
3885       include 'COMMON.INTERACT'
3886       include 'COMMON.CONTACTS'
3887       include 'COMMON.TORSION'
3888       include 'COMMON.VECTORS'
3889       include 'COMMON.FFIELD'
3890       include 'COMMON.CONTROL'
3891       dimension ggg(3)
3892       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3893      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3894      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3895       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3896      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3897       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3898      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3899      &    num_conti,j1,j2
3900       j=i+3
3901 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3902 C
3903 C               Fourth-order contributions
3904 C
3905 C                 (i+3)o----(i+4)
3906 C                     /  |
3907 C               (i+2)o   |
3908 C                     \  |
3909 C                 (i+1)o----i
3910 C
3911 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3912 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3913 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3914         a_temp(1,1)=a22
3915         a_temp(1,2)=a23
3916         a_temp(2,1)=a32
3917         a_temp(2,2)=a33
3918         iti1=itortyp(itype(i+1))
3919         iti2=itortyp(itype(i+2))
3920         iti3=itortyp(itype(i+3))
3921 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3922         call transpose2(EUg(1,1,i+1),e1t(1,1))
3923         call transpose2(Eug(1,1,i+2),e2t(1,1))
3924         call transpose2(Eug(1,1,i+3),e3t(1,1))
3925         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3926         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3927         s1=scalar2(b1(1,iti2),auxvec(1))
3928         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3929         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3930         s2=scalar2(b1(1,iti1),auxvec(1))
3931         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3932         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3933         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3934         eello_turn4=eello_turn4-(s1+s2+s3)
3935 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3936         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3937      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3938 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3939 cd     &    ' eello_turn4_num',8*eello_turn4_num
3940 C Derivatives in gamma(i)
3941         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3942         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3943         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3944         s1=scalar2(b1(1,iti2),auxvec(1))
3945         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3946         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3947         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3948 C Derivatives in gamma(i+1)
3949         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3950         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3951         s2=scalar2(b1(1,iti1),auxvec(1))
3952         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3953         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3954         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3955         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3956 C Derivatives in gamma(i+2)
3957         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3958         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3959         s1=scalar2(b1(1,iti2),auxvec(1))
3960         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3961         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3962         s2=scalar2(b1(1,iti1),auxvec(1))
3963         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3964         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3965         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3966         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3967 C Cartesian derivatives
3968 C Derivatives of this turn contributions in DC(i+2)
3969         if (j.lt.nres-1) then
3970           do l=1,3
3971             a_temp(1,1)=agg(l,1)
3972             a_temp(1,2)=agg(l,2)
3973             a_temp(2,1)=agg(l,3)
3974             a_temp(2,2)=agg(l,4)
3975             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3976             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3977             s1=scalar2(b1(1,iti2),auxvec(1))
3978             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3979             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3980             s2=scalar2(b1(1,iti1),auxvec(1))
3981             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3982             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3983             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3984             ggg(l)=-(s1+s2+s3)
3985             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3986           enddo
3987         endif
3988 C Remaining derivatives of this turn contribution
3989         do l=1,3
3990           a_temp(1,1)=aggi(l,1)
3991           a_temp(1,2)=aggi(l,2)
3992           a_temp(2,1)=aggi(l,3)
3993           a_temp(2,2)=aggi(l,4)
3994           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3995           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3996           s1=scalar2(b1(1,iti2),auxvec(1))
3997           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3998           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3999           s2=scalar2(b1(1,iti1),auxvec(1))
4000           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4001           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4002           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4003           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4004           a_temp(1,1)=aggi1(l,1)
4005           a_temp(1,2)=aggi1(l,2)
4006           a_temp(2,1)=aggi1(l,3)
4007           a_temp(2,2)=aggi1(l,4)
4008           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4009           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4010           s1=scalar2(b1(1,iti2),auxvec(1))
4011           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4012           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4013           s2=scalar2(b1(1,iti1),auxvec(1))
4014           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4015           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4016           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4017           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4018           a_temp(1,1)=aggj(l,1)
4019           a_temp(1,2)=aggj(l,2)
4020           a_temp(2,1)=aggj(l,3)
4021           a_temp(2,2)=aggj(l,4)
4022           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4023           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4024           s1=scalar2(b1(1,iti2),auxvec(1))
4025           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4026           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4027           s2=scalar2(b1(1,iti1),auxvec(1))
4028           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4029           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4030           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4031           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4032           a_temp(1,1)=aggj1(l,1)
4033           a_temp(1,2)=aggj1(l,2)
4034           a_temp(2,1)=aggj1(l,3)
4035           a_temp(2,2)=aggj1(l,4)
4036           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4037           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4038           s1=scalar2(b1(1,iti2),auxvec(1))
4039           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4040           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4041           s2=scalar2(b1(1,iti1),auxvec(1))
4042           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4043           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4044           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4045 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4046           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4047         enddo
4048       return
4049       end
4050 C-----------------------------------------------------------------------------
4051       subroutine vecpr(u,v,w)
4052       implicit real*8(a-h,o-z)
4053       dimension u(3),v(3),w(3)
4054       w(1)=u(2)*v(3)-u(3)*v(2)
4055       w(2)=-u(1)*v(3)+u(3)*v(1)
4056       w(3)=u(1)*v(2)-u(2)*v(1)
4057       return
4058       end
4059 C-----------------------------------------------------------------------------
4060       subroutine unormderiv(u,ugrad,unorm,ungrad)
4061 C This subroutine computes the derivatives of a normalized vector u, given
4062 C the derivatives computed without normalization conditions, ugrad. Returns
4063 C ungrad.
4064       implicit none
4065       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4066       double precision vec(3)
4067       double precision scalar
4068       integer i,j
4069 c      write (2,*) 'ugrad',ugrad
4070 c      write (2,*) 'u',u
4071       do i=1,3
4072         vec(i)=scalar(ugrad(1,i),u(1))
4073       enddo
4074 c      write (2,*) 'vec',vec
4075       do i=1,3
4076         do j=1,3
4077           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4078         enddo
4079       enddo
4080 c      write (2,*) 'ungrad',ungrad
4081       return
4082       end
4083 C-----------------------------------------------------------------------------
4084       subroutine escp_soft_sphere(evdw2,evdw2_14)
4085 C
4086 C This subroutine calculates the excluded-volume interaction energy between
4087 C peptide-group centers and side chains and its gradient in virtual-bond and
4088 C side-chain vectors.
4089 C
4090       implicit real*8 (a-h,o-z)
4091       include 'DIMENSIONS'
4092       include 'COMMON.GEO'
4093       include 'COMMON.VAR'
4094       include 'COMMON.LOCAL'
4095       include 'COMMON.CHAIN'
4096       include 'COMMON.DERIV'
4097       include 'COMMON.INTERACT'
4098       include 'COMMON.FFIELD'
4099       include 'COMMON.IOUNITS'
4100       include 'COMMON.CONTROL'
4101       dimension ggg(3)
4102       evdw2=0.0D0
4103       evdw2_14=0.0d0
4104       r0_scp=4.5d0
4105 cd    print '(a)','Enter ESCP'
4106 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4107       do xshift=-1,1
4108       do yshift=-1,1
4109       do zshift=-1,1
4110       do i=iatscp_s,iatscp_e
4111         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4112         iteli=itel(i)
4113         xi=0.5D0*(c(1,i)+c(1,i+1))
4114         yi=0.5D0*(c(2,i)+c(2,i+1))
4115         zi=0.5D0*(c(3,i)+c(3,i+1))
4116 C Return atom into box, boxxsize is size of box in x dimension
4117 c  134   continue
4118 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4119 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4120 C Condition for being inside the proper box
4121 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4122 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4123 c        go to 134
4124 c        endif
4125 c  135   continue
4126 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4127 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4128 C Condition for being inside the proper box
4129 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4130 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4131 c        go to 135
4132 c c       endif
4133 c  136   continue
4134 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4135 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4136 cC Condition for being inside the proper box
4137 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4138 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4139 c        go to 136
4140 c        endif
4141           xi=mod(xi,boxxsize)
4142           if (xi.lt.0) xi=xi+boxxsize
4143           yi=mod(yi,boxysize)
4144           if (yi.lt.0) yi=yi+boxysize
4145           zi=mod(zi,boxzsize)
4146           if (zi.lt.0) zi=zi+boxzsize
4147
4148         do iint=1,nscp_gr(i)
4149
4150         do j=iscpstart(i,iint),iscpend(i,iint)
4151           if (itype(j).eq.ntyp1) cycle
4152           itypj=iabs(itype(j))
4153 C Uncomment following three lines for SC-p interactions
4154 c         xj=c(1,nres+j)-xi
4155 c         yj=c(2,nres+j)-yi
4156 c         zj=c(3,nres+j)-zi
4157 C Uncomment following three lines for Ca-p interactions
4158           xj=c(1,j)
4159           yj=c(2,j)
4160           zj=c(3,j)
4161 c  174   continue
4162 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4163 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4164 C Condition for being inside the proper box
4165 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4166 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4167 c        go to 174
4168 c        endif
4169 c  175   continue
4170 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4171 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4172 cC Condition for being inside the proper box
4173 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4174 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4175 c        go to 175
4176 c        endif
4177 c  176   continue
4178 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4179 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4180 C Condition for being inside the proper box
4181 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4182 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4183 c        go to 176
4184           xj=mod(xj,boxxsize)
4185           if (xj.lt.0) xj=xj+boxxsize
4186           yj=mod(yj,boxysize)
4187           if (yj.lt.0) yj=yj+boxysize
4188           zj=mod(zj,boxzsize)
4189           if (zj.lt.0) zj=zj+boxzsize
4190 c c       endif
4191           xj=xj-xi
4192           yj=yj-yi
4193           zj=zj-zi
4194           rij=xj*xj+yj*yj+zj*zj
4195
4196           r0ij=r0_scp
4197           r0ijsq=r0ij*r0ij
4198           if (rij.lt.r0ijsq) then
4199             evdwij=0.25d0*(rij-r0ijsq)**2
4200             fac=rij-r0ijsq
4201           else
4202             evdwij=0.0d0
4203             fac=0.0d0
4204           endif
4205           evdw2=evdw2+evdwij
4206 C
4207 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4208 C
4209           ggg(1)=xj*fac
4210           ggg(2)=yj*fac
4211           ggg(3)=zj*fac
4212 cgrad          if (j.lt.i) then
4213 cd          write (iout,*) 'j<i'
4214 C Uncomment following three lines for SC-p interactions
4215 c           do k=1,3
4216 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4217 c           enddo
4218 cgrad          else
4219 cd          write (iout,*) 'j>i'
4220 cgrad            do k=1,3
4221 cgrad              ggg(k)=-ggg(k)
4222 C Uncomment following line for SC-p interactions
4223 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4224 cgrad            enddo
4225 cgrad          endif
4226 cgrad          do k=1,3
4227 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4228 cgrad          enddo
4229 cgrad          kstart=min0(i+1,j)
4230 cgrad          kend=max0(i-1,j-1)
4231 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4232 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4233 cgrad          do k=kstart,kend
4234 cgrad            do l=1,3
4235 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4236 cgrad            enddo
4237 cgrad          enddo
4238           do k=1,3
4239             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4240             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4241           enddo
4242         enddo
4243
4244         enddo ! iint
4245       enddo ! i
4246       enddo !zshift
4247       enddo !yshift
4248       enddo !xshift
4249       return
4250       end
4251 C-----------------------------------------------------------------------------
4252       subroutine escp(evdw2,evdw2_14)
4253 C
4254 C This subroutine calculates the excluded-volume interaction energy between
4255 C peptide-group centers and side chains and its gradient in virtual-bond and
4256 C side-chain vectors.
4257 C
4258       implicit real*8 (a-h,o-z)
4259       include 'DIMENSIONS'
4260       include 'COMMON.GEO'
4261       include 'COMMON.VAR'
4262       include 'COMMON.LOCAL'
4263       include 'COMMON.CHAIN'
4264       include 'COMMON.DERIV'
4265       include 'COMMON.INTERACT'
4266       include 'COMMON.FFIELD'
4267       include 'COMMON.IOUNITS'
4268       include 'COMMON.CONTROL'
4269       include 'COMMON.SPLITELE'
4270       dimension ggg(3)
4271       evdw2=0.0D0
4272       evdw2_14=0.0d0
4273 cd    print '(a)','Enter ESCP'
4274 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4275       do xshift=-1,1
4276       do yshift=-1,1
4277       do zshift=-1,1
4278       do i=iatscp_s,iatscp_e
4279         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4280         iteli=itel(i)
4281         xi=0.5D0*(c(1,i)+c(1,i+1))
4282         yi=0.5D0*(c(2,i)+c(2,i+1))
4283         zi=0.5D0*(c(3,i)+c(3,i+1))
4284           xi=mod(xi,boxxsize)
4285           if (xi.lt.0) xi=xi+boxxsize
4286           yi=mod(yi,boxysize)
4287           if (yi.lt.0) yi=yi+boxysize
4288           zi=mod(zi,boxzsize)
4289           if (zi.lt.0) zi=zi+boxzsize
4290
4291 C Return atom into box, boxxsize is size of box in x dimension
4292 c  134   continue
4293 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4294 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4295 C Condition for being inside the proper box
4296 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4297 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4298 c        go to 134
4299 c        endif
4300 c  135   continue
4301 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4302 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4303 C Condition for being inside the proper box
4304 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4305 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4306 c        go to 135
4307 c        endif
4308 c  136   continue
4309 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4310 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4311 C Condition for being inside the proper box
4312 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4313 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4314 c        go to 136
4315 c        endif
4316         do iint=1,nscp_gr(i)
4317
4318         do j=iscpstart(i,iint),iscpend(i,iint)
4319           itypj=iabs(itype(j))
4320           if (itypj.eq.ntyp1) cycle
4321 C Uncomment following three lines for SC-p interactions
4322 c         xj=c(1,nres+j)-xi
4323 c         yj=c(2,nres+j)-yi
4324 c         zj=c(3,nres+j)-zi
4325 C Uncomment following three lines for Ca-p interactions
4326           xj=c(1,j)
4327           yj=c(2,j)
4328           zj=c(3,j)
4329           xj=mod(xj,boxxsize)
4330           if (xj.lt.0) xj=xj+boxxsize
4331           yj=mod(yj,boxysize)
4332           if (yj.lt.0) yj=yj+boxysize
4333           zj=mod(zj,boxzsize)
4334           if (zj.lt.0) zj=zj+boxzsize
4335 c  174   continue
4336 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4337 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4338 C Condition for being inside the proper box
4339 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4340 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4341 c        go to 174
4342 c        endif
4343 c  175   continue
4344 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4345 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4346 cC Condition for being inside the proper box
4347 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4348 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4349 c        go to 175
4350 c        endif
4351 c  176   continue
4352 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4353 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4354 C Condition for being inside the proper box
4355 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4356 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4357 c        go to 176
4358 c        endif
4359           xj=xj-xi
4360           yj=yj-yi
4361           zj=zj-zi
4362           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4363           sss=sscale(1.0d0/(dsqrt(rrij)))
4364           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4365           if (sss.gt.0.0d0) then
4366           fac=rrij**expon2
4367           e1=fac*fac*aad(itypj,iteli)
4368           e2=fac*bad(itypj,iteli)
4369           if (iabs(j-i) .le. 2) then
4370             e1=scal14*e1
4371             e2=scal14*e2
4372             evdw2_14=evdw2_14+(e1+e2)*sss
4373           endif
4374           evdwij=e1+e2
4375           evdw2=evdw2+evdwij*sss
4376           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4377      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4378      &       bad(itypj,iteli)
4379 C
4380 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4381 C
4382           fac=-(evdwij+e1)*rrij*sss
4383           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4384           ggg(1)=xj*fac
4385           ggg(2)=yj*fac
4386           ggg(3)=zj*fac
4387 cgrad          if (j.lt.i) then
4388 cd          write (iout,*) 'j<i'
4389 C Uncomment following three lines for SC-p interactions
4390 c           do k=1,3
4391 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4392 c           enddo
4393 cgrad          else
4394 cd          write (iout,*) 'j>i'
4395 cgrad            do k=1,3
4396 cgrad              ggg(k)=-ggg(k)
4397 C Uncomment following line for SC-p interactions
4398 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4399 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4400 cgrad            enddo
4401 cgrad          endif
4402 cgrad          do k=1,3
4403 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4404 cgrad          enddo
4405 cgrad          kstart=min0(i+1,j)
4406 cgrad          kend=max0(i-1,j-1)
4407 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4408 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4409 cgrad          do k=kstart,kend
4410 cgrad            do l=1,3
4411 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4412 cgrad            enddo
4413 cgrad          enddo
4414           do k=1,3
4415             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4416             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4417           enddo
4418         endif !endif for sscale cutoff
4419         enddo ! j
4420
4421         enddo ! iint
4422       enddo ! i
4423       enddo !zshift
4424       enddo !yshift
4425       enddo !xshift
4426       do i=1,nct
4427         do j=1,3
4428           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4429           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4430           gradx_scp(j,i)=expon*gradx_scp(j,i)
4431         enddo
4432       enddo
4433 C******************************************************************************
4434 C
4435 C                              N O T E !!!
4436 C
4437 C To save time the factor EXPON has been extracted from ALL components
4438 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4439 C use!
4440 C
4441 C******************************************************************************
4442       return
4443       end
4444 C--------------------------------------------------------------------------
4445       subroutine edis(ehpb)
4446 C
4447 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4448 C
4449       implicit real*8 (a-h,o-z)
4450       include 'DIMENSIONS'
4451       include 'COMMON.SBRIDGE'
4452       include 'COMMON.CHAIN'
4453       include 'COMMON.DERIV'
4454       include 'COMMON.VAR'
4455       include 'COMMON.INTERACT'
4456       include 'COMMON.IOUNITS'
4457       dimension ggg(3)
4458       ehpb=0.0D0
4459 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4460 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4461       if (link_end.eq.0) return
4462       do i=link_start,link_end
4463 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4464 C CA-CA distance used in regularization of structure.
4465         ii=ihpb(i)
4466         jj=jhpb(i)
4467 C iii and jjj point to the residues for which the distance is assigned.
4468         if (ii.gt.nres) then
4469           iii=ii-nres
4470           jjj=jj-nres
4471         else
4472           iii=ii
4473           jjj=jj
4474         endif
4475 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4476 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4477 C    distance and angle dependent SS bond potential.
4478         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4479      & iabs(itype(jjj)).eq.1) then
4480           call ssbond_ene(iii,jjj,eij)
4481           ehpb=ehpb+2*eij
4482 cd          write (iout,*) "eij",eij
4483         else
4484 C Calculate the distance between the two points and its difference from the
4485 C target distance.
4486         dd=dist(ii,jj)
4487         rdis=dd-dhpb(i)
4488 C Get the force constant corresponding to this distance.
4489         waga=forcon(i)
4490 C Calculate the contribution to energy.
4491         ehpb=ehpb+waga*rdis*rdis
4492 C
4493 C Evaluate gradient.
4494 C
4495         fac=waga*rdis/dd
4496 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4497 cd   &   ' waga=',waga,' fac=',fac
4498         do j=1,3
4499           ggg(j)=fac*(c(j,jj)-c(j,ii))
4500         enddo
4501 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4502 C If this is a SC-SC distance, we need to calculate the contributions to the
4503 C Cartesian gradient in the SC vectors (ghpbx).
4504         if (iii.lt.ii) then
4505           do j=1,3
4506             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4507             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4508           enddo
4509         endif
4510 cgrad        do j=iii,jjj-1
4511 cgrad          do k=1,3
4512 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4513 cgrad          enddo
4514 cgrad        enddo
4515         do k=1,3
4516           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4517           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4518         enddo
4519         endif
4520       enddo
4521       ehpb=0.5D0*ehpb
4522       return
4523       end
4524 C--------------------------------------------------------------------------
4525       subroutine ssbond_ene(i,j,eij)
4526 C
4527 C Calculate the distance and angle dependent SS-bond potential energy
4528 C using a free-energy function derived based on RHF/6-31G** ab initio
4529 C calculations of diethyl disulfide.
4530 C
4531 C A. Liwo and U. Kozlowska, 11/24/03
4532 C
4533       implicit real*8 (a-h,o-z)
4534       include 'DIMENSIONS'
4535       include 'COMMON.SBRIDGE'
4536       include 'COMMON.CHAIN'
4537       include 'COMMON.DERIV'
4538       include 'COMMON.LOCAL'
4539       include 'COMMON.INTERACT'
4540       include 'COMMON.VAR'
4541       include 'COMMON.IOUNITS'
4542       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4543       itypi=iabs(itype(i))
4544       xi=c(1,nres+i)
4545       yi=c(2,nres+i)
4546       zi=c(3,nres+i)
4547       dxi=dc_norm(1,nres+i)
4548       dyi=dc_norm(2,nres+i)
4549       dzi=dc_norm(3,nres+i)
4550 c      dsci_inv=dsc_inv(itypi)
4551       dsci_inv=vbld_inv(nres+i)
4552       itypj=iabs(itype(j))
4553 c      dscj_inv=dsc_inv(itypj)
4554       dscj_inv=vbld_inv(nres+j)
4555       xj=c(1,nres+j)-xi
4556       yj=c(2,nres+j)-yi
4557       zj=c(3,nres+j)-zi
4558       dxj=dc_norm(1,nres+j)
4559       dyj=dc_norm(2,nres+j)
4560       dzj=dc_norm(3,nres+j)
4561       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4562       rij=dsqrt(rrij)
4563       erij(1)=xj*rij
4564       erij(2)=yj*rij
4565       erij(3)=zj*rij
4566       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4567       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4568       om12=dxi*dxj+dyi*dyj+dzi*dzj
4569       do k=1,3
4570         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4571         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4572       enddo
4573       rij=1.0d0/rij
4574       deltad=rij-d0cm
4575       deltat1=1.0d0-om1
4576       deltat2=1.0d0+om2
4577       deltat12=om2-om1+2.0d0
4578       cosphi=om12-om1*om2
4579       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4580      &  +akct*deltad*deltat12
4581      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4582 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4583 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4584 c     &  " deltat12",deltat12," eij",eij
4585       ed=2*akcm*deltad+akct*deltat12
4586       pom1=akct*deltad
4587       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4588       eom1=-2*akth*deltat1-pom1-om2*pom2
4589       eom2= 2*akth*deltat2+pom1-om1*pom2
4590       eom12=pom2
4591       do k=1,3
4592         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4593         ghpbx(k,i)=ghpbx(k,i)-ggk
4594      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4595      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4596         ghpbx(k,j)=ghpbx(k,j)+ggk
4597      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4598      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4599         ghpbc(k,i)=ghpbc(k,i)-ggk
4600         ghpbc(k,j)=ghpbc(k,j)+ggk
4601       enddo
4602 C
4603 C Calculate the components of the gradient in DC and X
4604 C
4605 cgrad      do k=i,j-1
4606 cgrad        do l=1,3
4607 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4608 cgrad        enddo
4609 cgrad      enddo
4610       return
4611       end
4612 C--------------------------------------------------------------------------
4613       subroutine ebond(estr)
4614 c
4615 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4616 c
4617       implicit real*8 (a-h,o-z)
4618       include 'DIMENSIONS'
4619       include 'COMMON.LOCAL'
4620       include 'COMMON.GEO'
4621       include 'COMMON.INTERACT'
4622       include 'COMMON.DERIV'
4623       include 'COMMON.VAR'
4624       include 'COMMON.CHAIN'
4625       include 'COMMON.IOUNITS'
4626       include 'COMMON.NAMES'
4627       include 'COMMON.FFIELD'
4628       include 'COMMON.CONTROL'
4629       include 'COMMON.SETUP'
4630       double precision u(3),ud(3)
4631       estr=0.0d0
4632       estr1=0.0d0
4633       do i=ibondp_start,ibondp_end
4634         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4635 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4636 c          do j=1,3
4637 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4638 c     &      *dc(j,i-1)/vbld(i)
4639 c          enddo
4640 c          if (energy_dec) write(iout,*)
4641 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4642 c        else
4643 C       Checking if it involves dummy (NH3+ or COO-) group
4644          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4645 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4646         diff = vbld(i)-vbldpDUM
4647          else
4648 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4649         diff = vbld(i)-vbldp0
4650          endif
4651         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4652      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4653         estr=estr+diff*diff
4654         do j=1,3
4655           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4656         enddo
4657 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4658 c        endif
4659       enddo
4660       estr=0.5d0*AKP*estr+estr1
4661 c
4662 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4663 c
4664       do i=ibond_start,ibond_end
4665         iti=iabs(itype(i))
4666         if (iti.ne.10 .and. iti.ne.ntyp1) then
4667           nbi=nbondterm(iti)
4668           if (nbi.eq.1) then
4669             diff=vbld(i+nres)-vbldsc0(1,iti)
4670             if (energy_dec) write (iout,*)
4671      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4672      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4673             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4674             do j=1,3
4675               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4676             enddo
4677           else
4678             do j=1,nbi
4679               diff=vbld(i+nres)-vbldsc0(j,iti)
4680               ud(j)=aksc(j,iti)*diff
4681               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4682             enddo
4683             uprod=u(1)
4684             do j=2,nbi
4685               uprod=uprod*u(j)
4686             enddo
4687             usum=0.0d0
4688             usumsqder=0.0d0
4689             do j=1,nbi
4690               uprod1=1.0d0
4691               uprod2=1.0d0
4692               do k=1,nbi
4693                 if (k.ne.j) then
4694                   uprod1=uprod1*u(k)
4695                   uprod2=uprod2*u(k)*u(k)
4696                 endif
4697               enddo
4698               usum=usum+uprod1
4699               usumsqder=usumsqder+ud(j)*uprod2
4700             enddo
4701             estr=estr+uprod/usum
4702             do j=1,3
4703              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4704             enddo
4705           endif
4706         endif
4707       enddo
4708       return
4709       end
4710 #ifdef CRYST_THETA
4711 C--------------------------------------------------------------------------
4712       subroutine ebend(etheta)
4713 C
4714 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4715 C angles gamma and its derivatives in consecutive thetas and gammas.
4716 C
4717       implicit real*8 (a-h,o-z)
4718       include 'DIMENSIONS'
4719       include 'COMMON.LOCAL'
4720       include 'COMMON.GEO'
4721       include 'COMMON.INTERACT'
4722       include 'COMMON.DERIV'
4723       include 'COMMON.VAR'
4724       include 'COMMON.CHAIN'
4725       include 'COMMON.IOUNITS'
4726       include 'COMMON.NAMES'
4727       include 'COMMON.FFIELD'
4728       include 'COMMON.CONTROL'
4729       common /calcthet/ term1,term2,termm,diffak,ratak,
4730      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4731      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4732       double precision y(2),z(2)
4733       delta=0.02d0*pi
4734 c      time11=dexp(-2*time)
4735 c      time12=1.0d0
4736       etheta=0.0D0
4737 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4738       do i=ithet_start,ithet_end
4739         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4740      &  .or.itype(i).eq.ntyp1) cycle
4741 C Zero the energy function and its derivative at 0 or pi.
4742         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4743         it=itype(i-1)
4744         ichir1=isign(1,itype(i-2))
4745         ichir2=isign(1,itype(i))
4746          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4747          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4748          if (itype(i-1).eq.10) then
4749           itype1=isign(10,itype(i-2))
4750           ichir11=isign(1,itype(i-2))
4751           ichir12=isign(1,itype(i-2))
4752           itype2=isign(10,itype(i))
4753           ichir21=isign(1,itype(i))
4754           ichir22=isign(1,itype(i))
4755          endif
4756
4757         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4758 #ifdef OSF
4759           phii=phi(i)
4760           if (phii.ne.phii) phii=150.0
4761 #else
4762           phii=phi(i)
4763 #endif
4764           y(1)=dcos(phii)
4765           y(2)=dsin(phii)
4766         else
4767           y(1)=0.0D0
4768           y(2)=0.0D0
4769         endif
4770         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4771 #ifdef OSF
4772           phii1=phi(i+1)
4773           if (phii1.ne.phii1) phii1=150.0
4774           phii1=pinorm(phii1)
4775           z(1)=cos(phii1)
4776 #else
4777           phii1=phi(i+1)
4778 #endif
4779           z(1)=dcos(phii1)
4780           z(2)=dsin(phii1)
4781         else
4782           z(1)=0.0D0
4783           z(2)=0.0D0
4784         endif
4785 C Calculate the "mean" value of theta from the part of the distribution
4786 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4787 C In following comments this theta will be referred to as t_c.
4788         thet_pred_mean=0.0d0
4789         do k=1,2
4790             athetk=athet(k,it,ichir1,ichir2)
4791             bthetk=bthet(k,it,ichir1,ichir2)
4792           if (it.eq.10) then
4793              athetk=athet(k,itype1,ichir11,ichir12)
4794              bthetk=bthet(k,itype2,ichir21,ichir22)
4795           endif
4796          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4797 c         write(iout,*) 'chuj tu', y(k),z(k)
4798         enddo
4799         dthett=thet_pred_mean*ssd
4800         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4801 C Derivatives of the "mean" values in gamma1 and gamma2.
4802         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4803      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4804          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4805      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4806          if (it.eq.10) then
4807       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4808      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4809         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4810      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4811          endif
4812         if (theta(i).gt.pi-delta) then
4813           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4814      &         E_tc0)
4815           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4816           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4817           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4818      &        E_theta)
4819           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4820      &        E_tc)
4821         else if (theta(i).lt.delta) then
4822           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4823           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4824           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4825      &        E_theta)
4826           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4827           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4828      &        E_tc)
4829         else
4830           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4831      &        E_theta,E_tc)
4832         endif
4833         etheta=etheta+ethetai
4834         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4835      &      'ebend',i,ethetai,theta(i),itype(i)
4836         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4837         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4838         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4839       enddo
4840 C Ufff.... We've done all this!!!
4841       return
4842       end
4843 C---------------------------------------------------------------------------
4844       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4845      &     E_tc)
4846       implicit real*8 (a-h,o-z)
4847       include 'DIMENSIONS'
4848       include 'COMMON.LOCAL'
4849       include 'COMMON.IOUNITS'
4850       common /calcthet/ term1,term2,termm,diffak,ratak,
4851      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4852      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4853 C Calculate the contributions to both Gaussian lobes.
4854 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4855 C The "polynomial part" of the "standard deviation" of this part of
4856 C the distributioni.
4857 ccc        write (iout,*) thetai,thet_pred_mean
4858         sig=polthet(3,it)
4859         do j=2,0,-1
4860           sig=sig*thet_pred_mean+polthet(j,it)
4861         enddo
4862 C Derivative of the "interior part" of the "standard deviation of the"
4863 C gamma-dependent Gaussian lobe in t_c.
4864         sigtc=3*polthet(3,it)
4865         do j=2,1,-1
4866           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4867         enddo
4868         sigtc=sig*sigtc
4869 C Set the parameters of both Gaussian lobes of the distribution.
4870 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4871         fac=sig*sig+sigc0(it)
4872         sigcsq=fac+fac
4873         sigc=1.0D0/sigcsq
4874 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4875         sigsqtc=-4.0D0*sigcsq*sigtc
4876 c       print *,i,sig,sigtc,sigsqtc
4877 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4878         sigtc=-sigtc/(fac*fac)
4879 C Following variable is sigma(t_c)**(-2)
4880         sigcsq=sigcsq*sigcsq
4881         sig0i=sig0(it)
4882         sig0inv=1.0D0/sig0i**2
4883         delthec=thetai-thet_pred_mean
4884         delthe0=thetai-theta0i
4885         term1=-0.5D0*sigcsq*delthec*delthec
4886         term2=-0.5D0*sig0inv*delthe0*delthe0
4887 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
4888 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4889 C NaNs in taking the logarithm. We extract the largest exponent which is added
4890 C to the energy (this being the log of the distribution) at the end of energy
4891 C term evaluation for this virtual-bond angle.
4892         if (term1.gt.term2) then
4893           termm=term1
4894           term2=dexp(term2-termm)
4895           term1=1.0d0
4896         else
4897           termm=term2
4898           term1=dexp(term1-termm)
4899           term2=1.0d0
4900         endif
4901 C The ratio between the gamma-independent and gamma-dependent lobes of
4902 C the distribution is a Gaussian function of thet_pred_mean too.
4903         diffak=gthet(2,it)-thet_pred_mean
4904         ratak=diffak/gthet(3,it)**2
4905         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4906 C Let's differentiate it in thet_pred_mean NOW.
4907         aktc=ak*ratak
4908 C Now put together the distribution terms to make complete distribution.
4909         termexp=term1+ak*term2
4910         termpre=sigc+ak*sig0i
4911 C Contribution of the bending energy from this theta is just the -log of
4912 C the sum of the contributions from the two lobes and the pre-exponential
4913 C factor. Simple enough, isn't it?
4914         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4915 C       write (iout,*) 'termexp',termexp,termm,termpre,i
4916 C NOW the derivatives!!!
4917 C 6/6/97 Take into account the deformation.
4918         E_theta=(delthec*sigcsq*term1
4919      &       +ak*delthe0*sig0inv*term2)/termexp
4920         E_tc=((sigtc+aktc*sig0i)/termpre
4921      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4922      &       aktc*term2)/termexp)
4923       return
4924       end
4925 c-----------------------------------------------------------------------------
4926       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4927       implicit real*8 (a-h,o-z)
4928       include 'DIMENSIONS'
4929       include 'COMMON.LOCAL'
4930       include 'COMMON.IOUNITS'
4931       common /calcthet/ term1,term2,termm,diffak,ratak,
4932      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4933      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4934       delthec=thetai-thet_pred_mean
4935       delthe0=thetai-theta0i
4936 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4937       t3 = thetai-thet_pred_mean
4938       t6 = t3**2
4939       t9 = term1
4940       t12 = t3*sigcsq
4941       t14 = t12+t6*sigsqtc
4942       t16 = 1.0d0
4943       t21 = thetai-theta0i
4944       t23 = t21**2
4945       t26 = term2
4946       t27 = t21*t26
4947       t32 = termexp
4948       t40 = t32**2
4949       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4950      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4951      & *(-t12*t9-ak*sig0inv*t27)
4952       return
4953       end
4954 #else
4955 C--------------------------------------------------------------------------
4956       subroutine ebend(etheta)
4957 C
4958 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4959 C angles gamma and its derivatives in consecutive thetas and gammas.
4960 C ab initio-derived potentials from
4961 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4962 C
4963       implicit real*8 (a-h,o-z)
4964       include 'DIMENSIONS'
4965       include 'COMMON.LOCAL'
4966       include 'COMMON.GEO'
4967       include 'COMMON.INTERACT'
4968       include 'COMMON.DERIV'
4969       include 'COMMON.VAR'
4970       include 'COMMON.CHAIN'
4971       include 'COMMON.IOUNITS'
4972       include 'COMMON.NAMES'
4973       include 'COMMON.FFIELD'
4974       include 'COMMON.CONTROL'
4975       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4976      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4977      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4978      & sinph1ph2(maxdouble,maxdouble)
4979       logical lprn /.false./, lprn1 /.false./
4980       etheta=0.0D0
4981       do i=ithet_start,ithet_end
4982 c        print *,i,itype(i-1),itype(i),itype(i-2)
4983         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4984      &  .or.itype(i).eq.ntyp1) cycle
4985 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4986
4987         if (iabs(itype(i+1)).eq.20) iblock=2
4988         if (iabs(itype(i+1)).ne.20) iblock=1
4989         dethetai=0.0d0
4990         dephii=0.0d0
4991         dephii1=0.0d0
4992         theti2=0.5d0*theta(i)
4993         ityp2=ithetyp((itype(i-1)))
4994         do k=1,nntheterm
4995           coskt(k)=dcos(k*theti2)
4996           sinkt(k)=dsin(k*theti2)
4997         enddo
4998         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4999 #ifdef OSF
5000           phii=phi(i)
5001           if (phii.ne.phii) phii=150.0
5002 #else
5003           phii=phi(i)
5004 #endif
5005           ityp1=ithetyp((itype(i-2)))
5006 C propagation of chirality for glycine type
5007           do k=1,nsingle
5008             cosph1(k)=dcos(k*phii)
5009             sinph1(k)=dsin(k*phii)
5010           enddo
5011         else
5012           phii=0.0d0
5013           ityp1=nthetyp+1
5014           do k=1,nsingle
5015             cosph1(k)=0.0d0
5016             sinph1(k)=0.0d0
5017           enddo
5018         endif
5019         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5020 #ifdef OSF
5021           phii1=phi(i+1)
5022           if (phii1.ne.phii1) phii1=150.0
5023           phii1=pinorm(phii1)
5024 #else
5025           phii1=phi(i+1)
5026 #endif
5027           ityp3=ithetyp((itype(i)))
5028           do k=1,nsingle
5029             cosph2(k)=dcos(k*phii1)
5030             sinph2(k)=dsin(k*phii1)
5031           enddo
5032         else
5033           phii1=0.0d0
5034           ityp3=nthetyp+1
5035           do k=1,nsingle
5036             cosph2(k)=0.0d0
5037             sinph2(k)=0.0d0
5038           enddo
5039         endif
5040         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5041         do k=1,ndouble
5042           do l=1,k-1
5043             ccl=cosph1(l)*cosph2(k-l)
5044             ssl=sinph1(l)*sinph2(k-l)
5045             scl=sinph1(l)*cosph2(k-l)
5046             csl=cosph1(l)*sinph2(k-l)
5047             cosph1ph2(l,k)=ccl-ssl
5048             cosph1ph2(k,l)=ccl+ssl
5049             sinph1ph2(l,k)=scl+csl
5050             sinph1ph2(k,l)=scl-csl
5051           enddo
5052         enddo
5053         if (lprn) then
5054         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5055      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5056         write (iout,*) "coskt and sinkt"
5057         do k=1,nntheterm
5058           write (iout,*) k,coskt(k),sinkt(k)
5059         enddo
5060         endif
5061         do k=1,ntheterm
5062           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5063           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5064      &      *coskt(k)
5065           if (lprn)
5066      &    write (iout,*) "k",k,"
5067      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5068      &     " ethetai",ethetai
5069         enddo
5070         if (lprn) then
5071         write (iout,*) "cosph and sinph"
5072         do k=1,nsingle
5073           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5074         enddo
5075         write (iout,*) "cosph1ph2 and sinph2ph2"
5076         do k=2,ndouble
5077           do l=1,k-1
5078             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5079      &         sinph1ph2(l,k),sinph1ph2(k,l)
5080           enddo
5081         enddo
5082         write(iout,*) "ethetai",ethetai
5083         endif
5084         do m=1,ntheterm2
5085           do k=1,nsingle
5086             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5087      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5088      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5089      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5090             ethetai=ethetai+sinkt(m)*aux
5091             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5092             dephii=dephii+k*sinkt(m)*(
5093      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5094      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5095             dephii1=dephii1+k*sinkt(m)*(
5096      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5097      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5098             if (lprn)
5099      &      write (iout,*) "m",m," k",k," bbthet",
5100      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5101      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5102      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5103      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5104           enddo
5105         enddo
5106         if (lprn)
5107      &  write(iout,*) "ethetai",ethetai
5108         do m=1,ntheterm3
5109           do k=2,ndouble
5110             do l=1,k-1
5111               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5112      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5113      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5114      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5115               ethetai=ethetai+sinkt(m)*aux
5116               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5117               dephii=dephii+l*sinkt(m)*(
5118      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5119      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5120      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5121      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5122               dephii1=dephii1+(k-l)*sinkt(m)*(
5123      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5124      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5125      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5126      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5127               if (lprn) then
5128               write (iout,*) "m",m," k",k," l",l," ffthet",
5129      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5130      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5131      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5132      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5133      &            " ethetai",ethetai
5134               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5135      &            cosph1ph2(k,l)*sinkt(m),
5136      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5137               endif
5138             enddo
5139           enddo
5140         enddo
5141 10      continue
5142 c        lprn1=.true.
5143         if (lprn1)
5144      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5145      &   i,theta(i)*rad2deg,phii*rad2deg,
5146      &   phii1*rad2deg,ethetai
5147 c        lprn1=.false.
5148         etheta=etheta+ethetai
5149         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5150         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5151         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5152       enddo
5153       return
5154       end
5155 #endif
5156 #ifdef CRYST_SC
5157 c-----------------------------------------------------------------------------
5158       subroutine esc(escloc)
5159 C Calculate the local energy of a side chain and its derivatives in the
5160 C corresponding virtual-bond valence angles THETA and the spherical angles
5161 C ALPHA and OMEGA.
5162       implicit real*8 (a-h,o-z)
5163       include 'DIMENSIONS'
5164       include 'COMMON.GEO'
5165       include 'COMMON.LOCAL'
5166       include 'COMMON.VAR'
5167       include 'COMMON.INTERACT'
5168       include 'COMMON.DERIV'
5169       include 'COMMON.CHAIN'
5170       include 'COMMON.IOUNITS'
5171       include 'COMMON.NAMES'
5172       include 'COMMON.FFIELD'
5173       include 'COMMON.CONTROL'
5174       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5175      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5176       common /sccalc/ time11,time12,time112,theti,it,nlobit
5177       delta=0.02d0*pi
5178       escloc=0.0D0
5179 c     write (iout,'(a)') 'ESC'
5180       do i=loc_start,loc_end
5181         it=itype(i)
5182         if (it.eq.ntyp1) cycle
5183         if (it.eq.10) goto 1
5184         nlobit=nlob(iabs(it))
5185 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5186 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5187         theti=theta(i+1)-pipol
5188         x(1)=dtan(theti)
5189         x(2)=alph(i)
5190         x(3)=omeg(i)
5191
5192         if (x(2).gt.pi-delta) then
5193           xtemp(1)=x(1)
5194           xtemp(2)=pi-delta
5195           xtemp(3)=x(3)
5196           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5197           xtemp(2)=pi
5198           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5199           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5200      &        escloci,dersc(2))
5201           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5202      &        ddersc0(1),dersc(1))
5203           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5204      &        ddersc0(3),dersc(3))
5205           xtemp(2)=pi-delta
5206           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5207           xtemp(2)=pi
5208           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5209           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5210      &            dersc0(2),esclocbi,dersc02)
5211           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5212      &            dersc12,dersc01)
5213           call splinthet(x(2),0.5d0*delta,ss,ssd)
5214           dersc0(1)=dersc01
5215           dersc0(2)=dersc02
5216           dersc0(3)=0.0d0
5217           do k=1,3
5218             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5219           enddo
5220           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5221 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5222 c    &             esclocbi,ss,ssd
5223           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5224 c         escloci=esclocbi
5225 c         write (iout,*) escloci
5226         else if (x(2).lt.delta) then
5227           xtemp(1)=x(1)
5228           xtemp(2)=delta
5229           xtemp(3)=x(3)
5230           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5231           xtemp(2)=0.0d0
5232           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5233           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5234      &        escloci,dersc(2))
5235           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5236      &        ddersc0(1),dersc(1))
5237           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5238      &        ddersc0(3),dersc(3))
5239           xtemp(2)=delta
5240           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5241           xtemp(2)=0.0d0
5242           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5243           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5244      &            dersc0(2),esclocbi,dersc02)
5245           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5246      &            dersc12,dersc01)
5247           dersc0(1)=dersc01
5248           dersc0(2)=dersc02
5249           dersc0(3)=0.0d0
5250           call splinthet(x(2),0.5d0*delta,ss,ssd)
5251           do k=1,3
5252             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5253           enddo
5254           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5255 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5256 c    &             esclocbi,ss,ssd
5257           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5258 c         write (iout,*) escloci
5259         else
5260           call enesc(x,escloci,dersc,ddummy,.false.)
5261         endif
5262
5263         escloc=escloc+escloci
5264         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5265      &     'escloc',i,escloci
5266 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5267
5268         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5269      &   wscloc*dersc(1)
5270         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5271         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5272     1   continue
5273       enddo
5274       return
5275       end
5276 C---------------------------------------------------------------------------
5277       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5278       implicit real*8 (a-h,o-z)
5279       include 'DIMENSIONS'
5280       include 'COMMON.GEO'
5281       include 'COMMON.LOCAL'
5282       include 'COMMON.IOUNITS'
5283       common /sccalc/ time11,time12,time112,theti,it,nlobit
5284       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5285       double precision contr(maxlob,-1:1)
5286       logical mixed
5287 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5288         escloc_i=0.0D0
5289         do j=1,3
5290           dersc(j)=0.0D0
5291           if (mixed) ddersc(j)=0.0d0
5292         enddo
5293         x3=x(3)
5294
5295 C Because of periodicity of the dependence of the SC energy in omega we have
5296 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5297 C To avoid underflows, first compute & store the exponents.
5298
5299         do iii=-1,1
5300
5301           x(3)=x3+iii*dwapi
5302
5303           do j=1,nlobit
5304             do k=1,3
5305               z(k)=x(k)-censc(k,j,it)
5306             enddo
5307             do k=1,3
5308               Axk=0.0D0
5309               do l=1,3
5310                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5311               enddo
5312               Ax(k,j,iii)=Axk
5313             enddo
5314             expfac=0.0D0
5315             do k=1,3
5316               expfac=expfac+Ax(k,j,iii)*z(k)
5317             enddo
5318             contr(j,iii)=expfac
5319           enddo ! j
5320
5321         enddo ! iii
5322
5323         x(3)=x3
5324 C As in the case of ebend, we want to avoid underflows in exponentiation and
5325 C subsequent NaNs and INFs in energy calculation.
5326 C Find the largest exponent
5327         emin=contr(1,-1)
5328         do iii=-1,1
5329           do j=1,nlobit
5330             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5331           enddo
5332         enddo
5333         emin=0.5D0*emin
5334 cd      print *,'it=',it,' emin=',emin
5335
5336 C Compute the contribution to SC energy and derivatives
5337         do iii=-1,1
5338
5339           do j=1,nlobit
5340 #ifdef OSF
5341             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5342             if(adexp.ne.adexp) adexp=1.0
5343             expfac=dexp(adexp)
5344 #else
5345             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5346 #endif
5347 cd          print *,'j=',j,' expfac=',expfac
5348             escloc_i=escloc_i+expfac
5349             do k=1,3
5350               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5351             enddo
5352             if (mixed) then
5353               do k=1,3,2
5354                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5355      &            +gaussc(k,2,j,it))*expfac
5356               enddo
5357             endif
5358           enddo
5359
5360         enddo ! iii
5361
5362         dersc(1)=dersc(1)/cos(theti)**2
5363         ddersc(1)=ddersc(1)/cos(theti)**2
5364         ddersc(3)=ddersc(3)
5365
5366         escloci=-(dlog(escloc_i)-emin)
5367         do j=1,3
5368           dersc(j)=dersc(j)/escloc_i
5369         enddo
5370         if (mixed) then
5371           do j=1,3,2
5372             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5373           enddo
5374         endif
5375       return
5376       end
5377 C------------------------------------------------------------------------------
5378       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5379       implicit real*8 (a-h,o-z)
5380       include 'DIMENSIONS'
5381       include 'COMMON.GEO'
5382       include 'COMMON.LOCAL'
5383       include 'COMMON.IOUNITS'
5384       common /sccalc/ time11,time12,time112,theti,it,nlobit
5385       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5386       double precision contr(maxlob)
5387       logical mixed
5388
5389       escloc_i=0.0D0
5390
5391       do j=1,3
5392         dersc(j)=0.0D0
5393       enddo
5394
5395       do j=1,nlobit
5396         do k=1,2
5397           z(k)=x(k)-censc(k,j,it)
5398         enddo
5399         z(3)=dwapi
5400         do k=1,3
5401           Axk=0.0D0
5402           do l=1,3
5403             Axk=Axk+gaussc(l,k,j,it)*z(l)
5404           enddo
5405           Ax(k,j)=Axk
5406         enddo
5407         expfac=0.0D0
5408         do k=1,3
5409           expfac=expfac+Ax(k,j)*z(k)
5410         enddo
5411         contr(j)=expfac
5412       enddo ! j
5413
5414 C As in the case of ebend, we want to avoid underflows in exponentiation and
5415 C subsequent NaNs and INFs in energy calculation.
5416 C Find the largest exponent
5417       emin=contr(1)
5418       do j=1,nlobit
5419         if (emin.gt.contr(j)) emin=contr(j)
5420       enddo
5421       emin=0.5D0*emin
5422
5423 C Compute the contribution to SC energy and derivatives
5424
5425       dersc12=0.0d0
5426       do j=1,nlobit
5427         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5428         escloc_i=escloc_i+expfac
5429         do k=1,2
5430           dersc(k)=dersc(k)+Ax(k,j)*expfac
5431         enddo
5432         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5433      &            +gaussc(1,2,j,it))*expfac
5434         dersc(3)=0.0d0
5435       enddo
5436
5437       dersc(1)=dersc(1)/cos(theti)**2
5438       dersc12=dersc12/cos(theti)**2
5439       escloci=-(dlog(escloc_i)-emin)
5440       do j=1,2
5441         dersc(j)=dersc(j)/escloc_i
5442       enddo
5443       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5444       return
5445       end
5446 #else
5447 c----------------------------------------------------------------------------------
5448       subroutine esc(escloc)
5449 C Calculate the local energy of a side chain and its derivatives in the
5450 C corresponding virtual-bond valence angles THETA and the spherical angles
5451 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5452 C added by Urszula Kozlowska. 07/11/2007
5453 C
5454       implicit real*8 (a-h,o-z)
5455       include 'DIMENSIONS'
5456       include 'COMMON.GEO'
5457       include 'COMMON.LOCAL'
5458       include 'COMMON.VAR'
5459       include 'COMMON.SCROT'
5460       include 'COMMON.INTERACT'
5461       include 'COMMON.DERIV'
5462       include 'COMMON.CHAIN'
5463       include 'COMMON.IOUNITS'
5464       include 'COMMON.NAMES'
5465       include 'COMMON.FFIELD'
5466       include 'COMMON.CONTROL'
5467       include 'COMMON.VECTORS'
5468       double precision x_prime(3),y_prime(3),z_prime(3)
5469      &    , sumene,dsc_i,dp2_i,x(65),
5470      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5471      &    de_dxx,de_dyy,de_dzz,de_dt
5472       double precision s1_t,s1_6_t,s2_t,s2_6_t
5473       double precision
5474      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5475      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5476      & dt_dCi(3),dt_dCi1(3)
5477       common /sccalc/ time11,time12,time112,theti,it,nlobit
5478       delta=0.02d0*pi
5479       escloc=0.0D0
5480       do i=loc_start,loc_end
5481         if (itype(i).eq.ntyp1) cycle
5482         costtab(i+1) =dcos(theta(i+1))
5483         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5484         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5485         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5486         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5487         cosfac=dsqrt(cosfac2)
5488         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5489         sinfac=dsqrt(sinfac2)
5490         it=iabs(itype(i))
5491         if (it.eq.10) goto 1
5492 c
5493 C  Compute the axes of tghe local cartesian coordinates system; store in
5494 c   x_prime, y_prime and z_prime
5495 c
5496         do j=1,3
5497           x_prime(j) = 0.00
5498           y_prime(j) = 0.00
5499           z_prime(j) = 0.00
5500         enddo
5501 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5502 C     &   dc_norm(3,i+nres)
5503         do j = 1,3
5504           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5505           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5506         enddo
5507         do j = 1,3
5508           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5509         enddo
5510 c       write (2,*) "i",i
5511 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5512 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5513 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5514 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5515 c      & " xy",scalar(x_prime(1),y_prime(1)),
5516 c      & " xz",scalar(x_prime(1),z_prime(1)),
5517 c      & " yy",scalar(y_prime(1),y_prime(1)),
5518 c      & " yz",scalar(y_prime(1),z_prime(1)),
5519 c      & " zz",scalar(z_prime(1),z_prime(1))
5520 c
5521 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5522 C to local coordinate system. Store in xx, yy, zz.
5523 c
5524         xx=0.0d0
5525         yy=0.0d0
5526         zz=0.0d0
5527         do j = 1,3
5528           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5529           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5530           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5531         enddo
5532
5533         xxtab(i)=xx
5534         yytab(i)=yy
5535         zztab(i)=zz
5536 C
5537 C Compute the energy of the ith side cbain
5538 C
5539 c        write (2,*) "xx",xx," yy",yy," zz",zz
5540         it=iabs(itype(i))
5541         do j = 1,65
5542           x(j) = sc_parmin(j,it)
5543         enddo
5544 #ifdef CHECK_COORD
5545 Cc diagnostics - remove later
5546         xx1 = dcos(alph(2))
5547         yy1 = dsin(alph(2))*dcos(omeg(2))
5548         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5549         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5550      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5551      &    xx1,yy1,zz1
5552 C,"  --- ", xx_w,yy_w,zz_w
5553 c end diagnostics
5554 #endif
5555         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5556      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5557      &   + x(10)*yy*zz
5558         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5559      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5560      & + x(20)*yy*zz
5561         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5562      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5563      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5564      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5565      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5566      &  +x(40)*xx*yy*zz
5567         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5568      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5569      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5570      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5571      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5572      &  +x(60)*xx*yy*zz
5573         dsc_i   = 0.743d0+x(61)
5574         dp2_i   = 1.9d0+x(62)
5575         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5576      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5577         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5578      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5579         s1=(1+x(63))/(0.1d0 + dscp1)
5580         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5581         s2=(1+x(65))/(0.1d0 + dscp2)
5582         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5583         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5584      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5585 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5586 c     &   sumene4,
5587 c     &   dscp1,dscp2,sumene
5588 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5589         escloc = escloc + sumene
5590 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5591 c     & ,zz,xx,yy
5592 c#define DEBUG
5593 #ifdef DEBUG
5594 C
5595 C This section to check the numerical derivatives of the energy of ith side
5596 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5597 C #define DEBUG in the code to turn it on.
5598 C
5599         write (2,*) "sumene               =",sumene
5600         aincr=1.0d-7
5601         xxsave=xx
5602         xx=xx+aincr
5603         write (2,*) xx,yy,zz
5604         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5605         de_dxx_num=(sumenep-sumene)/aincr
5606         xx=xxsave
5607         write (2,*) "xx+ sumene from enesc=",sumenep
5608         yysave=yy
5609         yy=yy+aincr
5610         write (2,*) xx,yy,zz
5611         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5612         de_dyy_num=(sumenep-sumene)/aincr
5613         yy=yysave
5614         write (2,*) "yy+ sumene from enesc=",sumenep
5615         zzsave=zz
5616         zz=zz+aincr
5617         write (2,*) xx,yy,zz
5618         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5619         de_dzz_num=(sumenep-sumene)/aincr
5620         zz=zzsave
5621         write (2,*) "zz+ sumene from enesc=",sumenep
5622         costsave=cost2tab(i+1)
5623         sintsave=sint2tab(i+1)
5624         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5625         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5626         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5627         de_dt_num=(sumenep-sumene)/aincr
5628         write (2,*) " t+ sumene from enesc=",sumenep
5629         cost2tab(i+1)=costsave
5630         sint2tab(i+1)=sintsave
5631 C End of diagnostics section.
5632 #endif
5633 C
5634 C Compute the gradient of esc
5635 C
5636 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5637         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5638         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5639         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5640         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5641         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5642         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5643         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5644         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5645         pom1=(sumene3*sint2tab(i+1)+sumene1)
5646      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5647         pom2=(sumene4*cost2tab(i+1)+sumene2)
5648      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5649         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5650         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5651      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5652      &  +x(40)*yy*zz
5653         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5654         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5655      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5656      &  +x(60)*yy*zz
5657         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5658      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5659      &        +(pom1+pom2)*pom_dx
5660 #ifdef DEBUG
5661         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5662 #endif
5663 C
5664         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5665         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5666      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5667      &  +x(40)*xx*zz
5668         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5669         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5670      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5671      &  +x(59)*zz**2 +x(60)*xx*zz
5672         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5673      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5674      &        +(pom1-pom2)*pom_dy
5675 #ifdef DEBUG
5676         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5677 #endif
5678 C
5679         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5680      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5681      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5682      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5683      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5684      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5685      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5686      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5687 #ifdef DEBUG
5688         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5689 #endif
5690 C
5691         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5692      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5693      &  +pom1*pom_dt1+pom2*pom_dt2
5694 #ifdef DEBUG
5695         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5696 #endif
5697 c#undef DEBUG
5698 c
5699 C
5700        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5701        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5702        cosfac2xx=cosfac2*xx
5703        sinfac2yy=sinfac2*yy
5704        do k = 1,3
5705          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5706      &      vbld_inv(i+1)
5707          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5708      &      vbld_inv(i)
5709          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5710          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5711 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5712 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5713 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5714 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5715          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5716          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5717          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5718          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5719          dZZ_Ci1(k)=0.0d0
5720          dZZ_Ci(k)=0.0d0
5721          do j=1,3
5722            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5723      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5724            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5725      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5726          enddo
5727
5728          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5729          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5730          dZZ_XYZ(k)=vbld_inv(i+nres)*
5731      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5732 c
5733          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5734          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5735        enddo
5736
5737        do k=1,3
5738          dXX_Ctab(k,i)=dXX_Ci(k)
5739          dXX_C1tab(k,i)=dXX_Ci1(k)
5740          dYY_Ctab(k,i)=dYY_Ci(k)
5741          dYY_C1tab(k,i)=dYY_Ci1(k)
5742          dZZ_Ctab(k,i)=dZZ_Ci(k)
5743          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5744          dXX_XYZtab(k,i)=dXX_XYZ(k)
5745          dYY_XYZtab(k,i)=dYY_XYZ(k)
5746          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5747        enddo
5748
5749        do k = 1,3
5750 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5751 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5752 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5753 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5754 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5755 c     &    dt_dci(k)
5756 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5757 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5758          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5759      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5760          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5761      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5762          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5763      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5764        enddo
5765 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5766 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5767
5768 C to check gradient call subroutine check_grad
5769
5770     1 continue
5771       enddo
5772       return
5773       end
5774 c------------------------------------------------------------------------------
5775       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5776       implicit none
5777       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5778      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5779       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5780      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5781      &   + x(10)*yy*zz
5782       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5783      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5784      & + x(20)*yy*zz
5785       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5786      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5787      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5788      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5789      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5790      &  +x(40)*xx*yy*zz
5791       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5792      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5793      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5794      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5795      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5796      &  +x(60)*xx*yy*zz
5797       dsc_i   = 0.743d0+x(61)
5798       dp2_i   = 1.9d0+x(62)
5799       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5800      &          *(xx*cost2+yy*sint2))
5801       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5802      &          *(xx*cost2-yy*sint2))
5803       s1=(1+x(63))/(0.1d0 + dscp1)
5804       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5805       s2=(1+x(65))/(0.1d0 + dscp2)
5806       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5807       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5808      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5809       enesc=sumene
5810       return
5811       end
5812 #endif
5813 c------------------------------------------------------------------------------
5814       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5815 C
5816 C This procedure calculates two-body contact function g(rij) and its derivative:
5817 C
5818 C           eps0ij                                     !       x < -1
5819 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5820 C            0                                         !       x > 1
5821 C
5822 C where x=(rij-r0ij)/delta
5823 C
5824 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5825 C
5826       implicit none
5827       double precision rij,r0ij,eps0ij,fcont,fprimcont
5828       double precision x,x2,x4,delta
5829 c     delta=0.02D0*r0ij
5830 c      delta=0.2D0*r0ij
5831       x=(rij-r0ij)/delta
5832       if (x.lt.-1.0D0) then
5833         fcont=eps0ij
5834         fprimcont=0.0D0
5835       else if (x.le.1.0D0) then
5836         x2=x*x
5837         x4=x2*x2
5838         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5839         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5840       else
5841         fcont=0.0D0
5842         fprimcont=0.0D0
5843       endif
5844       return
5845       end
5846 c------------------------------------------------------------------------------
5847       subroutine splinthet(theti,delta,ss,ssder)
5848       implicit real*8 (a-h,o-z)
5849       include 'DIMENSIONS'
5850       include 'COMMON.VAR'
5851       include 'COMMON.GEO'
5852       thetup=pi-delta
5853       thetlow=delta
5854       if (theti.gt.pipol) then
5855         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5856       else
5857         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5858         ssder=-ssder
5859       endif
5860       return
5861       end
5862 c------------------------------------------------------------------------------
5863       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5864       implicit none
5865       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5866       double precision ksi,ksi2,ksi3,a1,a2,a3
5867       a1=fprim0*delta/(f1-f0)
5868       a2=3.0d0-2.0d0*a1
5869       a3=a1-2.0d0
5870       ksi=(x-x0)/delta
5871       ksi2=ksi*ksi
5872       ksi3=ksi2*ksi
5873       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5874       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5875       return
5876       end
5877 c------------------------------------------------------------------------------
5878       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5879       implicit none
5880       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5881       double precision ksi,ksi2,ksi3,a1,a2,a3
5882       ksi=(x-x0)/delta
5883       ksi2=ksi*ksi
5884       ksi3=ksi2*ksi
5885       a1=fprim0x*delta
5886       a2=3*(f1x-f0x)-2*fprim0x*delta
5887       a3=fprim0x*delta-2*(f1x-f0x)
5888       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5889       return
5890       end
5891 C-----------------------------------------------------------------------------
5892 #ifdef CRYST_TOR
5893 C-----------------------------------------------------------------------------
5894       subroutine etor(etors,edihcnstr)
5895       implicit real*8 (a-h,o-z)
5896       include 'DIMENSIONS'
5897       include 'COMMON.VAR'
5898       include 'COMMON.GEO'
5899       include 'COMMON.LOCAL'
5900       include 'COMMON.TORSION'
5901       include 'COMMON.INTERACT'
5902       include 'COMMON.DERIV'
5903       include 'COMMON.CHAIN'
5904       include 'COMMON.NAMES'
5905       include 'COMMON.IOUNITS'
5906       include 'COMMON.FFIELD'
5907       include 'COMMON.TORCNSTR'
5908       include 'COMMON.CONTROL'
5909       logical lprn
5910 C Set lprn=.true. for debugging
5911       lprn=.false.
5912 c      lprn=.true.
5913       etors=0.0D0
5914       do i=iphi_start,iphi_end
5915       etors_ii=0.0D0
5916         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5917      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5918         itori=itortyp(itype(i-2))
5919         itori1=itortyp(itype(i-1))
5920         phii=phi(i)
5921         gloci=0.0D0
5922 C Proline-Proline pair is a special case...
5923         if (itori.eq.3 .and. itori1.eq.3) then
5924           if (phii.gt.-dwapi3) then
5925             cosphi=dcos(3*phii)
5926             fac=1.0D0/(1.0D0-cosphi)
5927             etorsi=v1(1,3,3)*fac
5928             etorsi=etorsi+etorsi
5929             etors=etors+etorsi-v1(1,3,3)
5930             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5931             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5932           endif
5933           do j=1,3
5934             v1ij=v1(j+1,itori,itori1)
5935             v2ij=v2(j+1,itori,itori1)
5936             cosphi=dcos(j*phii)
5937             sinphi=dsin(j*phii)
5938             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5939             if (energy_dec) etors_ii=etors_ii+
5940      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5941             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5942           enddo
5943         else
5944           do j=1,nterm_old
5945             v1ij=v1(j,itori,itori1)
5946             v2ij=v2(j,itori,itori1)
5947             cosphi=dcos(j*phii)
5948             sinphi=dsin(j*phii)
5949             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5950             if (energy_dec) etors_ii=etors_ii+
5951      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5952             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5953           enddo
5954         endif
5955         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5956              'etor',i,etors_ii
5957         if (lprn)
5958      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5959      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5960      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5961         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5962 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5963       enddo
5964 ! 6/20/98 - dihedral angle constraints
5965       edihcnstr=0.0d0
5966       do i=1,ndih_constr
5967         itori=idih_constr(i)
5968         phii=phi(itori)
5969         difi=phii-phi0(i)
5970         if (difi.gt.drange(i)) then
5971           difi=difi-drange(i)
5972           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5973           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5974         else if (difi.lt.-drange(i)) then
5975           difi=difi+drange(i)
5976           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5977           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5978         endif
5979 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5980 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5981       enddo
5982 !      write (iout,*) 'edihcnstr',edihcnstr
5983       return
5984       end
5985 c------------------------------------------------------------------------------
5986       subroutine etor_d(etors_d)
5987       etors_d=0.0d0
5988       return
5989       end
5990 c----------------------------------------------------------------------------
5991 #else
5992       subroutine etor(etors,edihcnstr)
5993       implicit real*8 (a-h,o-z)
5994       include 'DIMENSIONS'
5995       include 'COMMON.VAR'
5996       include 'COMMON.GEO'
5997       include 'COMMON.LOCAL'
5998       include 'COMMON.TORSION'
5999       include 'COMMON.INTERACT'
6000       include 'COMMON.DERIV'
6001       include 'COMMON.CHAIN'
6002       include 'COMMON.NAMES'
6003       include 'COMMON.IOUNITS'
6004       include 'COMMON.FFIELD'
6005       include 'COMMON.TORCNSTR'
6006       include 'COMMON.CONTROL'
6007       logical lprn
6008 C Set lprn=.true. for debugging
6009       lprn=.false.
6010 c     lprn=.true.
6011       etors=0.0D0
6012       do i=iphi_start,iphi_end
6013 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6014 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6015 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6016 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6017         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6018      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6019 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6020 C For introducing the NH3+ and COO- group please check the etor_d for reference
6021 C and guidance
6022         etors_ii=0.0D0
6023          if (iabs(itype(i)).eq.20) then
6024          iblock=2
6025          else
6026          iblock=1
6027          endif
6028         itori=itortyp(itype(i-2))
6029         itori1=itortyp(itype(i-1))
6030         phii=phi(i)
6031         gloci=0.0D0
6032 C Regular cosine and sine terms
6033         do j=1,nterm(itori,itori1,iblock)
6034           v1ij=v1(j,itori,itori1,iblock)
6035           v2ij=v2(j,itori,itori1,iblock)
6036           cosphi=dcos(j*phii)
6037           sinphi=dsin(j*phii)
6038           etors=etors+v1ij*cosphi+v2ij*sinphi
6039           if (energy_dec) etors_ii=etors_ii+
6040      &                v1ij*cosphi+v2ij*sinphi
6041           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6042         enddo
6043 C Lorentz terms
6044 C                         v1
6045 C  E = SUM ----------------------------------- - v1
6046 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6047 C
6048         cosphi=dcos(0.5d0*phii)
6049         sinphi=dsin(0.5d0*phii)
6050         do j=1,nlor(itori,itori1,iblock)
6051           vl1ij=vlor1(j,itori,itori1)
6052           vl2ij=vlor2(j,itori,itori1)
6053           vl3ij=vlor3(j,itori,itori1)
6054           pom=vl2ij*cosphi+vl3ij*sinphi
6055           pom1=1.0d0/(pom*pom+1.0d0)
6056           etors=etors+vl1ij*pom1
6057           if (energy_dec) etors_ii=etors_ii+
6058      &                vl1ij*pom1
6059           pom=-pom*pom1*pom1
6060           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6061         enddo
6062 C Subtract the constant term
6063         etors=etors-v0(itori,itori1,iblock)
6064           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6065      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6066         if (lprn)
6067      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6068      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6069      &  (v1(j,itori,itori1,iblock),j=1,6),
6070      &  (v2(j,itori,itori1,iblock),j=1,6)
6071         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6072 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6073       enddo
6074 ! 6/20/98 - dihedral angle constraints
6075       edihcnstr=0.0d0
6076 c      do i=1,ndih_constr
6077       do i=idihconstr_start,idihconstr_end
6078         itori=idih_constr(i)
6079         phii=phi(itori)
6080         difi=pinorm(phii-phi0(i))
6081         if (difi.gt.drange(i)) then
6082           difi=difi-drange(i)
6083           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6084           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6085         else if (difi.lt.-drange(i)) then
6086           difi=difi+drange(i)
6087           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6088           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6089         else
6090           difi=0.0
6091         endif
6092 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6093 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6094 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6095       enddo
6096 cd       write (iout,*) 'edihcnstr',edihcnstr
6097       return
6098       end
6099 c----------------------------------------------------------------------------
6100       subroutine etor_d(etors_d)
6101 C 6/23/01 Compute double torsional energy
6102       implicit real*8 (a-h,o-z)
6103       include 'DIMENSIONS'
6104       include 'COMMON.VAR'
6105       include 'COMMON.GEO'
6106       include 'COMMON.LOCAL'
6107       include 'COMMON.TORSION'
6108       include 'COMMON.INTERACT'
6109       include 'COMMON.DERIV'
6110       include 'COMMON.CHAIN'
6111       include 'COMMON.NAMES'
6112       include 'COMMON.IOUNITS'
6113       include 'COMMON.FFIELD'
6114       include 'COMMON.TORCNSTR'
6115       logical lprn
6116 C Set lprn=.true. for debugging
6117       lprn=.false.
6118 c     lprn=.true.
6119       etors_d=0.0D0
6120 c      write(iout,*) "a tu??"
6121       do i=iphid_start,iphid_end
6122 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6123 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6124 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6125 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6126 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6127          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6128      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6129      &  (itype(i+1).eq.ntyp1)) cycle
6130 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6131         itori=itortyp(itype(i-2))
6132         itori1=itortyp(itype(i-1))
6133         itori2=itortyp(itype(i))
6134         phii=phi(i)
6135         phii1=phi(i+1)
6136         gloci1=0.0D0
6137         gloci2=0.0D0
6138         iblock=1
6139         if (iabs(itype(i+1)).eq.20) iblock=2
6140 C Iblock=2 Proline type
6141 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6142 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6143 C        if (itype(i+1).eq.ntyp1) iblock=3
6144 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6145 C IS or IS NOT need for this
6146 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6147 C        is (itype(i-3).eq.ntyp1) ntblock=2
6148 C        ntblock is N-terminal blocking group
6149
6150 C Regular cosine and sine terms
6151         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6152 C Example of changes for NH3+ blocking group
6153 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6154 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6155           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6156           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6157           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6158           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6159           cosphi1=dcos(j*phii)
6160           sinphi1=dsin(j*phii)
6161           cosphi2=dcos(j*phii1)
6162           sinphi2=dsin(j*phii1)
6163           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6164      &     v2cij*cosphi2+v2sij*sinphi2
6165           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6166           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6167         enddo
6168         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6169           do l=1,k-1
6170             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6171             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6172             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6173             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6174             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6175             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6176             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6177             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6178             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6179      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6180             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6181      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6182             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6183      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6184           enddo
6185         enddo
6186         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6187         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6188       enddo
6189       return
6190       end
6191 #endif
6192 c------------------------------------------------------------------------------
6193       subroutine eback_sc_corr(esccor)
6194 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6195 c        conformational states; temporarily implemented as differences
6196 c        between UNRES torsional potentials (dependent on three types of
6197 c        residues) and the torsional potentials dependent on all 20 types
6198 c        of residues computed from AM1  energy surfaces of terminally-blocked
6199 c        amino-acid residues.
6200       implicit real*8 (a-h,o-z)
6201       include 'DIMENSIONS'
6202       include 'COMMON.VAR'
6203       include 'COMMON.GEO'
6204       include 'COMMON.LOCAL'
6205       include 'COMMON.TORSION'
6206       include 'COMMON.SCCOR'
6207       include 'COMMON.INTERACT'
6208       include 'COMMON.DERIV'
6209       include 'COMMON.CHAIN'
6210       include 'COMMON.NAMES'
6211       include 'COMMON.IOUNITS'
6212       include 'COMMON.FFIELD'
6213       include 'COMMON.CONTROL'
6214       logical lprn
6215 C Set lprn=.true. for debugging
6216       lprn=.false.
6217 c      lprn=.true.
6218 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6219       esccor=0.0D0
6220       do i=itau_start,itau_end
6221         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6222         esccor_ii=0.0D0
6223         isccori=isccortyp(itype(i-2))
6224         isccori1=isccortyp(itype(i-1))
6225 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6226         phii=phi(i)
6227         do intertyp=1,3 !intertyp
6228 cc Added 09 May 2012 (Adasko)
6229 cc  Intertyp means interaction type of backbone mainchain correlation:
6230 c   1 = SC...Ca...Ca...Ca
6231 c   2 = Ca...Ca...Ca...SC
6232 c   3 = SC...Ca...Ca...SCi
6233         gloci=0.0D0
6234         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6235      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6236      &      (itype(i-1).eq.ntyp1)))
6237      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6238      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6239      &     .or.(itype(i).eq.ntyp1)))
6240      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6241      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6242      &      (itype(i-3).eq.ntyp1)))) cycle
6243         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6244         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6245      & cycle
6246        do j=1,nterm_sccor(isccori,isccori1)
6247           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6248           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6249           cosphi=dcos(j*tauangle(intertyp,i))
6250           sinphi=dsin(j*tauangle(intertyp,i))
6251           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6252           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6253         enddo
6254 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6255         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6256         if (lprn)
6257      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6258      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6259      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6260      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6261         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6262        enddo !intertyp
6263       enddo
6264
6265       return
6266       end
6267 c----------------------------------------------------------------------------
6268       subroutine multibody(ecorr)
6269 C This subroutine calculates multi-body contributions to energy following
6270 C the idea of Skolnick et al. If side chains I and J make a contact and
6271 C at the same time side chains I+1 and J+1 make a contact, an extra
6272 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6273       implicit real*8 (a-h,o-z)
6274       include 'DIMENSIONS'
6275       include 'COMMON.IOUNITS'
6276       include 'COMMON.DERIV'
6277       include 'COMMON.INTERACT'
6278       include 'COMMON.CONTACTS'
6279       double precision gx(3),gx1(3)
6280       logical lprn
6281
6282 C Set lprn=.true. for debugging
6283       lprn=.false.
6284
6285       if (lprn) then
6286         write (iout,'(a)') 'Contact function values:'
6287         do i=nnt,nct-2
6288           write (iout,'(i2,20(1x,i2,f10.5))')
6289      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6290         enddo
6291       endif
6292       ecorr=0.0D0
6293       do i=nnt,nct
6294         do j=1,3
6295           gradcorr(j,i)=0.0D0
6296           gradxorr(j,i)=0.0D0
6297         enddo
6298       enddo
6299       do i=nnt,nct-2
6300
6301         DO ISHIFT = 3,4
6302
6303         i1=i+ishift
6304         num_conti=num_cont(i)
6305         num_conti1=num_cont(i1)
6306         do jj=1,num_conti
6307           j=jcont(jj,i)
6308           do kk=1,num_conti1
6309             j1=jcont(kk,i1)
6310             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6311 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6312 cd   &                   ' ishift=',ishift
6313 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6314 C The system gains extra energy.
6315               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6316             endif   ! j1==j+-ishift
6317           enddo     ! kk
6318         enddo       ! jj
6319
6320         ENDDO ! ISHIFT
6321
6322       enddo         ! i
6323       return
6324       end
6325 c------------------------------------------------------------------------------
6326       double precision function esccorr(i,j,k,l,jj,kk)
6327       implicit real*8 (a-h,o-z)
6328       include 'DIMENSIONS'
6329       include 'COMMON.IOUNITS'
6330       include 'COMMON.DERIV'
6331       include 'COMMON.INTERACT'
6332       include 'COMMON.CONTACTS'
6333       double precision gx(3),gx1(3)
6334       logical lprn
6335       lprn=.false.
6336       eij=facont(jj,i)
6337       ekl=facont(kk,k)
6338 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6339 C Calculate the multi-body contribution to energy.
6340 C Calculate multi-body contributions to the gradient.
6341 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6342 cd   & k,l,(gacont(m,kk,k),m=1,3)
6343       do m=1,3
6344         gx(m) =ekl*gacont(m,jj,i)
6345         gx1(m)=eij*gacont(m,kk,k)
6346         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6347         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6348         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6349         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6350       enddo
6351       do m=i,j-1
6352         do ll=1,3
6353           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6354         enddo
6355       enddo
6356       do m=k,l-1
6357         do ll=1,3
6358           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6359         enddo
6360       enddo
6361       esccorr=-eij*ekl
6362       return
6363       end
6364 c------------------------------------------------------------------------------
6365       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6366 C This subroutine calculates multi-body contributions to hydrogen-bonding
6367       implicit real*8 (a-h,o-z)
6368       include 'DIMENSIONS'
6369       include 'COMMON.IOUNITS'
6370 #ifdef MPI
6371       include "mpif.h"
6372       parameter (max_cont=maxconts)
6373       parameter (max_dim=26)
6374       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6375       double precision zapas(max_dim,maxconts,max_fg_procs),
6376      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6377       common /przechowalnia/ zapas
6378       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6379      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6380 #endif
6381       include 'COMMON.SETUP'
6382       include 'COMMON.FFIELD'
6383       include 'COMMON.DERIV'
6384       include 'COMMON.INTERACT'
6385       include 'COMMON.CONTACTS'
6386       include 'COMMON.CONTROL'
6387       include 'COMMON.LOCAL'
6388       double precision gx(3),gx1(3),time00
6389       logical lprn,ldone
6390
6391 C Set lprn=.true. for debugging
6392       lprn=.false.
6393 #ifdef MPI
6394       n_corr=0
6395       n_corr1=0
6396       if (nfgtasks.le.1) goto 30
6397       if (lprn) then
6398         write (iout,'(a)') 'Contact function values before RECEIVE:'
6399         do i=nnt,nct-2
6400           write (iout,'(2i3,50(1x,i2,f5.2))')
6401      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6402      &    j=1,num_cont_hb(i))
6403         enddo
6404       endif
6405       call flush(iout)
6406       do i=1,ntask_cont_from
6407         ncont_recv(i)=0
6408       enddo
6409       do i=1,ntask_cont_to
6410         ncont_sent(i)=0
6411       enddo
6412 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6413 c     & ntask_cont_to
6414 C Make the list of contacts to send to send to other procesors
6415 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6416 c      call flush(iout)
6417       do i=iturn3_start,iturn3_end
6418 c        write (iout,*) "make contact list turn3",i," num_cont",
6419 c     &    num_cont_hb(i)
6420         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6421       enddo
6422       do i=iturn4_start,iturn4_end
6423 c        write (iout,*) "make contact list turn4",i," num_cont",
6424 c     &   num_cont_hb(i)
6425         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6426       enddo
6427       do ii=1,nat_sent
6428         i=iat_sent(ii)
6429 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6430 c     &    num_cont_hb(i)
6431         do j=1,num_cont_hb(i)
6432         do k=1,4
6433           jjc=jcont_hb(j,i)
6434           iproc=iint_sent_local(k,jjc,ii)
6435 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6436           if (iproc.gt.0) then
6437             ncont_sent(iproc)=ncont_sent(iproc)+1
6438             nn=ncont_sent(iproc)
6439             zapas(1,nn,iproc)=i
6440             zapas(2,nn,iproc)=jjc
6441             zapas(3,nn,iproc)=facont_hb(j,i)
6442             zapas(4,nn,iproc)=ees0p(j,i)
6443             zapas(5,nn,iproc)=ees0m(j,i)
6444             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6445             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6446             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6447             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6448             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6449             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6450             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6451             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6452             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6453             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6454             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6455             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6456             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6457             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6458             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6459             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6460             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6461             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6462             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6463             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6464             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6465           endif
6466         enddo
6467         enddo
6468       enddo
6469       if (lprn) then
6470       write (iout,*)
6471      &  "Numbers of contacts to be sent to other processors",
6472      &  (ncont_sent(i),i=1,ntask_cont_to)
6473       write (iout,*) "Contacts sent"
6474       do ii=1,ntask_cont_to
6475         nn=ncont_sent(ii)
6476         iproc=itask_cont_to(ii)
6477         write (iout,*) nn," contacts to processor",iproc,
6478      &   " of CONT_TO_COMM group"
6479         do i=1,nn
6480           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6481         enddo
6482       enddo
6483       call flush(iout)
6484       endif
6485       CorrelType=477
6486       CorrelID=fg_rank+1
6487       CorrelType1=478
6488       CorrelID1=nfgtasks+fg_rank+1
6489       ireq=0
6490 C Receive the numbers of needed contacts from other processors
6491       do ii=1,ntask_cont_from
6492         iproc=itask_cont_from(ii)
6493         ireq=ireq+1
6494         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6495      &    FG_COMM,req(ireq),IERR)
6496       enddo
6497 c      write (iout,*) "IRECV ended"
6498 c      call flush(iout)
6499 C Send the number of contacts needed by other processors
6500       do ii=1,ntask_cont_to
6501         iproc=itask_cont_to(ii)
6502         ireq=ireq+1
6503         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6504      &    FG_COMM,req(ireq),IERR)
6505       enddo
6506 c      write (iout,*) "ISEND ended"
6507 c      write (iout,*) "number of requests (nn)",ireq
6508       call flush(iout)
6509       if (ireq.gt.0)
6510      &  call MPI_Waitall(ireq,req,status_array,ierr)
6511 c      write (iout,*)
6512 c     &  "Numbers of contacts to be received from other processors",
6513 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6514 c      call flush(iout)
6515 C Receive contacts
6516       ireq=0
6517       do ii=1,ntask_cont_from
6518         iproc=itask_cont_from(ii)
6519         nn=ncont_recv(ii)
6520 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6521 c     &   " of CONT_TO_COMM group"
6522         call flush(iout)
6523         if (nn.gt.0) then
6524           ireq=ireq+1
6525           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6526      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6527 c          write (iout,*) "ireq,req",ireq,req(ireq)
6528         endif
6529       enddo
6530 C Send the contacts to processors that need them
6531       do ii=1,ntask_cont_to
6532         iproc=itask_cont_to(ii)
6533         nn=ncont_sent(ii)
6534 c        write (iout,*) nn," contacts to processor",iproc,
6535 c     &   " of CONT_TO_COMM group"
6536         if (nn.gt.0) then
6537           ireq=ireq+1
6538           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6539      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6540 c          write (iout,*) "ireq,req",ireq,req(ireq)
6541 c          do i=1,nn
6542 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6543 c          enddo
6544         endif
6545       enddo
6546 c      write (iout,*) "number of requests (contacts)",ireq
6547 c      write (iout,*) "req",(req(i),i=1,4)
6548 c      call flush(iout)
6549       if (ireq.gt.0)
6550      & call MPI_Waitall(ireq,req,status_array,ierr)
6551       do iii=1,ntask_cont_from
6552         iproc=itask_cont_from(iii)
6553         nn=ncont_recv(iii)
6554         if (lprn) then
6555         write (iout,*) "Received",nn," contacts from processor",iproc,
6556      &   " of CONT_FROM_COMM group"
6557         call flush(iout)
6558         do i=1,nn
6559           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6560         enddo
6561         call flush(iout)
6562         endif
6563         do i=1,nn
6564           ii=zapas_recv(1,i,iii)
6565 c Flag the received contacts to prevent double-counting
6566           jj=-zapas_recv(2,i,iii)
6567 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6568 c          call flush(iout)
6569           nnn=num_cont_hb(ii)+1
6570           num_cont_hb(ii)=nnn
6571           jcont_hb(nnn,ii)=jj
6572           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6573           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6574           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6575           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6576           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6577           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6578           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6579           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6580           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6581           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6582           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6583           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6584           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6585           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6586           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6587           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6588           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6589           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6590           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6591           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6592           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6593           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6594           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6595           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6596         enddo
6597       enddo
6598       call flush(iout)
6599       if (lprn) then
6600         write (iout,'(a)') 'Contact function values after receive:'
6601         do i=nnt,nct-2
6602           write (iout,'(2i3,50(1x,i3,f5.2))')
6603      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6604      &    j=1,num_cont_hb(i))
6605         enddo
6606         call flush(iout)
6607       endif
6608    30 continue
6609 #endif
6610       if (lprn) then
6611         write (iout,'(a)') 'Contact function values:'
6612         do i=nnt,nct-2
6613           write (iout,'(2i3,50(1x,i3,f5.2))')
6614      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6615      &    j=1,num_cont_hb(i))
6616         enddo
6617       endif
6618       ecorr=0.0D0
6619 C Remove the loop below after debugging !!!
6620       do i=nnt,nct
6621         do j=1,3
6622           gradcorr(j,i)=0.0D0
6623           gradxorr(j,i)=0.0D0
6624         enddo
6625       enddo
6626 C Calculate the local-electrostatic correlation terms
6627       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6628         i1=i+1
6629         num_conti=num_cont_hb(i)
6630         num_conti1=num_cont_hb(i+1)
6631         do jj=1,num_conti
6632           j=jcont_hb(jj,i)
6633           jp=iabs(j)
6634           do kk=1,num_conti1
6635             j1=jcont_hb(kk,i1)
6636             jp1=iabs(j1)
6637 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6638 c     &         ' jj=',jj,' kk=',kk
6639             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6640      &          .or. j.lt.0 .and. j1.gt.0) .and.
6641      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6642 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6643 C The system gains extra energy.
6644               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6645               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6646      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6647               n_corr=n_corr+1
6648             else if (j1.eq.j) then
6649 C Contacts I-J and I-(J+1) occur simultaneously.
6650 C The system loses extra energy.
6651 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6652             endif
6653           enddo ! kk
6654           do kk=1,num_conti
6655             j1=jcont_hb(kk,i)
6656 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6657 c    &         ' jj=',jj,' kk=',kk
6658             if (j1.eq.j+1) then
6659 C Contacts I-J and (I+1)-J occur simultaneously.
6660 C The system loses extra energy.
6661 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6662             endif ! j1==j+1
6663           enddo ! kk
6664         enddo ! jj
6665       enddo ! i
6666       return
6667       end
6668 c------------------------------------------------------------------------------
6669       subroutine add_hb_contact(ii,jj,itask)
6670       implicit real*8 (a-h,o-z)
6671       include "DIMENSIONS"
6672       include "COMMON.IOUNITS"
6673       integer max_cont
6674       integer max_dim
6675       parameter (max_cont=maxconts)
6676       parameter (max_dim=26)
6677       include "COMMON.CONTACTS"
6678       double precision zapas(max_dim,maxconts,max_fg_procs),
6679      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6680       common /przechowalnia/ zapas
6681       integer i,j,ii,jj,iproc,itask(4),nn
6682 c      write (iout,*) "itask",itask
6683       do i=1,2
6684         iproc=itask(i)
6685         if (iproc.gt.0) then
6686           do j=1,num_cont_hb(ii)
6687             jjc=jcont_hb(j,ii)
6688 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6689             if (jjc.eq.jj) then
6690               ncont_sent(iproc)=ncont_sent(iproc)+1
6691               nn=ncont_sent(iproc)
6692               zapas(1,nn,iproc)=ii
6693               zapas(2,nn,iproc)=jjc
6694               zapas(3,nn,iproc)=facont_hb(j,ii)
6695               zapas(4,nn,iproc)=ees0p(j,ii)
6696               zapas(5,nn,iproc)=ees0m(j,ii)
6697               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6698               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6699               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6700               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6701               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6702               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6703               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6704               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6705               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6706               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6707               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6708               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6709               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6710               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6711               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6712               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6713               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6714               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6715               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6716               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6717               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6718               exit
6719             endif
6720           enddo
6721         endif
6722       enddo
6723       return
6724       end
6725 c------------------------------------------------------------------------------
6726       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6727      &  n_corr1)
6728 C This subroutine calculates multi-body contributions to hydrogen-bonding
6729       implicit real*8 (a-h,o-z)
6730       include 'DIMENSIONS'
6731       include 'COMMON.IOUNITS'
6732 #ifdef MPI
6733       include "mpif.h"
6734       parameter (max_cont=maxconts)
6735       parameter (max_dim=70)
6736       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6737       double precision zapas(max_dim,maxconts,max_fg_procs),
6738      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6739       common /przechowalnia/ zapas
6740       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6741      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6742 #endif
6743       include 'COMMON.SETUP'
6744       include 'COMMON.FFIELD'
6745       include 'COMMON.DERIV'
6746       include 'COMMON.LOCAL'
6747       include 'COMMON.INTERACT'
6748       include 'COMMON.CONTACTS'
6749       include 'COMMON.CHAIN'
6750       include 'COMMON.CONTROL'
6751       double precision gx(3),gx1(3)
6752       integer num_cont_hb_old(maxres)
6753       logical lprn,ldone
6754       double precision eello4,eello5,eelo6,eello_turn6
6755       external eello4,eello5,eello6,eello_turn6
6756 C Set lprn=.true. for debugging
6757       lprn=.false.
6758       eturn6=0.0d0
6759 #ifdef MPI
6760       do i=1,nres
6761         num_cont_hb_old(i)=num_cont_hb(i)
6762       enddo
6763       n_corr=0
6764       n_corr1=0
6765       if (nfgtasks.le.1) goto 30
6766       if (lprn) then
6767         write (iout,'(a)') 'Contact function values before RECEIVE:'
6768         do i=nnt,nct-2
6769           write (iout,'(2i3,50(1x,i2,f5.2))')
6770      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6771      &    j=1,num_cont_hb(i))
6772         enddo
6773       endif
6774       call flush(iout)
6775       do i=1,ntask_cont_from
6776         ncont_recv(i)=0
6777       enddo
6778       do i=1,ntask_cont_to
6779         ncont_sent(i)=0
6780       enddo
6781 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6782 c     & ntask_cont_to
6783 C Make the list of contacts to send to send to other procesors
6784       do i=iturn3_start,iturn3_end
6785 c        write (iout,*) "make contact list turn3",i," num_cont",
6786 c     &    num_cont_hb(i)
6787         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6788       enddo
6789       do i=iturn4_start,iturn4_end
6790 c        write (iout,*) "make contact list turn4",i," num_cont",
6791 c     &   num_cont_hb(i)
6792         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6793       enddo
6794       do ii=1,nat_sent
6795         i=iat_sent(ii)
6796 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6797 c     &    num_cont_hb(i)
6798         do j=1,num_cont_hb(i)
6799         do k=1,4
6800           jjc=jcont_hb(j,i)
6801           iproc=iint_sent_local(k,jjc,ii)
6802 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6803           if (iproc.ne.0) then
6804             ncont_sent(iproc)=ncont_sent(iproc)+1
6805             nn=ncont_sent(iproc)
6806             zapas(1,nn,iproc)=i
6807             zapas(2,nn,iproc)=jjc
6808             zapas(3,nn,iproc)=d_cont(j,i)
6809             ind=3
6810             do kk=1,3
6811               ind=ind+1
6812               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6813             enddo
6814             do kk=1,2
6815               do ll=1,2
6816                 ind=ind+1
6817                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6818               enddo
6819             enddo
6820             do jj=1,5
6821               do kk=1,3
6822                 do ll=1,2
6823                   do mm=1,2
6824                     ind=ind+1
6825                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6826                   enddo
6827                 enddo
6828               enddo
6829             enddo
6830           endif
6831         enddo
6832         enddo
6833       enddo
6834       if (lprn) then
6835       write (iout,*)
6836      &  "Numbers of contacts to be sent to other processors",
6837      &  (ncont_sent(i),i=1,ntask_cont_to)
6838       write (iout,*) "Contacts sent"
6839       do ii=1,ntask_cont_to
6840         nn=ncont_sent(ii)
6841         iproc=itask_cont_to(ii)
6842         write (iout,*) nn," contacts to processor",iproc,
6843      &   " of CONT_TO_COMM group"
6844         do i=1,nn
6845           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6846         enddo
6847       enddo
6848       call flush(iout)
6849       endif
6850       CorrelType=477
6851       CorrelID=fg_rank+1
6852       CorrelType1=478
6853       CorrelID1=nfgtasks+fg_rank+1
6854       ireq=0
6855 C Receive the numbers of needed contacts from other processors
6856       do ii=1,ntask_cont_from
6857         iproc=itask_cont_from(ii)
6858         ireq=ireq+1
6859         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6860      &    FG_COMM,req(ireq),IERR)
6861       enddo
6862 c      write (iout,*) "IRECV ended"
6863 c      call flush(iout)
6864 C Send the number of contacts needed by other processors
6865       do ii=1,ntask_cont_to
6866         iproc=itask_cont_to(ii)
6867         ireq=ireq+1
6868         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6869      &    FG_COMM,req(ireq),IERR)
6870       enddo
6871 c      write (iout,*) "ISEND ended"
6872 c      write (iout,*) "number of requests (nn)",ireq
6873       call flush(iout)
6874       if (ireq.gt.0)
6875      &  call MPI_Waitall(ireq,req,status_array,ierr)
6876 c      write (iout,*)
6877 c     &  "Numbers of contacts to be received from other processors",
6878 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6879 c      call flush(iout)
6880 C Receive contacts
6881       ireq=0
6882       do ii=1,ntask_cont_from
6883         iproc=itask_cont_from(ii)
6884         nn=ncont_recv(ii)
6885 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6886 c     &   " of CONT_TO_COMM group"
6887         call flush(iout)
6888         if (nn.gt.0) then
6889           ireq=ireq+1
6890           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6891      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6892 c          write (iout,*) "ireq,req",ireq,req(ireq)
6893         endif
6894       enddo
6895 C Send the contacts to processors that need them
6896       do ii=1,ntask_cont_to
6897         iproc=itask_cont_to(ii)
6898         nn=ncont_sent(ii)
6899 c        write (iout,*) nn," contacts to processor",iproc,
6900 c     &   " of CONT_TO_COMM group"
6901         if (nn.gt.0) then
6902           ireq=ireq+1
6903           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6904      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6905 c          write (iout,*) "ireq,req",ireq,req(ireq)
6906 c          do i=1,nn
6907 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6908 c          enddo
6909         endif
6910       enddo
6911 c      write (iout,*) "number of requests (contacts)",ireq
6912 c      write (iout,*) "req",(req(i),i=1,4)
6913 c      call flush(iout)
6914       if (ireq.gt.0)
6915      & call MPI_Waitall(ireq,req,status_array,ierr)
6916       do iii=1,ntask_cont_from
6917         iproc=itask_cont_from(iii)
6918         nn=ncont_recv(iii)
6919         if (lprn) then
6920         write (iout,*) "Received",nn," contacts from processor",iproc,
6921      &   " of CONT_FROM_COMM group"
6922         call flush(iout)
6923         do i=1,nn
6924           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6925         enddo
6926         call flush(iout)
6927         endif
6928         do i=1,nn
6929           ii=zapas_recv(1,i,iii)
6930 c Flag the received contacts to prevent double-counting
6931           jj=-zapas_recv(2,i,iii)
6932 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6933 c          call flush(iout)
6934           nnn=num_cont_hb(ii)+1
6935           num_cont_hb(ii)=nnn
6936           jcont_hb(nnn,ii)=jj
6937           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6938           ind=3
6939           do kk=1,3
6940             ind=ind+1
6941             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6942           enddo
6943           do kk=1,2
6944             do ll=1,2
6945               ind=ind+1
6946               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6947             enddo
6948           enddo
6949           do jj=1,5
6950             do kk=1,3
6951               do ll=1,2
6952                 do mm=1,2
6953                   ind=ind+1
6954                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6955                 enddo
6956               enddo
6957             enddo
6958           enddo
6959         enddo
6960       enddo
6961       call flush(iout)
6962       if (lprn) then
6963         write (iout,'(a)') 'Contact function values after receive:'
6964         do i=nnt,nct-2
6965           write (iout,'(2i3,50(1x,i3,5f6.3))')
6966      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6967      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6968         enddo
6969         call flush(iout)
6970       endif
6971    30 continue
6972 #endif
6973       if (lprn) then
6974         write (iout,'(a)') 'Contact function values:'
6975         do i=nnt,nct-2
6976           write (iout,'(2i3,50(1x,i2,5f6.3))')
6977      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6978      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6979         enddo
6980       endif
6981       ecorr=0.0D0
6982       ecorr5=0.0d0
6983       ecorr6=0.0d0
6984 C Remove the loop below after debugging !!!
6985       do i=nnt,nct
6986         do j=1,3
6987           gradcorr(j,i)=0.0D0
6988           gradxorr(j,i)=0.0D0
6989         enddo
6990       enddo
6991 C Calculate the dipole-dipole interaction energies
6992       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6993       do i=iatel_s,iatel_e+1
6994         num_conti=num_cont_hb(i)
6995         do jj=1,num_conti
6996           j=jcont_hb(jj,i)
6997 #ifdef MOMENT
6998           call dipole(i,j,jj)
6999 #endif
7000         enddo
7001       enddo
7002       endif
7003 C Calculate the local-electrostatic correlation terms
7004 c                write (iout,*) "gradcorr5 in eello5 before loop"
7005 c                do iii=1,nres
7006 c                  write (iout,'(i5,3f10.5)')
7007 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7008 c                enddo
7009       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7010 c        write (iout,*) "corr loop i",i
7011         i1=i+1
7012         num_conti=num_cont_hb(i)
7013         num_conti1=num_cont_hb(i+1)
7014         do jj=1,num_conti
7015           j=jcont_hb(jj,i)
7016           jp=iabs(j)
7017           do kk=1,num_conti1
7018             j1=jcont_hb(kk,i1)
7019             jp1=iabs(j1)
7020 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7021 c     &         ' jj=',jj,' kk=',kk
7022 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7023             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7024      &          .or. j.lt.0 .and. j1.gt.0) .and.
7025      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7026 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7027 C The system gains extra energy.
7028               n_corr=n_corr+1
7029               sqd1=dsqrt(d_cont(jj,i))
7030               sqd2=dsqrt(d_cont(kk,i1))
7031               sred_geom = sqd1*sqd2
7032               IF (sred_geom.lt.cutoff_corr) THEN
7033                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7034      &            ekont,fprimcont)
7035 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7036 cd     &         ' jj=',jj,' kk=',kk
7037                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7038                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7039                 do l=1,3
7040                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7041                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7042                 enddo
7043                 n_corr1=n_corr1+1
7044 cd               write (iout,*) 'sred_geom=',sred_geom,
7045 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7046 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7047 cd               write (iout,*) "g_contij",g_contij
7048 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7049 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7050                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7051                 if (wcorr4.gt.0.0d0)
7052      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7053                   if (energy_dec.and.wcorr4.gt.0.0d0)
7054      1                 write (iout,'(a6,4i5,0pf7.3)')
7055      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7056 c                write (iout,*) "gradcorr5 before eello5"
7057 c                do iii=1,nres
7058 c                  write (iout,'(i5,3f10.5)')
7059 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7060 c                enddo
7061                 if (wcorr5.gt.0.0d0)
7062      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7063 c                write (iout,*) "gradcorr5 after eello5"
7064 c                do iii=1,nres
7065 c                  write (iout,'(i5,3f10.5)')
7066 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7067 c                enddo
7068                   if (energy_dec.and.wcorr5.gt.0.0d0)
7069      1                 write (iout,'(a6,4i5,0pf7.3)')
7070      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7071 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7072 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7073                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7074      &               .or. wturn6.eq.0.0d0))then
7075 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7076                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7077                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7078      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7079 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7080 cd     &            'ecorr6=',ecorr6
7081 cd                write (iout,'(4e15.5)') sred_geom,
7082 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7083 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7084 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7085                 else if (wturn6.gt.0.0d0
7086      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7087 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7088                   eturn6=eturn6+eello_turn6(i,jj,kk)
7089                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7090      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7091 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7092                 endif
7093               ENDIF
7094 1111          continue
7095             endif
7096           enddo ! kk
7097         enddo ! jj
7098       enddo ! i
7099       do i=1,nres
7100         num_cont_hb(i)=num_cont_hb_old(i)
7101       enddo
7102 c                write (iout,*) "gradcorr5 in eello5"
7103 c                do iii=1,nres
7104 c                  write (iout,'(i5,3f10.5)')
7105 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7106 c                enddo
7107       return
7108       end
7109 c------------------------------------------------------------------------------
7110       subroutine add_hb_contact_eello(ii,jj,itask)
7111       implicit real*8 (a-h,o-z)
7112       include "DIMENSIONS"
7113       include "COMMON.IOUNITS"
7114       integer max_cont
7115       integer max_dim
7116       parameter (max_cont=maxconts)
7117       parameter (max_dim=70)
7118       include "COMMON.CONTACTS"
7119       double precision zapas(max_dim,maxconts,max_fg_procs),
7120      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7121       common /przechowalnia/ zapas
7122       integer i,j,ii,jj,iproc,itask(4),nn
7123 c      write (iout,*) "itask",itask
7124       do i=1,2
7125         iproc=itask(i)
7126         if (iproc.gt.0) then
7127           do j=1,num_cont_hb(ii)
7128             jjc=jcont_hb(j,ii)
7129 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7130             if (jjc.eq.jj) then
7131               ncont_sent(iproc)=ncont_sent(iproc)+1
7132               nn=ncont_sent(iproc)
7133               zapas(1,nn,iproc)=ii
7134               zapas(2,nn,iproc)=jjc
7135               zapas(3,nn,iproc)=d_cont(j,ii)
7136               ind=3
7137               do kk=1,3
7138                 ind=ind+1
7139                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7140               enddo
7141               do kk=1,2
7142                 do ll=1,2
7143                   ind=ind+1
7144                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7145                 enddo
7146               enddo
7147               do jj=1,5
7148                 do kk=1,3
7149                   do ll=1,2
7150                     do mm=1,2
7151                       ind=ind+1
7152                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7153                     enddo
7154                   enddo
7155                 enddo
7156               enddo
7157               exit
7158             endif
7159           enddo
7160         endif
7161       enddo
7162       return
7163       end
7164 c------------------------------------------------------------------------------
7165       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7166       implicit real*8 (a-h,o-z)
7167       include 'DIMENSIONS'
7168       include 'COMMON.IOUNITS'
7169       include 'COMMON.DERIV'
7170       include 'COMMON.INTERACT'
7171       include 'COMMON.CONTACTS'
7172       double precision gx(3),gx1(3)
7173       logical lprn
7174       lprn=.false.
7175       eij=facont_hb(jj,i)
7176       ekl=facont_hb(kk,k)
7177       ees0pij=ees0p(jj,i)
7178       ees0pkl=ees0p(kk,k)
7179       ees0mij=ees0m(jj,i)
7180       ees0mkl=ees0m(kk,k)
7181       ekont=eij*ekl
7182       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7183 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7184 C Following 4 lines for diagnostics.
7185 cd    ees0pkl=0.0D0
7186 cd    ees0pij=1.0D0
7187 cd    ees0mkl=0.0D0
7188 cd    ees0mij=1.0D0
7189 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7190 c     & 'Contacts ',i,j,
7191 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7192 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7193 c     & 'gradcorr_long'
7194 C Calculate the multi-body contribution to energy.
7195 c      ecorr=ecorr+ekont*ees
7196 C Calculate multi-body contributions to the gradient.
7197       coeffpees0pij=coeffp*ees0pij
7198       coeffmees0mij=coeffm*ees0mij
7199       coeffpees0pkl=coeffp*ees0pkl
7200       coeffmees0mkl=coeffm*ees0mkl
7201       do ll=1,3
7202 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7203         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7204      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7205      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7206         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7207      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7208      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7209 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7210         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7211      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7212      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7213         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7214      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7215      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7216         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7217      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7218      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7219         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7220         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7221         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7222      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7223      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7224         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7225         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7226 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7227       enddo
7228 c      write (iout,*)
7229 cgrad      do m=i+1,j-1
7230 cgrad        do ll=1,3
7231 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7232 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7233 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7234 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7235 cgrad        enddo
7236 cgrad      enddo
7237 cgrad      do m=k+1,l-1
7238 cgrad        do ll=1,3
7239 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7240 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7241 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7242 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7243 cgrad        enddo
7244 cgrad      enddo
7245 c      write (iout,*) "ehbcorr",ekont*ees
7246       ehbcorr=ekont*ees
7247       return
7248       end
7249 #ifdef MOMENT
7250 C---------------------------------------------------------------------------
7251       subroutine dipole(i,j,jj)
7252       implicit real*8 (a-h,o-z)
7253       include 'DIMENSIONS'
7254       include 'COMMON.IOUNITS'
7255       include 'COMMON.CHAIN'
7256       include 'COMMON.FFIELD'
7257       include 'COMMON.DERIV'
7258       include 'COMMON.INTERACT'
7259       include 'COMMON.CONTACTS'
7260       include 'COMMON.TORSION'
7261       include 'COMMON.VAR'
7262       include 'COMMON.GEO'
7263       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7264      &  auxmat(2,2)
7265       iti1 = itortyp(itype(i+1))
7266       if (j.lt.nres-1) then
7267         itj1 = itortyp(itype(j+1))
7268       else
7269         itj1=ntortyp
7270       endif
7271       do iii=1,2
7272         dipi(iii,1)=Ub2(iii,i)
7273         dipderi(iii)=Ub2der(iii,i)
7274         dipi(iii,2)=b1(iii,iti1)
7275         dipj(iii,1)=Ub2(iii,j)
7276         dipderj(iii)=Ub2der(iii,j)
7277         dipj(iii,2)=b1(iii,itj1)
7278       enddo
7279       kkk=0
7280       do iii=1,2
7281         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7282         do jjj=1,2
7283           kkk=kkk+1
7284           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7285         enddo
7286       enddo
7287       do kkk=1,5
7288         do lll=1,3
7289           mmm=0
7290           do iii=1,2
7291             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7292      &        auxvec(1))
7293             do jjj=1,2
7294               mmm=mmm+1
7295               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7296             enddo
7297           enddo
7298         enddo
7299       enddo
7300       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7301       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7302       do iii=1,2
7303         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7304       enddo
7305       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7306       do iii=1,2
7307         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7308       enddo
7309       return
7310       end
7311 #endif
7312 C---------------------------------------------------------------------------
7313       subroutine calc_eello(i,j,k,l,jj,kk)
7314 C
7315 C This subroutine computes matrices and vectors needed to calculate
7316 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7317 C
7318       implicit real*8 (a-h,o-z)
7319       include 'DIMENSIONS'
7320       include 'COMMON.IOUNITS'
7321       include 'COMMON.CHAIN'
7322       include 'COMMON.DERIV'
7323       include 'COMMON.INTERACT'
7324       include 'COMMON.CONTACTS'
7325       include 'COMMON.TORSION'
7326       include 'COMMON.VAR'
7327       include 'COMMON.GEO'
7328       include 'COMMON.FFIELD'
7329       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7330      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7331       logical lprn
7332       common /kutas/ lprn
7333 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7334 cd     & ' jj=',jj,' kk=',kk
7335 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7336 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7337 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7338       do iii=1,2
7339         do jjj=1,2
7340           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7341           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7342         enddo
7343       enddo
7344       call transpose2(aa1(1,1),aa1t(1,1))
7345       call transpose2(aa2(1,1),aa2t(1,1))
7346       do kkk=1,5
7347         do lll=1,3
7348           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7349      &      aa1tder(1,1,lll,kkk))
7350           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7351      &      aa2tder(1,1,lll,kkk))
7352         enddo
7353       enddo
7354       if (l.eq.j+1) then
7355 C parallel orientation of the two CA-CA-CA frames.
7356         if (i.gt.1) then
7357           iti=itortyp(itype(i))
7358         else
7359           iti=ntortyp
7360         endif
7361         itk1=itortyp(itype(k+1))
7362         itj=itortyp(itype(j))
7363         if (l.lt.nres-1) then
7364           itl1=itortyp(itype(l+1))
7365         else
7366           itl1=ntortyp
7367         endif
7368 C A1 kernel(j+1) A2T
7369 cd        do iii=1,2
7370 cd          write (iout,'(3f10.5,5x,3f10.5)')
7371 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7372 cd        enddo
7373         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7374      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7375      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7376 C Following matrices are needed only for 6-th order cumulants
7377         IF (wcorr6.gt.0.0d0) THEN
7378         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7379      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7380      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7381         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7382      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7383      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7384      &   ADtEAderx(1,1,1,1,1,1))
7385         lprn=.false.
7386         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7387      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7388      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7389      &   ADtEA1derx(1,1,1,1,1,1))
7390         ENDIF
7391 C End 6-th order cumulants
7392 cd        lprn=.false.
7393 cd        if (lprn) then
7394 cd        write (2,*) 'In calc_eello6'
7395 cd        do iii=1,2
7396 cd          write (2,*) 'iii=',iii
7397 cd          do kkk=1,5
7398 cd            write (2,*) 'kkk=',kkk
7399 cd            do jjj=1,2
7400 cd              write (2,'(3(2f10.5),5x)')
7401 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7402 cd            enddo
7403 cd          enddo
7404 cd        enddo
7405 cd        endif
7406         call transpose2(EUgder(1,1,k),auxmat(1,1))
7407         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7408         call transpose2(EUg(1,1,k),auxmat(1,1))
7409         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7410         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7411         do iii=1,2
7412           do kkk=1,5
7413             do lll=1,3
7414               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7415      &          EAEAderx(1,1,lll,kkk,iii,1))
7416             enddo
7417           enddo
7418         enddo
7419 C A1T kernel(i+1) A2
7420         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7421      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7422      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7423 C Following matrices are needed only for 6-th order cumulants
7424         IF (wcorr6.gt.0.0d0) THEN
7425         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7426      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7427      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7428         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7429      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7430      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7431      &   ADtEAderx(1,1,1,1,1,2))
7432         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7433      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7434      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7435      &   ADtEA1derx(1,1,1,1,1,2))
7436         ENDIF
7437 C End 6-th order cumulants
7438         call transpose2(EUgder(1,1,l),auxmat(1,1))
7439         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7440         call transpose2(EUg(1,1,l),auxmat(1,1))
7441         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7442         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7443         do iii=1,2
7444           do kkk=1,5
7445             do lll=1,3
7446               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7447      &          EAEAderx(1,1,lll,kkk,iii,2))
7448             enddo
7449           enddo
7450         enddo
7451 C AEAb1 and AEAb2
7452 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7453 C They are needed only when the fifth- or the sixth-order cumulants are
7454 C indluded.
7455         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7456         call transpose2(AEA(1,1,1),auxmat(1,1))
7457         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7458         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7459         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7460         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7461         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7462         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7463         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7464         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7465         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7466         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7467         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7468         call transpose2(AEA(1,1,2),auxmat(1,1))
7469         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7470         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7471         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7472         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7473         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7474         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7475         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7476         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7477         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7478         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7479         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7480 C Calculate the Cartesian derivatives of the vectors.
7481         do iii=1,2
7482           do kkk=1,5
7483             do lll=1,3
7484               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7485               call matvec2(auxmat(1,1),b1(1,iti),
7486      &          AEAb1derx(1,lll,kkk,iii,1,1))
7487               call matvec2(auxmat(1,1),Ub2(1,i),
7488      &          AEAb2derx(1,lll,kkk,iii,1,1))
7489               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7490      &          AEAb1derx(1,lll,kkk,iii,2,1))
7491               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7492      &          AEAb2derx(1,lll,kkk,iii,2,1))
7493               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7494               call matvec2(auxmat(1,1),b1(1,itj),
7495      &          AEAb1derx(1,lll,kkk,iii,1,2))
7496               call matvec2(auxmat(1,1),Ub2(1,j),
7497      &          AEAb2derx(1,lll,kkk,iii,1,2))
7498               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7499      &          AEAb1derx(1,lll,kkk,iii,2,2))
7500               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7501      &          AEAb2derx(1,lll,kkk,iii,2,2))
7502             enddo
7503           enddo
7504         enddo
7505         ENDIF
7506 C End vectors
7507       else
7508 C Antiparallel orientation of the two CA-CA-CA frames.
7509         if (i.gt.1) then
7510           iti=itortyp(itype(i))
7511         else
7512           iti=ntortyp
7513         endif
7514         itk1=itortyp(itype(k+1))
7515         itl=itortyp(itype(l))
7516         itj=itortyp(itype(j))
7517         if (j.lt.nres-1) then
7518           itj1=itortyp(itype(j+1))
7519         else
7520           itj1=ntortyp
7521         endif
7522 C A2 kernel(j-1)T A1T
7523         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7524      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7525      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7526 C Following matrices are needed only for 6-th order cumulants
7527         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7528      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7529         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7530      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7531      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7532         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7533      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7534      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7535      &   ADtEAderx(1,1,1,1,1,1))
7536         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7537      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7538      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7539      &   ADtEA1derx(1,1,1,1,1,1))
7540         ENDIF
7541 C End 6-th order cumulants
7542         call transpose2(EUgder(1,1,k),auxmat(1,1))
7543         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7544         call transpose2(EUg(1,1,k),auxmat(1,1))
7545         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7546         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7547         do iii=1,2
7548           do kkk=1,5
7549             do lll=1,3
7550               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7551      &          EAEAderx(1,1,lll,kkk,iii,1))
7552             enddo
7553           enddo
7554         enddo
7555 C A2T kernel(i+1)T A1
7556         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7557      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7558      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7559 C Following matrices are needed only for 6-th order cumulants
7560         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7561      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7562         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7563      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7564      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7565         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7566      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7567      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7568      &   ADtEAderx(1,1,1,1,1,2))
7569         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7570      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7571      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7572      &   ADtEA1derx(1,1,1,1,1,2))
7573         ENDIF
7574 C End 6-th order cumulants
7575         call transpose2(EUgder(1,1,j),auxmat(1,1))
7576         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7577         call transpose2(EUg(1,1,j),auxmat(1,1))
7578         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7579         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7580         do iii=1,2
7581           do kkk=1,5
7582             do lll=1,3
7583               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7584      &          EAEAderx(1,1,lll,kkk,iii,2))
7585             enddo
7586           enddo
7587         enddo
7588 C AEAb1 and AEAb2
7589 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7590 C They are needed only when the fifth- or the sixth-order cumulants are
7591 C indluded.
7592         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7593      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7594         call transpose2(AEA(1,1,1),auxmat(1,1))
7595         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7596         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7597         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7598         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7599         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7600         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7601         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7602         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7603         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7604         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7605         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7606         call transpose2(AEA(1,1,2),auxmat(1,1))
7607         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7608         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7609         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7610         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7611         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7612         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7613         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7614         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7615         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7616         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7617         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7618 C Calculate the Cartesian derivatives of the vectors.
7619         do iii=1,2
7620           do kkk=1,5
7621             do lll=1,3
7622               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7623               call matvec2(auxmat(1,1),b1(1,iti),
7624      &          AEAb1derx(1,lll,kkk,iii,1,1))
7625               call matvec2(auxmat(1,1),Ub2(1,i),
7626      &          AEAb2derx(1,lll,kkk,iii,1,1))
7627               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7628      &          AEAb1derx(1,lll,kkk,iii,2,1))
7629               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7630      &          AEAb2derx(1,lll,kkk,iii,2,1))
7631               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7632               call matvec2(auxmat(1,1),b1(1,itl),
7633      &          AEAb1derx(1,lll,kkk,iii,1,2))
7634               call matvec2(auxmat(1,1),Ub2(1,l),
7635      &          AEAb2derx(1,lll,kkk,iii,1,2))
7636               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7637      &          AEAb1derx(1,lll,kkk,iii,2,2))
7638               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7639      &          AEAb2derx(1,lll,kkk,iii,2,2))
7640             enddo
7641           enddo
7642         enddo
7643         ENDIF
7644 C End vectors
7645       endif
7646       return
7647       end
7648 C---------------------------------------------------------------------------
7649       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7650      &  KK,KKderg,AKA,AKAderg,AKAderx)
7651       implicit none
7652       integer nderg
7653       logical transp
7654       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7655      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7656      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7657       integer iii,kkk,lll
7658       integer jjj,mmm
7659       logical lprn
7660       common /kutas/ lprn
7661       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7662       do iii=1,nderg
7663         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7664      &    AKAderg(1,1,iii))
7665       enddo
7666 cd      if (lprn) write (2,*) 'In kernel'
7667       do kkk=1,5
7668 cd        if (lprn) write (2,*) 'kkk=',kkk
7669         do lll=1,3
7670           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7671      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7672 cd          if (lprn) then
7673 cd            write (2,*) 'lll=',lll
7674 cd            write (2,*) 'iii=1'
7675 cd            do jjj=1,2
7676 cd              write (2,'(3(2f10.5),5x)')
7677 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7678 cd            enddo
7679 cd          endif
7680           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7681      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7682 cd          if (lprn) then
7683 cd            write (2,*) 'lll=',lll
7684 cd            write (2,*) 'iii=2'
7685 cd            do jjj=1,2
7686 cd              write (2,'(3(2f10.5),5x)')
7687 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7688 cd            enddo
7689 cd          endif
7690         enddo
7691       enddo
7692       return
7693       end
7694 C---------------------------------------------------------------------------
7695       double precision function eello4(i,j,k,l,jj,kk)
7696       implicit real*8 (a-h,o-z)
7697       include 'DIMENSIONS'
7698       include 'COMMON.IOUNITS'
7699       include 'COMMON.CHAIN'
7700       include 'COMMON.DERIV'
7701       include 'COMMON.INTERACT'
7702       include 'COMMON.CONTACTS'
7703       include 'COMMON.TORSION'
7704       include 'COMMON.VAR'
7705       include 'COMMON.GEO'
7706       double precision pizda(2,2),ggg1(3),ggg2(3)
7707 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7708 cd        eello4=0.0d0
7709 cd        return
7710 cd      endif
7711 cd      print *,'eello4:',i,j,k,l,jj,kk
7712 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7713 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7714 cold      eij=facont_hb(jj,i)
7715 cold      ekl=facont_hb(kk,k)
7716 cold      ekont=eij*ekl
7717       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7718 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7719       gcorr_loc(k-1)=gcorr_loc(k-1)
7720      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7721       if (l.eq.j+1) then
7722         gcorr_loc(l-1)=gcorr_loc(l-1)
7723      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7724       else
7725         gcorr_loc(j-1)=gcorr_loc(j-1)
7726      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7727       endif
7728       do iii=1,2
7729         do kkk=1,5
7730           do lll=1,3
7731             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7732      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7733 cd            derx(lll,kkk,iii)=0.0d0
7734           enddo
7735         enddo
7736       enddo
7737 cd      gcorr_loc(l-1)=0.0d0
7738 cd      gcorr_loc(j-1)=0.0d0
7739 cd      gcorr_loc(k-1)=0.0d0
7740 cd      eel4=1.0d0
7741 cd      write (iout,*)'Contacts have occurred for peptide groups',
7742 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7743 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7744       if (j.lt.nres-1) then
7745         j1=j+1
7746         j2=j-1
7747       else
7748         j1=j-1
7749         j2=j-2
7750       endif
7751       if (l.lt.nres-1) then
7752         l1=l+1
7753         l2=l-1
7754       else
7755         l1=l-1
7756         l2=l-2
7757       endif
7758       do ll=1,3
7759 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7760 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7761         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7762         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7763 cgrad        ghalf=0.5d0*ggg1(ll)
7764         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7765         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7766         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7767         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7768         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7769         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7770 cgrad        ghalf=0.5d0*ggg2(ll)
7771         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7772         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7773         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7774         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7775         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7776         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7777       enddo
7778 cgrad      do m=i+1,j-1
7779 cgrad        do ll=1,3
7780 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7781 cgrad        enddo
7782 cgrad      enddo
7783 cgrad      do m=k+1,l-1
7784 cgrad        do ll=1,3
7785 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7786 cgrad        enddo
7787 cgrad      enddo
7788 cgrad      do m=i+2,j2
7789 cgrad        do ll=1,3
7790 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7791 cgrad        enddo
7792 cgrad      enddo
7793 cgrad      do m=k+2,l2
7794 cgrad        do ll=1,3
7795 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7796 cgrad        enddo
7797 cgrad      enddo
7798 cd      do iii=1,nres-3
7799 cd        write (2,*) iii,gcorr_loc(iii)
7800 cd      enddo
7801       eello4=ekont*eel4
7802 cd      write (2,*) 'ekont',ekont
7803 cd      write (iout,*) 'eello4',ekont*eel4
7804       return
7805       end
7806 C---------------------------------------------------------------------------
7807       double precision function eello5(i,j,k,l,jj,kk)
7808       implicit real*8 (a-h,o-z)
7809       include 'DIMENSIONS'
7810       include 'COMMON.IOUNITS'
7811       include 'COMMON.CHAIN'
7812       include 'COMMON.DERIV'
7813       include 'COMMON.INTERACT'
7814       include 'COMMON.CONTACTS'
7815       include 'COMMON.TORSION'
7816       include 'COMMON.VAR'
7817       include 'COMMON.GEO'
7818       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7819       double precision ggg1(3),ggg2(3)
7820 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7821 C                                                                              C
7822 C                            Parallel chains                                   C
7823 C                                                                              C
7824 C          o             o                   o             o                   C
7825 C         /l\           / \             \   / \           / \   /              C
7826 C        /   \         /   \             \ /   \         /   \ /               C
7827 C       j| o |l1       | o |              o| o |         | o |o                C
7828 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7829 C      \i/   \         /   \ /             /   \         /   \                 C
7830 C       o    k1             o                                                  C
7831 C         (I)          (II)                (III)          (IV)                 C
7832 C                                                                              C
7833 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7834 C                                                                              C
7835 C                            Antiparallel chains                               C
7836 C                                                                              C
7837 C          o             o                   o             o                   C
7838 C         /j\           / \             \   / \           / \   /              C
7839 C        /   \         /   \             \ /   \         /   \ /               C
7840 C      j1| o |l        | o |              o| o |         | o |o                C
7841 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7842 C      \i/   \         /   \ /             /   \         /   \                 C
7843 C       o     k1            o                                                  C
7844 C         (I)          (II)                (III)          (IV)                 C
7845 C                                                                              C
7846 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7847 C                                                                              C
7848 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7849 C                                                                              C
7850 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7851 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7852 cd        eello5=0.0d0
7853 cd        return
7854 cd      endif
7855 cd      write (iout,*)
7856 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7857 cd     &   ' and',k,l
7858       itk=itortyp(itype(k))
7859       itl=itortyp(itype(l))
7860       itj=itortyp(itype(j))
7861       eello5_1=0.0d0
7862       eello5_2=0.0d0
7863       eello5_3=0.0d0
7864       eello5_4=0.0d0
7865 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7866 cd     &   eel5_3_num,eel5_4_num)
7867       do iii=1,2
7868         do kkk=1,5
7869           do lll=1,3
7870             derx(lll,kkk,iii)=0.0d0
7871           enddo
7872         enddo
7873       enddo
7874 cd      eij=facont_hb(jj,i)
7875 cd      ekl=facont_hb(kk,k)
7876 cd      ekont=eij*ekl
7877 cd      write (iout,*)'Contacts have occurred for peptide groups',
7878 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7879 cd      goto 1111
7880 C Contribution from the graph I.
7881 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7882 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7883       call transpose2(EUg(1,1,k),auxmat(1,1))
7884       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7885       vv(1)=pizda(1,1)-pizda(2,2)
7886       vv(2)=pizda(1,2)+pizda(2,1)
7887       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7888      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7889 C Explicit gradient in virtual-dihedral angles.
7890       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7891      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7892      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7893       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7894       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7895       vv(1)=pizda(1,1)-pizda(2,2)
7896       vv(2)=pizda(1,2)+pizda(2,1)
7897       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7898      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7899      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7900       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7901       vv(1)=pizda(1,1)-pizda(2,2)
7902       vv(2)=pizda(1,2)+pizda(2,1)
7903       if (l.eq.j+1) then
7904         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7905      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7906      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7907       else
7908         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7909      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7910      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7911       endif
7912 C Cartesian gradient
7913       do iii=1,2
7914         do kkk=1,5
7915           do lll=1,3
7916             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7917      &        pizda(1,1))
7918             vv(1)=pizda(1,1)-pizda(2,2)
7919             vv(2)=pizda(1,2)+pizda(2,1)
7920             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7921      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7922      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7923           enddo
7924         enddo
7925       enddo
7926 c      goto 1112
7927 c1111  continue
7928 C Contribution from graph II
7929       call transpose2(EE(1,1,itk),auxmat(1,1))
7930       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7931       vv(1)=pizda(1,1)+pizda(2,2)
7932       vv(2)=pizda(2,1)-pizda(1,2)
7933       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7934      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7935 C Explicit gradient in virtual-dihedral angles.
7936       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7937      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7938       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7939       vv(1)=pizda(1,1)+pizda(2,2)
7940       vv(2)=pizda(2,1)-pizda(1,2)
7941       if (l.eq.j+1) then
7942         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7943      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7944      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7945       else
7946         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7947      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7948      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7949       endif
7950 C Cartesian gradient
7951       do iii=1,2
7952         do kkk=1,5
7953           do lll=1,3
7954             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7955      &        pizda(1,1))
7956             vv(1)=pizda(1,1)+pizda(2,2)
7957             vv(2)=pizda(2,1)-pizda(1,2)
7958             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7959      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7960      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7961           enddo
7962         enddo
7963       enddo
7964 cd      goto 1112
7965 cd1111  continue
7966       if (l.eq.j+1) then
7967 cd        goto 1110
7968 C Parallel orientation
7969 C Contribution from graph III
7970         call transpose2(EUg(1,1,l),auxmat(1,1))
7971         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7972         vv(1)=pizda(1,1)-pizda(2,2)
7973         vv(2)=pizda(1,2)+pizda(2,1)
7974         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7975      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7976 C Explicit gradient in virtual-dihedral angles.
7977         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7978      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7979      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7980         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7981         vv(1)=pizda(1,1)-pizda(2,2)
7982         vv(2)=pizda(1,2)+pizda(2,1)
7983         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7984      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7985      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7986         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7987         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7988         vv(1)=pizda(1,1)-pizda(2,2)
7989         vv(2)=pizda(1,2)+pizda(2,1)
7990         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7991      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7992      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7993 C Cartesian gradient
7994         do iii=1,2
7995           do kkk=1,5
7996             do lll=1,3
7997               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7998      &          pizda(1,1))
7999               vv(1)=pizda(1,1)-pizda(2,2)
8000               vv(2)=pizda(1,2)+pizda(2,1)
8001               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8002      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8003      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8004             enddo
8005           enddo
8006         enddo
8007 cd        goto 1112
8008 C Contribution from graph IV
8009 cd1110    continue
8010         call transpose2(EE(1,1,itl),auxmat(1,1))
8011         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8012         vv(1)=pizda(1,1)+pizda(2,2)
8013         vv(2)=pizda(2,1)-pizda(1,2)
8014         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8015      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8016 C Explicit gradient in virtual-dihedral angles.
8017         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8018      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8019         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8020         vv(1)=pizda(1,1)+pizda(2,2)
8021         vv(2)=pizda(2,1)-pizda(1,2)
8022         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8023      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8024      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8025 C Cartesian gradient
8026         do iii=1,2
8027           do kkk=1,5
8028             do lll=1,3
8029               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8030      &          pizda(1,1))
8031               vv(1)=pizda(1,1)+pizda(2,2)
8032               vv(2)=pizda(2,1)-pizda(1,2)
8033               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8034      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8035      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8036             enddo
8037           enddo
8038         enddo
8039       else
8040 C Antiparallel orientation
8041 C Contribution from graph III
8042 c        goto 1110
8043         call transpose2(EUg(1,1,j),auxmat(1,1))
8044         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8045         vv(1)=pizda(1,1)-pizda(2,2)
8046         vv(2)=pizda(1,2)+pizda(2,1)
8047         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8048      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8049 C Explicit gradient in virtual-dihedral angles.
8050         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8051      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8052      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8053         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8054         vv(1)=pizda(1,1)-pizda(2,2)
8055         vv(2)=pizda(1,2)+pizda(2,1)
8056         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8057      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8058      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8059         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8060         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8061         vv(1)=pizda(1,1)-pizda(2,2)
8062         vv(2)=pizda(1,2)+pizda(2,1)
8063         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8064      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8065      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8066 C Cartesian gradient
8067         do iii=1,2
8068           do kkk=1,5
8069             do lll=1,3
8070               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8071      &          pizda(1,1))
8072               vv(1)=pizda(1,1)-pizda(2,2)
8073               vv(2)=pizda(1,2)+pizda(2,1)
8074               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8075      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8076      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8077             enddo
8078           enddo
8079         enddo
8080 cd        goto 1112
8081 C Contribution from graph IV
8082 1110    continue
8083         call transpose2(EE(1,1,itj),auxmat(1,1))
8084         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8085         vv(1)=pizda(1,1)+pizda(2,2)
8086         vv(2)=pizda(2,1)-pizda(1,2)
8087         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8088      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8089 C Explicit gradient in virtual-dihedral angles.
8090         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8091      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8092         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8093         vv(1)=pizda(1,1)+pizda(2,2)
8094         vv(2)=pizda(2,1)-pizda(1,2)
8095         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8096      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8097      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8098 C Cartesian gradient
8099         do iii=1,2
8100           do kkk=1,5
8101             do lll=1,3
8102               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8103      &          pizda(1,1))
8104               vv(1)=pizda(1,1)+pizda(2,2)
8105               vv(2)=pizda(2,1)-pizda(1,2)
8106               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8107      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8108      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8109             enddo
8110           enddo
8111         enddo
8112       endif
8113 1112  continue
8114       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8115 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8116 cd        write (2,*) 'ijkl',i,j,k,l
8117 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8118 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8119 cd      endif
8120 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8121 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8122 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8123 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8124       if (j.lt.nres-1) then
8125         j1=j+1
8126         j2=j-1
8127       else
8128         j1=j-1
8129         j2=j-2
8130       endif
8131       if (l.lt.nres-1) then
8132         l1=l+1
8133         l2=l-1
8134       else
8135         l1=l-1
8136         l2=l-2
8137       endif
8138 cd      eij=1.0d0
8139 cd      ekl=1.0d0
8140 cd      ekont=1.0d0
8141 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8142 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8143 C        summed up outside the subrouine as for the other subroutines
8144 C        handling long-range interactions. The old code is commented out
8145 C        with "cgrad" to keep track of changes.
8146       do ll=1,3
8147 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8148 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8149         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8150         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8151 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8152 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8153 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8154 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8155 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8156 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8157 c     &   gradcorr5ij,
8158 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8159 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8160 cgrad        ghalf=0.5d0*ggg1(ll)
8161 cd        ghalf=0.0d0
8162         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8163         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8164         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8165         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8166         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8167         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8168 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8169 cgrad        ghalf=0.5d0*ggg2(ll)
8170 cd        ghalf=0.0d0
8171         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8172         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8173         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8174         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8175         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8176         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8177       enddo
8178 cd      goto 1112
8179 cgrad      do m=i+1,j-1
8180 cgrad        do ll=1,3
8181 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8182 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8183 cgrad        enddo
8184 cgrad      enddo
8185 cgrad      do m=k+1,l-1
8186 cgrad        do ll=1,3
8187 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8188 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8189 cgrad        enddo
8190 cgrad      enddo
8191 c1112  continue
8192 cgrad      do m=i+2,j2
8193 cgrad        do ll=1,3
8194 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8195 cgrad        enddo
8196 cgrad      enddo
8197 cgrad      do m=k+2,l2
8198 cgrad        do ll=1,3
8199 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8200 cgrad        enddo
8201 cgrad      enddo
8202 cd      do iii=1,nres-3
8203 cd        write (2,*) iii,g_corr5_loc(iii)
8204 cd      enddo
8205       eello5=ekont*eel5
8206 cd      write (2,*) 'ekont',ekont
8207 cd      write (iout,*) 'eello5',ekont*eel5
8208       return
8209       end
8210 c--------------------------------------------------------------------------
8211       double precision function eello6(i,j,k,l,jj,kk)
8212       implicit real*8 (a-h,o-z)
8213       include 'DIMENSIONS'
8214       include 'COMMON.IOUNITS'
8215       include 'COMMON.CHAIN'
8216       include 'COMMON.DERIV'
8217       include 'COMMON.INTERACT'
8218       include 'COMMON.CONTACTS'
8219       include 'COMMON.TORSION'
8220       include 'COMMON.VAR'
8221       include 'COMMON.GEO'
8222       include 'COMMON.FFIELD'
8223       double precision ggg1(3),ggg2(3)
8224 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8225 cd        eello6=0.0d0
8226 cd        return
8227 cd      endif
8228 cd      write (iout,*)
8229 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8230 cd     &   ' and',k,l
8231       eello6_1=0.0d0
8232       eello6_2=0.0d0
8233       eello6_3=0.0d0
8234       eello6_4=0.0d0
8235       eello6_5=0.0d0
8236       eello6_6=0.0d0
8237 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8238 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8239       do iii=1,2
8240         do kkk=1,5
8241           do lll=1,3
8242             derx(lll,kkk,iii)=0.0d0
8243           enddo
8244         enddo
8245       enddo
8246 cd      eij=facont_hb(jj,i)
8247 cd      ekl=facont_hb(kk,k)
8248 cd      ekont=eij*ekl
8249 cd      eij=1.0d0
8250 cd      ekl=1.0d0
8251 cd      ekont=1.0d0
8252       if (l.eq.j+1) then
8253         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8254         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8255         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8256         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8257         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8258         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8259       else
8260         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8261         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8262         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8263         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8264         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8265           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8266         else
8267           eello6_5=0.0d0
8268         endif
8269         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8270       endif
8271 C If turn contributions are considered, they will be handled separately.
8272       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8273 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8274 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8275 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8276 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8277 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8278 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8279 cd      goto 1112
8280       if (j.lt.nres-1) then
8281         j1=j+1
8282         j2=j-1
8283       else
8284         j1=j-1
8285         j2=j-2
8286       endif
8287       if (l.lt.nres-1) then
8288         l1=l+1
8289         l2=l-1
8290       else
8291         l1=l-1
8292         l2=l-2
8293       endif
8294       do ll=1,3
8295 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8296 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8297 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8298 cgrad        ghalf=0.5d0*ggg1(ll)
8299 cd        ghalf=0.0d0
8300         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8301         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8302         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8303         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8304         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8305         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8306         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8307         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8308 cgrad        ghalf=0.5d0*ggg2(ll)
8309 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8310 cd        ghalf=0.0d0
8311         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8312         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8313         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8314         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8315         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8316         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8317       enddo
8318 cd      goto 1112
8319 cgrad      do m=i+1,j-1
8320 cgrad        do ll=1,3
8321 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8322 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8323 cgrad        enddo
8324 cgrad      enddo
8325 cgrad      do m=k+1,l-1
8326 cgrad        do ll=1,3
8327 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8328 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8329 cgrad        enddo
8330 cgrad      enddo
8331 cgrad1112  continue
8332 cgrad      do m=i+2,j2
8333 cgrad        do ll=1,3
8334 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8335 cgrad        enddo
8336 cgrad      enddo
8337 cgrad      do m=k+2,l2
8338 cgrad        do ll=1,3
8339 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8340 cgrad        enddo
8341 cgrad      enddo
8342 cd      do iii=1,nres-3
8343 cd        write (2,*) iii,g_corr6_loc(iii)
8344 cd      enddo
8345       eello6=ekont*eel6
8346 cd      write (2,*) 'ekont',ekont
8347 cd      write (iout,*) 'eello6',ekont*eel6
8348       return
8349       end
8350 c--------------------------------------------------------------------------
8351       double precision function eello6_graph1(i,j,k,l,imat,swap)
8352       implicit real*8 (a-h,o-z)
8353       include 'DIMENSIONS'
8354       include 'COMMON.IOUNITS'
8355       include 'COMMON.CHAIN'
8356       include 'COMMON.DERIV'
8357       include 'COMMON.INTERACT'
8358       include 'COMMON.CONTACTS'
8359       include 'COMMON.TORSION'
8360       include 'COMMON.VAR'
8361       include 'COMMON.GEO'
8362       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8363       logical swap
8364       logical lprn
8365       common /kutas/ lprn
8366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8367 C                                                                              C
8368 C      Parallel       Antiparallel                                             C
8369 C                                                                              C
8370 C          o             o                                                     C
8371 C         /l\           /j\                                                    C
8372 C        /   \         /   \                                                   C
8373 C       /| o |         | o |\                                                  C
8374 C     \ j|/k\|  /   \  |/k\|l /                                                C
8375 C      \ /   \ /     \ /   \ /                                                 C
8376 C       o     o       o     o                                                  C
8377 C       i             i                                                        C
8378 C                                                                              C
8379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8380       itk=itortyp(itype(k))
8381       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8382       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8383       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8384       call transpose2(EUgC(1,1,k),auxmat(1,1))
8385       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8386       vv1(1)=pizda1(1,1)-pizda1(2,2)
8387       vv1(2)=pizda1(1,2)+pizda1(2,1)
8388       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8389       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8390       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8391       s5=scalar2(vv(1),Dtobr2(1,i))
8392 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8393       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8394       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8395      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8396      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8397      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8398      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8399      & +scalar2(vv(1),Dtobr2der(1,i)))
8400       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8401       vv1(1)=pizda1(1,1)-pizda1(2,2)
8402       vv1(2)=pizda1(1,2)+pizda1(2,1)
8403       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8404       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8405       if (l.eq.j+1) then
8406         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8407      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8408      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8409      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8410      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8411       else
8412         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8413      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8414      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8415      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8416      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8417       endif
8418       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8419       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8420       vv1(1)=pizda1(1,1)-pizda1(2,2)
8421       vv1(2)=pizda1(1,2)+pizda1(2,1)
8422       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8423      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8424      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8425      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8426       do iii=1,2
8427         if (swap) then
8428           ind=3-iii
8429         else
8430           ind=iii
8431         endif
8432         do kkk=1,5
8433           do lll=1,3
8434             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8435             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8436             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8437             call transpose2(EUgC(1,1,k),auxmat(1,1))
8438             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8439      &        pizda1(1,1))
8440             vv1(1)=pizda1(1,1)-pizda1(2,2)
8441             vv1(2)=pizda1(1,2)+pizda1(2,1)
8442             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8443             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8444      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8445             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8446      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8447             s5=scalar2(vv(1),Dtobr2(1,i))
8448             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8449           enddo
8450         enddo
8451       enddo
8452       return
8453       end
8454 c----------------------------------------------------------------------------
8455       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8456       implicit real*8 (a-h,o-z)
8457       include 'DIMENSIONS'
8458       include 'COMMON.IOUNITS'
8459       include 'COMMON.CHAIN'
8460       include 'COMMON.DERIV'
8461       include 'COMMON.INTERACT'
8462       include 'COMMON.CONTACTS'
8463       include 'COMMON.TORSION'
8464       include 'COMMON.VAR'
8465       include 'COMMON.GEO'
8466       logical swap
8467       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8468      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8469       logical lprn
8470       common /kutas/ lprn
8471 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8472 C                                                                              C
8473 C      Parallel       Antiparallel                                             C
8474 C                                                                              C
8475 C          o             o                                                     C
8476 C     \   /l\           /j\   /                                                C
8477 C      \ /   \         /   \ /                                                 C
8478 C       o| o |         | o |o                                                  C
8479 C     \ j|/k\|      \  |/k\|l                                                  C
8480 C      \ /   \       \ /   \                                                   C
8481 C       o             o                                                        C
8482 C       i             i                                                        C
8483 C                                                                              C
8484 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8485 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8486 C AL 7/4/01 s1 would occur in the sixth-order moment,
8487 C           but not in a cluster cumulant
8488 #ifdef MOMENT
8489       s1=dip(1,jj,i)*dip(1,kk,k)
8490 #endif
8491       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8492       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8493       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8494       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8495       call transpose2(EUg(1,1,k),auxmat(1,1))
8496       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8497       vv(1)=pizda(1,1)-pizda(2,2)
8498       vv(2)=pizda(1,2)+pizda(2,1)
8499       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8500 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8501 #ifdef MOMENT
8502       eello6_graph2=-(s1+s2+s3+s4)
8503 #else
8504       eello6_graph2=-(s2+s3+s4)
8505 #endif
8506 c      eello6_graph2=-s3
8507 C Derivatives in gamma(i-1)
8508       if (i.gt.1) then
8509 #ifdef MOMENT
8510         s1=dipderg(1,jj,i)*dip(1,kk,k)
8511 #endif
8512         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8513         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8514         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8515         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8516 #ifdef MOMENT
8517         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8518 #else
8519         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8520 #endif
8521 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8522       endif
8523 C Derivatives in gamma(k-1)
8524 #ifdef MOMENT
8525       s1=dip(1,jj,i)*dipderg(1,kk,k)
8526 #endif
8527       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8528       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8529       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8530       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8531       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8532       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8533       vv(1)=pizda(1,1)-pizda(2,2)
8534       vv(2)=pizda(1,2)+pizda(2,1)
8535       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8536 #ifdef MOMENT
8537       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8538 #else
8539       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8540 #endif
8541 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8542 C Derivatives in gamma(j-1) or gamma(l-1)
8543       if (j.gt.1) then
8544 #ifdef MOMENT
8545         s1=dipderg(3,jj,i)*dip(1,kk,k)
8546 #endif
8547         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8548         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8549         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8550         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8551         vv(1)=pizda(1,1)-pizda(2,2)
8552         vv(2)=pizda(1,2)+pizda(2,1)
8553         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8554 #ifdef MOMENT
8555         if (swap) then
8556           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8557         else
8558           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8559         endif
8560 #endif
8561         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8562 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8563       endif
8564 C Derivatives in gamma(l-1) or gamma(j-1)
8565       if (l.gt.1) then
8566 #ifdef MOMENT
8567         s1=dip(1,jj,i)*dipderg(3,kk,k)
8568 #endif
8569         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8570         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8571         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8572         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8573         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8574         vv(1)=pizda(1,1)-pizda(2,2)
8575         vv(2)=pizda(1,2)+pizda(2,1)
8576         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8577 #ifdef MOMENT
8578         if (swap) then
8579           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8580         else
8581           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8582         endif
8583 #endif
8584         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8585 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8586       endif
8587 C Cartesian derivatives.
8588       if (lprn) then
8589         write (2,*) 'In eello6_graph2'
8590         do iii=1,2
8591           write (2,*) 'iii=',iii
8592           do kkk=1,5
8593             write (2,*) 'kkk=',kkk
8594             do jjj=1,2
8595               write (2,'(3(2f10.5),5x)')
8596      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8597             enddo
8598           enddo
8599         enddo
8600       endif
8601       do iii=1,2
8602         do kkk=1,5
8603           do lll=1,3
8604 #ifdef MOMENT
8605             if (iii.eq.1) then
8606               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8607             else
8608               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8609             endif
8610 #endif
8611             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8612      &        auxvec(1))
8613             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8614             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8615      &        auxvec(1))
8616             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8617             call transpose2(EUg(1,1,k),auxmat(1,1))
8618             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8619      &        pizda(1,1))
8620             vv(1)=pizda(1,1)-pizda(2,2)
8621             vv(2)=pizda(1,2)+pizda(2,1)
8622             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8623 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8624 #ifdef MOMENT
8625             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8626 #else
8627             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8628 #endif
8629             if (swap) then
8630               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8631             else
8632               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8633             endif
8634           enddo
8635         enddo
8636       enddo
8637       return
8638       end
8639 c----------------------------------------------------------------------------
8640       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8641       implicit real*8 (a-h,o-z)
8642       include 'DIMENSIONS'
8643       include 'COMMON.IOUNITS'
8644       include 'COMMON.CHAIN'
8645       include 'COMMON.DERIV'
8646       include 'COMMON.INTERACT'
8647       include 'COMMON.CONTACTS'
8648       include 'COMMON.TORSION'
8649       include 'COMMON.VAR'
8650       include 'COMMON.GEO'
8651       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8652       logical swap
8653 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8654 C                                                                              C
8655 C      Parallel       Antiparallel                                             C
8656 C                                                                              C
8657 C          o             o                                                     C
8658 C         /l\   /   \   /j\                                                    C
8659 C        /   \ /     \ /   \                                                   C
8660 C       /| o |o       o| o |\                                                  C
8661 C       j|/k\|  /      |/k\|l /                                                C
8662 C        /   \ /       /   \ /                                                 C
8663 C       /     o       /     o                                                  C
8664 C       i             i                                                        C
8665 C                                                                              C
8666 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8667 C
8668 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8669 C           energy moment and not to the cluster cumulant.
8670       iti=itortyp(itype(i))
8671       if (j.lt.nres-1) then
8672         itj1=itortyp(itype(j+1))
8673       else
8674         itj1=ntortyp
8675       endif
8676       itk=itortyp(itype(k))
8677       itk1=itortyp(itype(k+1))
8678       if (l.lt.nres-1) then
8679         itl1=itortyp(itype(l+1))
8680       else
8681         itl1=ntortyp
8682       endif
8683 #ifdef MOMENT
8684       s1=dip(4,jj,i)*dip(4,kk,k)
8685 #endif
8686       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8687       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8688       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8689       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8690       call transpose2(EE(1,1,itk),auxmat(1,1))
8691       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8692       vv(1)=pizda(1,1)+pizda(2,2)
8693       vv(2)=pizda(2,1)-pizda(1,2)
8694       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8695 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8696 cd     & "sum",-(s2+s3+s4)
8697 #ifdef MOMENT
8698       eello6_graph3=-(s1+s2+s3+s4)
8699 #else
8700       eello6_graph3=-(s2+s3+s4)
8701 #endif
8702 c      eello6_graph3=-s4
8703 C Derivatives in gamma(k-1)
8704       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8705       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8706       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8707       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8708 C Derivatives in gamma(l-1)
8709       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8710       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8711       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8712       vv(1)=pizda(1,1)+pizda(2,2)
8713       vv(2)=pizda(2,1)-pizda(1,2)
8714       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8715       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8716 C Cartesian derivatives.
8717       do iii=1,2
8718         do kkk=1,5
8719           do lll=1,3
8720 #ifdef MOMENT
8721             if (iii.eq.1) then
8722               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8723             else
8724               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8725             endif
8726 #endif
8727             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8728      &        auxvec(1))
8729             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8730             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8731      &        auxvec(1))
8732             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8733             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8734      &        pizda(1,1))
8735             vv(1)=pizda(1,1)+pizda(2,2)
8736             vv(2)=pizda(2,1)-pizda(1,2)
8737             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8738 #ifdef MOMENT
8739             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8740 #else
8741             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8742 #endif
8743             if (swap) then
8744               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8745             else
8746               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8747             endif
8748 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8749           enddo
8750         enddo
8751       enddo
8752       return
8753       end
8754 c----------------------------------------------------------------------------
8755       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8756       implicit real*8 (a-h,o-z)
8757       include 'DIMENSIONS'
8758       include 'COMMON.IOUNITS'
8759       include 'COMMON.CHAIN'
8760       include 'COMMON.DERIV'
8761       include 'COMMON.INTERACT'
8762       include 'COMMON.CONTACTS'
8763       include 'COMMON.TORSION'
8764       include 'COMMON.VAR'
8765       include 'COMMON.GEO'
8766       include 'COMMON.FFIELD'
8767       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8768      & auxvec1(2),auxmat1(2,2)
8769       logical swap
8770 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8771 C                                                                              C
8772 C      Parallel       Antiparallel                                             C
8773 C                                                                              C
8774 C          o             o                                                     C
8775 C         /l\   /   \   /j\                                                    C
8776 C        /   \ /     \ /   \                                                   C
8777 C       /| o |o       o| o |\                                                  C
8778 C     \ j|/k\|      \  |/k\|l                                                  C
8779 C      \ /   \       \ /   \                                                   C
8780 C       o     \       o     \                                                  C
8781 C       i             i                                                        C
8782 C                                                                              C
8783 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8784 C
8785 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8786 C           energy moment and not to the cluster cumulant.
8787 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8788       iti=itortyp(itype(i))
8789       itj=itortyp(itype(j))
8790       if (j.lt.nres-1) then
8791         itj1=itortyp(itype(j+1))
8792       else
8793         itj1=ntortyp
8794       endif
8795       itk=itortyp(itype(k))
8796       if (k.lt.nres-1) then
8797         itk1=itortyp(itype(k+1))
8798       else
8799         itk1=ntortyp
8800       endif
8801       itl=itortyp(itype(l))
8802       if (l.lt.nres-1) then
8803         itl1=itortyp(itype(l+1))
8804       else
8805         itl1=ntortyp
8806       endif
8807 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8808 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8809 cd     & ' itl',itl,' itl1',itl1
8810 #ifdef MOMENT
8811       if (imat.eq.1) then
8812         s1=dip(3,jj,i)*dip(3,kk,k)
8813       else
8814         s1=dip(2,jj,j)*dip(2,kk,l)
8815       endif
8816 #endif
8817       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8818       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8819       if (j.eq.l+1) then
8820         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8821         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8822       else
8823         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8824         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8825       endif
8826       call transpose2(EUg(1,1,k),auxmat(1,1))
8827       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8828       vv(1)=pizda(1,1)-pizda(2,2)
8829       vv(2)=pizda(2,1)+pizda(1,2)
8830       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8831 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8832 #ifdef MOMENT
8833       eello6_graph4=-(s1+s2+s3+s4)
8834 #else
8835       eello6_graph4=-(s2+s3+s4)
8836 #endif
8837 C Derivatives in gamma(i-1)
8838       if (i.gt.1) then
8839 #ifdef MOMENT
8840         if (imat.eq.1) then
8841           s1=dipderg(2,jj,i)*dip(3,kk,k)
8842         else
8843           s1=dipderg(4,jj,j)*dip(2,kk,l)
8844         endif
8845 #endif
8846         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8847         if (j.eq.l+1) then
8848           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8849           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8850         else
8851           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8852           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8853         endif
8854         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8855         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8856 cd          write (2,*) 'turn6 derivatives'
8857 #ifdef MOMENT
8858           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8859 #else
8860           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8861 #endif
8862         else
8863 #ifdef MOMENT
8864           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8865 #else
8866           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8867 #endif
8868         endif
8869       endif
8870 C Derivatives in gamma(k-1)
8871 #ifdef MOMENT
8872       if (imat.eq.1) then
8873         s1=dip(3,jj,i)*dipderg(2,kk,k)
8874       else
8875         s1=dip(2,jj,j)*dipderg(4,kk,l)
8876       endif
8877 #endif
8878       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8879       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8880       if (j.eq.l+1) then
8881         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8882         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8883       else
8884         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8885         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8886       endif
8887       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8888       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8889       vv(1)=pizda(1,1)-pizda(2,2)
8890       vv(2)=pizda(2,1)+pizda(1,2)
8891       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8892       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8893 #ifdef MOMENT
8894         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8895 #else
8896         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8897 #endif
8898       else
8899 #ifdef MOMENT
8900         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8901 #else
8902         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8903 #endif
8904       endif
8905 C Derivatives in gamma(j-1) or gamma(l-1)
8906       if (l.eq.j+1 .and. l.gt.1) then
8907         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8908         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8909         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8910         vv(1)=pizda(1,1)-pizda(2,2)
8911         vv(2)=pizda(2,1)+pizda(1,2)
8912         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8913         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8914       else if (j.gt.1) then
8915         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8916         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8917         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8918         vv(1)=pizda(1,1)-pizda(2,2)
8919         vv(2)=pizda(2,1)+pizda(1,2)
8920         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8921         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8922           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8923         else
8924           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8925         endif
8926       endif
8927 C Cartesian derivatives.
8928       do iii=1,2
8929         do kkk=1,5
8930           do lll=1,3
8931 #ifdef MOMENT
8932             if (iii.eq.1) then
8933               if (imat.eq.1) then
8934                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8935               else
8936                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8937               endif
8938             else
8939               if (imat.eq.1) then
8940                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8941               else
8942                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8943               endif
8944             endif
8945 #endif
8946             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8947      &        auxvec(1))
8948             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8949             if (j.eq.l+1) then
8950               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8951      &          b1(1,itj1),auxvec(1))
8952               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8953             else
8954               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8955      &          b1(1,itl1),auxvec(1))
8956               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8957             endif
8958             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8959      &        pizda(1,1))
8960             vv(1)=pizda(1,1)-pizda(2,2)
8961             vv(2)=pizda(2,1)+pizda(1,2)
8962             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8963             if (swap) then
8964               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8965 #ifdef MOMENT
8966                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8967      &             -(s1+s2+s4)
8968 #else
8969                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8970      &             -(s2+s4)
8971 #endif
8972                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8973               else
8974 #ifdef MOMENT
8975                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8976 #else
8977                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8978 #endif
8979                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8980               endif
8981             else
8982 #ifdef MOMENT
8983               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8984 #else
8985               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8986 #endif
8987               if (l.eq.j+1) then
8988                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8989               else
8990                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8991               endif
8992             endif
8993           enddo
8994         enddo
8995       enddo
8996       return
8997       end
8998 c----------------------------------------------------------------------------
8999       double precision function eello_turn6(i,jj,kk)
9000       implicit real*8 (a-h,o-z)
9001       include 'DIMENSIONS'
9002       include 'COMMON.IOUNITS'
9003       include 'COMMON.CHAIN'
9004       include 'COMMON.DERIV'
9005       include 'COMMON.INTERACT'
9006       include 'COMMON.CONTACTS'
9007       include 'COMMON.TORSION'
9008       include 'COMMON.VAR'
9009       include 'COMMON.GEO'
9010       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9011      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9012      &  ggg1(3),ggg2(3)
9013       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9014      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9015 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9016 C           the respective energy moment and not to the cluster cumulant.
9017       s1=0.0d0
9018       s8=0.0d0
9019       s13=0.0d0
9020 c
9021       eello_turn6=0.0d0
9022       j=i+4
9023       k=i+1
9024       l=i+3
9025       iti=itortyp(itype(i))
9026       itk=itortyp(itype(k))
9027       itk1=itortyp(itype(k+1))
9028       itl=itortyp(itype(l))
9029       itj=itortyp(itype(j))
9030 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9031 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9032 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9033 cd        eello6=0.0d0
9034 cd        return
9035 cd      endif
9036 cd      write (iout,*)
9037 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9038 cd     &   ' and',k,l
9039 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9040       do iii=1,2
9041         do kkk=1,5
9042           do lll=1,3
9043             derx_turn(lll,kkk,iii)=0.0d0
9044           enddo
9045         enddo
9046       enddo
9047 cd      eij=1.0d0
9048 cd      ekl=1.0d0
9049 cd      ekont=1.0d0
9050       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9051 cd      eello6_5=0.0d0
9052 cd      write (2,*) 'eello6_5',eello6_5
9053 #ifdef MOMENT
9054       call transpose2(AEA(1,1,1),auxmat(1,1))
9055       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9056       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9057       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9058 #endif
9059       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9060       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9061       s2 = scalar2(b1(1,itk),vtemp1(1))
9062 #ifdef MOMENT
9063       call transpose2(AEA(1,1,2),atemp(1,1))
9064       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9065       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9066       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9067 #endif
9068       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9069       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9070       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9071 #ifdef MOMENT
9072       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9073       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9074       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9075       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9076       ss13 = scalar2(b1(1,itk),vtemp4(1))
9077       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9078 #endif
9079 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9080 c      s1=0.0d0
9081 c      s2=0.0d0
9082 c      s8=0.0d0
9083 c      s12=0.0d0
9084 c      s13=0.0d0
9085       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9086 C Derivatives in gamma(i+2)
9087       s1d =0.0d0
9088       s8d =0.0d0
9089 #ifdef MOMENT
9090       call transpose2(AEA(1,1,1),auxmatd(1,1))
9091       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9092       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9093       call transpose2(AEAderg(1,1,2),atempd(1,1))
9094       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9095       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9096 #endif
9097       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9098       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9099       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9100 c      s1d=0.0d0
9101 c      s2d=0.0d0
9102 c      s8d=0.0d0
9103 c      s12d=0.0d0
9104 c      s13d=0.0d0
9105       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9106 C Derivatives in gamma(i+3)
9107 #ifdef MOMENT
9108       call transpose2(AEA(1,1,1),auxmatd(1,1))
9109       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9110       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9111       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9112 #endif
9113       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9114       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9115       s2d = scalar2(b1(1,itk),vtemp1d(1))
9116 #ifdef MOMENT
9117       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9118       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9119 #endif
9120       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9121 #ifdef MOMENT
9122       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9123       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9124       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9125 #endif
9126 c      s1d=0.0d0
9127 c      s2d=0.0d0
9128 c      s8d=0.0d0
9129 c      s12d=0.0d0
9130 c      s13d=0.0d0
9131 #ifdef MOMENT
9132       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9133      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9134 #else
9135       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9136      &               -0.5d0*ekont*(s2d+s12d)
9137 #endif
9138 C Derivatives in gamma(i+4)
9139       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9140       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9141       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9142 #ifdef MOMENT
9143       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9144       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9145       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9146 #endif
9147 c      s1d=0.0d0
9148 c      s2d=0.0d0
9149 c      s8d=0.0d0
9150 C      s12d=0.0d0
9151 c      s13d=0.0d0
9152 #ifdef MOMENT
9153       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9154 #else
9155       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9156 #endif
9157 C Derivatives in gamma(i+5)
9158 #ifdef MOMENT
9159       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9160       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9161       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9162 #endif
9163       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9164       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9165       s2d = scalar2(b1(1,itk),vtemp1d(1))
9166 #ifdef MOMENT
9167       call transpose2(AEA(1,1,2),atempd(1,1))
9168       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9169       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9170 #endif
9171       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9172       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9173 #ifdef MOMENT
9174       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9175       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9176       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9177 #endif
9178 c      s1d=0.0d0
9179 c      s2d=0.0d0
9180 c      s8d=0.0d0
9181 c      s12d=0.0d0
9182 c      s13d=0.0d0
9183 #ifdef MOMENT
9184       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9185      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9186 #else
9187       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9188      &               -0.5d0*ekont*(s2d+s12d)
9189 #endif
9190 C Cartesian derivatives
9191       do iii=1,2
9192         do kkk=1,5
9193           do lll=1,3
9194 #ifdef MOMENT
9195             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9196             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9197             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9198 #endif
9199             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9200             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9201      &          vtemp1d(1))
9202             s2d = scalar2(b1(1,itk),vtemp1d(1))
9203 #ifdef MOMENT
9204             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9205             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9206             s8d = -(atempd(1,1)+atempd(2,2))*
9207      &           scalar2(cc(1,1,itl),vtemp2(1))
9208 #endif
9209             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9210      &           auxmatd(1,1))
9211             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9212             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9213 c      s1d=0.0d0
9214 c      s2d=0.0d0
9215 c      s8d=0.0d0
9216 c      s12d=0.0d0
9217 c      s13d=0.0d0
9218 #ifdef MOMENT
9219             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9220      &        - 0.5d0*(s1d+s2d)
9221 #else
9222             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9223      &        - 0.5d0*s2d
9224 #endif
9225 #ifdef MOMENT
9226             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9227      &        - 0.5d0*(s8d+s12d)
9228 #else
9229             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9230      &        - 0.5d0*s12d
9231 #endif
9232           enddo
9233         enddo
9234       enddo
9235 #ifdef MOMENT
9236       do kkk=1,5
9237         do lll=1,3
9238           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9239      &      achuj_tempd(1,1))
9240           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9241           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9242           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9243           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9244           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9245      &      vtemp4d(1))
9246           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9247           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9248           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9249         enddo
9250       enddo
9251 #endif
9252 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9253 cd     &  16*eel_turn6_num
9254 cd      goto 1112
9255       if (j.lt.nres-1) then
9256         j1=j+1
9257         j2=j-1
9258       else
9259         j1=j-1
9260         j2=j-2
9261       endif
9262       if (l.lt.nres-1) then
9263         l1=l+1
9264         l2=l-1
9265       else
9266         l1=l-1
9267         l2=l-2
9268       endif
9269       do ll=1,3
9270 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9271 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9272 cgrad        ghalf=0.5d0*ggg1(ll)
9273 cd        ghalf=0.0d0
9274         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9275         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9276         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9277      &    +ekont*derx_turn(ll,2,1)
9278         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9279         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9280      &    +ekont*derx_turn(ll,4,1)
9281         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9282         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9283         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9284 cgrad        ghalf=0.5d0*ggg2(ll)
9285 cd        ghalf=0.0d0
9286         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9287      &    +ekont*derx_turn(ll,2,2)
9288         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9289         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9290      &    +ekont*derx_turn(ll,4,2)
9291         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9292         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9293         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9294       enddo
9295 cd      goto 1112
9296 cgrad      do m=i+1,j-1
9297 cgrad        do ll=1,3
9298 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9299 cgrad        enddo
9300 cgrad      enddo
9301 cgrad      do m=k+1,l-1
9302 cgrad        do ll=1,3
9303 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9304 cgrad        enddo
9305 cgrad      enddo
9306 cgrad1112  continue
9307 cgrad      do m=i+2,j2
9308 cgrad        do ll=1,3
9309 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9310 cgrad        enddo
9311 cgrad      enddo
9312 cgrad      do m=k+2,l2
9313 cgrad        do ll=1,3
9314 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9315 cgrad        enddo
9316 cgrad      enddo
9317 cd      do iii=1,nres-3
9318 cd        write (2,*) iii,g_corr6_loc(iii)
9319 cd      enddo
9320       eello_turn6=ekont*eel_turn6
9321 cd      write (2,*) 'ekont',ekont
9322 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9323       return
9324       end
9325
9326 C-----------------------------------------------------------------------------
9327       double precision function scalar(u,v)
9328 !DIR$ INLINEALWAYS scalar
9329 #ifndef OSF
9330 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9331 #endif
9332       implicit none
9333       double precision u(3),v(3)
9334 cd      double precision sc
9335 cd      integer i
9336 cd      sc=0.0d0
9337 cd      do i=1,3
9338 cd        sc=sc+u(i)*v(i)
9339 cd      enddo
9340 cd      scalar=sc
9341
9342       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9343       return
9344       end
9345 crc-------------------------------------------------
9346       SUBROUTINE MATVEC2(A1,V1,V2)
9347 !DIR$ INLINEALWAYS MATVEC2
9348 #ifndef OSF
9349 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9350 #endif
9351       implicit real*8 (a-h,o-z)
9352       include 'DIMENSIONS'
9353       DIMENSION A1(2,2),V1(2),V2(2)
9354 c      DO 1 I=1,2
9355 c        VI=0.0
9356 c        DO 3 K=1,2
9357 c    3     VI=VI+A1(I,K)*V1(K)
9358 c        Vaux(I)=VI
9359 c    1 CONTINUE
9360
9361       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9362       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9363
9364       v2(1)=vaux1
9365       v2(2)=vaux2
9366       END
9367 C---------------------------------------
9368       SUBROUTINE MATMAT2(A1,A2,A3)
9369 #ifndef OSF
9370 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9371 #endif
9372       implicit real*8 (a-h,o-z)
9373       include 'DIMENSIONS'
9374       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9375 c      DIMENSION AI3(2,2)
9376 c        DO  J=1,2
9377 c          A3IJ=0.0
9378 c          DO K=1,2
9379 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9380 c          enddo
9381 c          A3(I,J)=A3IJ
9382 c       enddo
9383 c      enddo
9384
9385       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9386       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9387       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9388       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9389
9390       A3(1,1)=AI3_11
9391       A3(2,1)=AI3_21
9392       A3(1,2)=AI3_12
9393       A3(2,2)=AI3_22
9394       END
9395
9396 c-------------------------------------------------------------------------
9397       double precision function scalar2(u,v)
9398 !DIR$ INLINEALWAYS scalar2
9399       implicit none
9400       double precision u(2),v(2)
9401       double precision sc
9402       integer i
9403       scalar2=u(1)*v(1)+u(2)*v(2)
9404       return
9405       end
9406
9407 C-----------------------------------------------------------------------------
9408
9409       subroutine transpose2(a,at)
9410 !DIR$ INLINEALWAYS transpose2
9411 #ifndef OSF
9412 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9413 #endif
9414       implicit none
9415       double precision a(2,2),at(2,2)
9416       at(1,1)=a(1,1)
9417       at(1,2)=a(2,1)
9418       at(2,1)=a(1,2)
9419       at(2,2)=a(2,2)
9420       return
9421       end
9422 c--------------------------------------------------------------------------
9423       subroutine transpose(n,a,at)
9424       implicit none
9425       integer n,i,j
9426       double precision a(n,n),at(n,n)
9427       do i=1,n
9428         do j=1,n
9429           at(j,i)=a(i,j)
9430         enddo
9431       enddo
9432       return
9433       end
9434 C---------------------------------------------------------------------------
9435       subroutine prodmat3(a1,a2,kk,transp,prod)
9436 !DIR$ INLINEALWAYS prodmat3
9437 #ifndef OSF
9438 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9439 #endif
9440       implicit none
9441       integer i,j
9442       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9443       logical transp
9444 crc      double precision auxmat(2,2),prod_(2,2)
9445
9446       if (transp) then
9447 crc        call transpose2(kk(1,1),auxmat(1,1))
9448 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9449 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9450
9451            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9452      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9453            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9454      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9455            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9456      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9457            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9458      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9459
9460       else
9461 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9462 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9463
9464            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9465      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9466            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9467      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9468            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9469      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9470            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9471      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9472
9473       endif
9474 c      call transpose2(a2(1,1),a2t(1,1))
9475
9476 crc      print *,transp
9477 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9478 crc      print *,((prod(i,j),i=1,2),j=1,2)
9479
9480       return
9481       end
9482