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 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.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 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202 C      print *,"TU DOCHODZE?"
 203       call esc(escloc)
 204 c      print *,"Processor",myrank," computed USC"
 205 C
 206 C Calculate the virtual-bond torsional energy.
 207 C
 208 cd    print *,'nterm=',nterm
 209       if (wtor.gt.0) then
 210        call etor(etors,edihcnstr)
 211       else
 212        etors=0
 213        edihcnstr=0
 214       endif
 215 c      print *,"Processor",myrank," computed Utor"
 216 C
 217 C 6/23/01 Calculate double-torsional energy
 218 C
 219       if (wtor_d.gt.0) then
 220        call etor_d(etors_d)
 221       else
 222        etors_d=0
 223       endif
 224 c      print *,"Processor",myrank," computed Utord"
 225 C
 226 C 21/5/07 Calculate local sicdechain correlation energy
 227 C
 228       if (wsccor.gt.0.0d0) then
 229         call eback_sc_corr(esccor)
 230       else
 231         esccor=0.0d0
 232       endif
 233 C      print *,"PRZED MULIt"
 234 c      print *,"Processor",myrank," computed Usccorr"
 235 C
 236 C 12/1/95 Multi-body terms
 237 C
 238       n_corr=0
 239       n_corr1=0
 240       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 241      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 242          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 243 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 244 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 245       else
 246          ecorr=0.0d0
 247          ecorr5=0.0d0
 248          ecorr6=0.0d0
 249          eturn6=0.0d0
 250       endif
 251       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 253 cd         write (iout,*) "multibody_hb ecorr",ecorr
 254       endif
 255 c      print *,"Processor",myrank," computed Ucorr"
 256 C
 257 C If performing constraint dynamics, call the constraint energy
 258 C  after the equilibration time
 259       if(usampl.and.totT.gt.eq_time) then
 260          call EconstrQ
 261          call Econstr_back
 262       else
 263          Uconst=0.0d0
 264          Uconst_back=0.0d0
 265       endif
 266 C 01/27/2015 added by adasko
 267 C the energy component below is energy transfer into lipid environment
 268 C based on partition function
 269 C      print *,"przed lipidami"
 270       if (wliptran.gt.0) then
 271         call Eliptransfer(eliptran)
 272       endif
 273 C      print *,"za lipidami"
 274 #ifdef TIMING
 275       time_enecalc=time_enecalc+MPI_Wtime()-time00
 276 #endif
 277 c      print *,"Processor",myrank," computed Uconstr"
 278 #ifdef TIMING
 279       time00=MPI_Wtime()
 280 #endif
 281 c
 282 C Sum the energies
 283 C
 284       energia(1)=evdw
 285 #ifdef SCP14
 286       energia(2)=evdw2-evdw2_14
 287       energia(18)=evdw2_14
 288 #else
 289       energia(2)=evdw2
 290       energia(18)=0.0d0
 291 #endif
 292 #ifdef SPLITELE
 293       energia(3)=ees
 294       energia(16)=evdw1
 295 #else
 296       energia(3)=ees+evdw1
 297       energia(16)=0.0d0
 298 #endif
 299       energia(4)=ecorr
 300       energia(5)=ecorr5
 301       energia(6)=ecorr6
 302       energia(7)=eel_loc
 303       energia(8)=eello_turn3
 304       energia(9)=eello_turn4
 305       energia(10)=eturn6
 306       energia(11)=ebe
 307       energia(12)=escloc
 308       energia(13)=etors
 309       energia(14)=etors_d
 310       energia(15)=ehpb
 311       energia(19)=edihcnstr
 312       energia(17)=estr
 313       energia(20)=Uconst+Uconst_back
 314       energia(21)=esccor
 315       energia(22)=eliptran
 316 c    Here are the energies showed per procesor if the are more processors
 317 c    per molecule then we sum it up in sum_energy subroutine
 318 c      print *," Processor",myrank," calls SUM_ENERGY"
 319       call sum_energy(energia,.true.)
 320       if (dyn_ss) call dyn_set_nss
 321 c      print *," Processor",myrank," left SUM_ENERGY"
 322 #ifdef TIMING
 323       time_sumene=time_sumene+MPI_Wtime()-time00
 324 #endif
 325       return
 326       end
 327 c-------------------------------------------------------------------------------
 328       subroutine sum_energy(energia,reduce)
 329       implicit real*8 (a-h,o-z)
 330       include 'DIMENSIONS'
 331 #ifndef ISNAN
 332       external proc_proc
 333 #ifdef WINPGI
 334 cMS$ATTRIBUTES C ::  proc_proc
 335 #endif
 336 #endif
 337 #ifdef MPI
 338       include "mpif.h"
 339 #endif
 340       include 'COMMON.SETUP'
 341       include 'COMMON.IOUNITS'
 342       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 343       include 'COMMON.FFIELD'
 344       include 'COMMON.DERIV'
 345       include 'COMMON.INTERACT'
 346       include 'COMMON.SBRIDGE'
 347       include 'COMMON.CHAIN'
 348       include 'COMMON.VAR'
 349       include 'COMMON.CONTROL'
 350       include 'COMMON.TIME1'
 351       logical reduce
 352 #ifdef MPI
 353       if (nfgtasks.gt.1 .and. reduce) then
 354 #ifdef DEBUG
 355         write (iout,*) "energies before REDUCE"
 356         call enerprint(energia)
 357         call flush(iout)
 358 #endif
 359         do i=0,n_ene
 360           enebuff(i)=energia(i)
 361         enddo
 362         time00=MPI_Wtime()
 363         call MPI_Barrier(FG_COMM,IERR)
 364         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 365         time00=MPI_Wtime()
 366         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 367      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 368 #ifdef DEBUG
 369         write (iout,*) "energies after REDUCE"
 370         call enerprint(energia)
 371         call flush(iout)
 372 #endif
 373         time_Reduce=time_Reduce+MPI_Wtime()-time00
 374       endif
 375       if (fg_rank.eq.0) then
 376 #endif
 377       evdw=energia(1)
 378 #ifdef SCP14
 379       evdw2=energia(2)+energia(18)
 380       evdw2_14=energia(18)
 381 #else
 382       evdw2=energia(2)
 383 #endif
 384 #ifdef SPLITELE
 385       ees=energia(3)
 386       evdw1=energia(16)
 387 #else
 388       ees=energia(3)
 389       evdw1=0.0d0
 390 #endif
 391       ecorr=energia(4)
 392       ecorr5=energia(5)
 393       ecorr6=energia(6)
 394       eel_loc=energia(7)
 395       eello_turn3=energia(8)
 396       eello_turn4=energia(9)
 397       eturn6=energia(10)
 398       ebe=energia(11)
 399       escloc=energia(12)
 400       etors=energia(13)
 401       etors_d=energia(14)
 402       ehpb=energia(15)
 403       edihcnstr=energia(19)
 404       estr=energia(17)
 405       Uconst=energia(20)
 406       esccor=energia(21)
 407       eliptran=energia(22)
 408 #ifdef SPLITELE
 409       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 410      & +wang*ebe+wtor*etors+wscloc*escloc
 411      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 412      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 413      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 414      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 415 #else
 416       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 417      & +wang*ebe+wtor*etors+wscloc*escloc
 418      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 419      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 420      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 421      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 422 #endif
 423       energia(0)=etot
 424 c detecting NaNQ
 425 #ifdef ISNAN
 426 #ifdef AIX
 427       if (isnan(etot).ne.0) energia(0)=1.0d+99
 428 #else
 429       if (isnan(etot)) energia(0)=1.0d+99
 430 #endif
 431 #else
 432       i=0
 433 #ifdef WINPGI
 434       idumm=proc_proc(etot,i)
 435 #else
 436       call proc_proc(etot,i)
 437 #endif
 438       if(i.eq.1)energia(0)=1.0d+99
 439 #endif
 440 #ifdef MPI
 441       endif
 442 #endif
 443       return
 444       end
 445 c-------------------------------------------------------------------------------
 446       subroutine sum_gradient
 447       implicit real*8 (a-h,o-z)
 448       include 'DIMENSIONS'
 449 #ifndef ISNAN
 450       external proc_proc
 451 #ifdef WINPGI
 452 cMS$ATTRIBUTES C ::  proc_proc
 453 #endif
 454 #endif
 455 #ifdef MPI
 456       include 'mpif.h'
 457 #endif
 458       double precision gradbufc(3,0:maxres),gradbufx(3,0:maxres),
 459      & glocbuf(4*maxres),gradbufc_sum(3,0:maxres),gloc_scbuf(3,0:maxres)
 460       include 'COMMON.SETUP'
 461       include 'COMMON.IOUNITS'
 462       include 'COMMON.FFIELD'
 463       include 'COMMON.DERIV'
 464       include 'COMMON.INTERACT'
 465       include 'COMMON.SBRIDGE'
 466       include 'COMMON.CHAIN'
 467       include 'COMMON.VAR'
 468       include 'COMMON.CONTROL'
 469       include 'COMMON.TIME1'
 470       include 'COMMON.MAXGRAD'
 471       include 'COMMON.SCCOR'
 472 #ifdef TIMING
 473       time01=MPI_Wtime()
 474 #endif
 475 #ifdef DEBUG
 476       write (iout,*) "sum_gradient gvdwc, gvdwx"
 477       do i=1,nres
 478         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 479      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 480       enddo
 481       call flush(iout)
 482 #endif
 483 #ifdef MPI
 484 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 485         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 486      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 487 #endif
 488 C
 489 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 490 C            in virtual-bond-vector coordinates
 491 C
 492 #ifdef DEBUG
 493 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 494 c      do i=1,nres-1
 495 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 496 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 497 c      enddo
 498 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 499 c      do i=1,nres-1
 500 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 501 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 502 c      enddo
 503       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 504       do i=1,nres
 505         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 506      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 507      &   g_corr5_loc(i)
 508       enddo
 509       call flush(iout)
 510 #endif
 511 #ifdef SPLITELE
 512       do i=1,nct
 513         do j=1,3
 514           gradbufc(j,i)=wsc*gvdwc(j,i)+
 515      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 516      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 517      &                wel_loc*gel_loc_long(j,i)+
 518      &                wcorr*gradcorr_long(j,i)+
 519      &                wcorr5*gradcorr5_long(j,i)+
 520      &                wcorr6*gradcorr6_long(j,i)+
 521      &                wturn6*gcorr6_turn_long(j,i)+
 522      &                wstrain*ghpbc(j,i)
 523      &                +wliptran*gliptranc(j,i)
 524
 525         enddo
 526       enddo
 527 #else
 528       do i=1,nct
 529         do j=1,3
 530           gradbufc(j,i)=wsc*gvdwc(j,i)+
 531      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 532      &                welec*gelc_long(j,i)+
 533      &                wbond*gradb(j,i)+
 534      &                wel_loc*gel_loc_long(j,i)+
 535      &                wcorr*gradcorr_long(j,i)+
 536      &                wcorr5*gradcorr5_long(j,i)+
 537      &                wcorr6*gradcorr6_long(j,i)+
 538      &                wturn6*gcorr6_turn_long(j,i)+
 539      &                wstrain*ghpbc(j,i)
 540      &                +wliptran*gliptranc(j,i)
 541         enddo
 542       enddo
 543 #endif
 544 #ifdef MPI
 545       if (nfgtasks.gt.1) then
 546       time00=MPI_Wtime()
 547 #ifdef DEBUG
 548       write (iout,*) "gradbufc before allreduce"
 549       do i=1,nres
 550         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 551       enddo
 552       call flush(iout)
 553 #endif
 554       do i=1,nres
 555         do j=1,3
 556           gradbufc_sum(j,i)=gradbufc(j,i)
 557         enddo
 558       enddo
 559 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 560 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 561 c      time_reduce=time_reduce+MPI_Wtime()-time00
 562 #ifdef DEBUG
 563 c      write (iout,*) "gradbufc_sum after allreduce"
 564 c      do i=1,nres
 565 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 566 c      enddo
 567 c      call flush(iout)
 568 #endif
 569 #ifdef TIMING
 570 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 571 #endif
 572       do i=nnt,nres
 573         do k=1,3
 574           gradbufc(k,i)=0.0d0
 575         enddo
 576       enddo
 577 #ifdef DEBUG
 578       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 579       write (iout,*) (i," jgrad_start",jgrad_start(i),
 580      &                  " jgrad_end  ",jgrad_end(i),
 581      &                  i=igrad_start,igrad_end)
 582 #endif
 583 c
 584 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 585 c do not parallelize this part.
 586 c
 587 c      do i=igrad_start,igrad_end
 588 c        do j=jgrad_start(i),jgrad_end(i)
 589 c          do k=1,3
 590 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 591 c          enddo
 592 c        enddo
 593 c      enddo
 594       do j=1,3
 595         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 596       enddo
 597       do i=nres-2,nnt,-1
 598         do j=1,3
 599           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 600         enddo
 601       enddo
 602 #ifdef DEBUG
 603       write (iout,*) "gradbufc after summing"
 604       do i=1,nres
 605         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 606       enddo
 607       call flush(iout)
 608 #endif
 609       else
 610 #endif
 611 #ifdef DEBUG
 612       write (iout,*) "gradbufc"
 613       do i=1,nres
 614         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 615       enddo
 616       call flush(iout)
 617 #endif
 618       do i=1,nres
 619         do j=1,3
 620           gradbufc_sum(j,i)=gradbufc(j,i)
 621           gradbufc(j,i)=0.0d0
 622         enddo
 623       enddo
 624       do j=1,3
 625         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 626       enddo
 627       do i=nres-2,nnt,-1
 628         do j=1,3
 629           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 630         enddo
 631       enddo
 632 c      do i=nnt,nres-1
 633 c        do k=1,3
 634 c          gradbufc(k,i)=0.0d0
 635 c        enddo
 636 c        do j=i+1,nres
 637 c          do k=1,3
 638 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 639 c          enddo
 640 c        enddo
 641 c      enddo
 642 #ifdef DEBUG
 643       write (iout,*) "gradbufc after summing"
 644       do i=1,nres
 645         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 646       enddo
 647       call flush(iout)
 648 #endif
 649 #ifdef MPI
 650       endif
 651 #endif
 652       do k=1,3
 653         gradbufc(k,nres)=0.0d0
 654       enddo
 655       do i=1,nct
 656         do j=1,3
 657 #ifdef SPLITELE
 658           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 659      &                wel_loc*gel_loc(j,i)+
 660      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 661      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 662      &                wel_loc*gel_loc_long(j,i)+
 663      &                wcorr*gradcorr_long(j,i)+
 664      &                wcorr5*gradcorr5_long(j,i)+
 665      &                wcorr6*gradcorr6_long(j,i)+
 666      &                wturn6*gcorr6_turn_long(j,i))+
 667      &                wbond*gradb(j,i)+
 668      &                wcorr*gradcorr(j,i)+
 669      &                wturn3*gcorr3_turn(j,i)+
 670      &                wturn4*gcorr4_turn(j,i)+
 671      &                wcorr5*gradcorr5(j,i)+
 672      &                wcorr6*gradcorr6(j,i)+
 673      &                wturn6*gcorr6_turn(j,i)+
 674      &                wsccor*gsccorc(j,i)
 675      &               +wscloc*gscloc(j,i)
 676      &               +wliptran*gliptranc(j,i)
 677 #else
 678           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 679      &                wel_loc*gel_loc(j,i)+
 680      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 681      &                welec*gelc_long(j,i)
 682      &                wel_loc*gel_loc_long(j,i)+
 683      &                wcorr*gcorr_long(j,i)+
 684      &                wcorr5*gradcorr5_long(j,i)+
 685      &                wcorr6*gradcorr6_long(j,i)+
 686      &                wturn6*gcorr6_turn_long(j,i))+
 687      &                wbond*gradb(j,i)+
 688      &                wcorr*gradcorr(j,i)+
 689      &                wturn3*gcorr3_turn(j,i)+
 690      &                wturn4*gcorr4_turn(j,i)+
 691      &                wcorr5*gradcorr5(j,i)+
 692      &                wcorr6*gradcorr6(j,i)+
 693      &                wturn6*gcorr6_turn(j,i)+
 694      &                wsccor*gsccorc(j,i)
 695      &               +wscloc*gscloc(j,i)
 696      &               +wliptran*gliptranc(j,i)
 697 #endif
 698           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 699      &                  wbond*gradbx(j,i)+
 700      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 701      &                  wsccor*gsccorx(j,i)
 702      &                 +wscloc*gsclocx(j,i)
 703      &                 +wliptran*gliptranx(j,i)
 704         enddo
 705       enddo
 706 #ifdef DEBUG
 707       write (iout,*) "gloc before adding corr"
 708       do i=1,4*nres
 709         write (iout,*) i,gloc(i,icg)
 710       enddo
 711 #endif
 712       do i=1,nres-3
 713         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 714      &   +wcorr5*g_corr5_loc(i)
 715      &   +wcorr6*g_corr6_loc(i)
 716      &   +wturn4*gel_loc_turn4(i)
 717      &   +wturn3*gel_loc_turn3(i)
 718      &   +wturn6*gel_loc_turn6(i)
 719      &   +wel_loc*gel_loc_loc(i)
 720       enddo
 721 #ifdef DEBUG
 722       write (iout,*) "gloc after adding corr"
 723       do i=1,4*nres
 724         write (iout,*) i,gloc(i,icg)
 725       enddo
 726 #endif
 727 #ifdef MPI
 728       if (nfgtasks.gt.1) then
 729         do j=1,3
 730           do i=1,nres
 731             gradbufc(j,i)=gradc(j,i,icg)
 732             gradbufx(j,i)=gradx(j,i,icg)
 733           enddo
 734         enddo
 735         do i=1,4*nres
 736           glocbuf(i)=gloc(i,icg)
 737         enddo
 738 c#define DEBUG
 739 #ifdef DEBUG
 740       write (iout,*) "gloc_sc before reduce"
 741       do i=1,nres
 742        do j=1,1
 743         write (iout,*) i,j,gloc_sc(j,i,icg)
 744        enddo
 745       enddo
 746 #endif
 747 c#undef DEBUG
 748         do i=1,nres
 749          do j=1,3
 750           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 751          enddo
 752         enddo
 753         time00=MPI_Wtime()
 754         call MPI_Barrier(FG_COMM,IERR)
 755         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 756         time00=MPI_Wtime()
 757         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 758      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 759         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 760      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 761         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 762      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 763         time_reduce=time_reduce+MPI_Wtime()-time00
 764         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 765      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 766         time_reduce=time_reduce+MPI_Wtime()-time00
 767 c#define DEBUG
 768 #ifdef DEBUG
 769       write (iout,*) "gloc_sc after reduce"
 770       do i=1,nres
 771        do j=1,1
 772         write (iout,*) i,j,gloc_sc(j,i,icg)
 773        enddo
 774       enddo
 775 #endif
 776 c#undef DEBUG
 777 #ifdef DEBUG
 778       write (iout,*) "gloc after reduce"
 779       do i=1,4*nres
 780         write (iout,*) i,gloc(i,icg)
 781       enddo
 782 #endif
 783       endif
 784 #endif
 785       if (gnorm_check) then
 786 c
 787 c Compute the maximum elements of the gradient
 788 c
 789       gvdwc_max=0.0d0
 790       gvdwc_scp_max=0.0d0
 791       gelc_max=0.0d0
 792       gvdwpp_max=0.0d0
 793       gradb_max=0.0d0
 794       ghpbc_max=0.0d0
 795       gradcorr_max=0.0d0
 796       gel_loc_max=0.0d0
 797       gcorr3_turn_max=0.0d0
 798       gcorr4_turn_max=0.0d0
 799       gradcorr5_max=0.0d0
 800       gradcorr6_max=0.0d0
 801       gcorr6_turn_max=0.0d0
 802       gsccorc_max=0.0d0
 803       gscloc_max=0.0d0
 804       gvdwx_max=0.0d0
 805       gradx_scp_max=0.0d0
 806       ghpbx_max=0.0d0
 807       gradxorr_max=0.0d0
 808       gsccorx_max=0.0d0
 809       gsclocx_max=0.0d0
 810       do i=1,nct
 811         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 812         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 813         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 814         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 815      &   gvdwc_scp_max=gvdwc_scp_norm
 816         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 817         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 818         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 819         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 820         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 821         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 822         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 823         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 824         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 825         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 826         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 827         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 828         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 829      &    gcorr3_turn(1,i)))
 830         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 831      &    gcorr3_turn_max=gcorr3_turn_norm
 832         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 833      &    gcorr4_turn(1,i)))
 834         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 835      &    gcorr4_turn_max=gcorr4_turn_norm
 836         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 837         if (gradcorr5_norm.gt.gradcorr5_max)
 838      &    gradcorr5_max=gradcorr5_norm
 839         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 840         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 841         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 842      &    gcorr6_turn(1,i)))
 843         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 844      &    gcorr6_turn_max=gcorr6_turn_norm
 845         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 846         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 847         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 848         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 849         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 850         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 851         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 852         if (gradx_scp_norm.gt.gradx_scp_max)
 853      &    gradx_scp_max=gradx_scp_norm
 854         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 855         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 856         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 857         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 858         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 859         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 860         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 861         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 862       enddo
 863       if (gradout) then
 864 #ifdef AIX
 865         open(istat,file=statname,position="append")
 866 #else
 867         open(istat,file=statname,access="append")
 868 #endif
 869         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 870      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 871      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 872      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 873      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 874      &     gsccorx_max,gsclocx_max
 875         close(istat)
 876         if (gvdwc_max.gt.1.0d4) then
 877           write (iout,*) "gvdwc gvdwx gradb gradbx"
 878           do i=nnt,nct
 879             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 880      &        gradb(j,i),gradbx(j,i),j=1,3)
 881           enddo
 882           call pdbout(0.0d0,'cipiszcze',iout)
 883           call flush(iout)
 884         endif
 885       endif
 886       endif
 887 #ifdef DEBUG
 888       write (iout,*) "gradc gradx gloc"
 889       do i=1,nres
 890         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 891      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 892       enddo
 893 #endif
 894 #ifdef TIMING
 895       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 896 #endif
 897       return
 898       end
 899 c-------------------------------------------------------------------------------
 900       subroutine rescale_weights(t_bath)
 901       implicit real*8 (a-h,o-z)
 902       include 'DIMENSIONS'
 903       include 'COMMON.IOUNITS'
 904       include 'COMMON.FFIELD'
 905       include 'COMMON.SBRIDGE'
 906       double precision kfac /2.4d0/
 907       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 908 c      facT=temp0/t_bath
 909 c      facT=2*temp0/(t_bath+temp0)
 910       if (rescale_mode.eq.0) then
 911         facT=1.0d0
 912         facT2=1.0d0
 913         facT3=1.0d0
 914         facT4=1.0d0
 915         facT5=1.0d0
 916       else if (rescale_mode.eq.1) then
 917         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 918         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 919         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 920         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 921         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 922       else if (rescale_mode.eq.2) then
 923         x=t_bath/temp0
 924         x2=x*x
 925         x3=x2*x
 926         x4=x3*x
 927         x5=x4*x
 928         facT=licznik/dlog(dexp(x)+dexp(-x))
 929         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 930         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 931         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 932         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 933       else
 934         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 935         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 936 #ifdef MPI
 937        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 938 #endif
 939        stop 555
 940       endif
 941       welec=weights(3)*fact
 942       wcorr=weights(4)*fact3
 943       wcorr5=weights(5)*fact4
 944       wcorr6=weights(6)*fact5
 945       wel_loc=weights(7)*fact2
 946       wturn3=weights(8)*fact2
 947       wturn4=weights(9)*fact3
 948       wturn6=weights(10)*fact5
 949       wtor=weights(13)*fact
 950       wtor_d=weights(14)*fact2
 951       wsccor=weights(21)*fact
 952
 953       return
 954       end
 955 C------------------------------------------------------------------------
 956       subroutine enerprint(energia)
 957       implicit real*8 (a-h,o-z)
 958       include 'DIMENSIONS'
 959       include 'COMMON.IOUNITS'
 960       include 'COMMON.FFIELD'
 961       include 'COMMON.SBRIDGE'
 962       include 'COMMON.MD'
 963       double precision energia(0:n_ene)
 964       etot=energia(0)
 965       evdw=energia(1)
 966       evdw2=energia(2)
 967 #ifdef SCP14
 968       evdw2=energia(2)+energia(18)
 969 #else
 970       evdw2=energia(2)
 971 #endif
 972       ees=energia(3)
 973 #ifdef SPLITELE
 974       evdw1=energia(16)
 975 #endif
 976       ecorr=energia(4)
 977       ecorr5=energia(5)
 978       ecorr6=energia(6)
 979       eel_loc=energia(7)
 980       eello_turn3=energia(8)
 981       eello_turn4=energia(9)
 982       eello_turn6=energia(10)
 983       ebe=energia(11)
 984       escloc=energia(12)
 985       etors=energia(13)
 986       etors_d=energia(14)
 987       ehpb=energia(15)
 988       edihcnstr=energia(19)
 989       estr=energia(17)
 990       Uconst=energia(20)
 991       esccor=energia(21)
 992       eliptran=energia(22)
 993 #ifdef SPLITELE
 994       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 995      &  estr,wbond,ebe,wang,
 996      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 997      &  ecorr,wcorr,
 998      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 999      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1000      &  edihcnstr,ebr*nss,
1001      &  Uconst,eliptran,wliptran,etot
1002    10 format (/'Virtual-chain energies:'//
1003      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1004      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1005      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1006      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1007      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1008      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1009      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1010      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1011      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1012      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1013      & ' (SS bridges & dist. cnstr.)'/
1014      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1015      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1016      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1017      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1018      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1019      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1020      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1021      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1022      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1023      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1024      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1025      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1026      & 'ETOT=  ',1pE16.6,' (total)')
1027 #else
1028       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1029      &  estr,wbond,ebe,wang,
1030      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1031      &  ecorr,wcorr,
1032      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1033      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1034      &  ebr*nss,Uconst,eliptran,wliptran,etot
1035    10 format (/'Virtual-chain energies:'//
1036      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1037      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1038      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1039      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1040      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1041      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1042      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1043      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1044      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1045      & ' (SS bridges & dist. cnstr.)'/
1046      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1047      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1048      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1049      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1050      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1051      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1052      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1053      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1054      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1055      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1056      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1057      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1058      & 'ETOT=  ',1pE16.6,' (total)')
1059 #endif
1060       return
1061       end
1062 C-----------------------------------------------------------------------
1063       subroutine elj(evdw)
1064 C
1065 C This subroutine calculates the interaction energy of nonbonded side chains
1066 C assuming the LJ potential of interaction.
1067 C
1068       implicit real*8 (a-h,o-z)
1069       include 'DIMENSIONS'
1070       parameter (accur=1.0d-10)
1071       include 'COMMON.GEO'
1072       include 'COMMON.VAR'
1073       include 'COMMON.LOCAL'
1074       include 'COMMON.CHAIN'
1075       include 'COMMON.DERIV'
1076       include 'COMMON.INTERACT'
1077       include 'COMMON.TORSION'
1078       include 'COMMON.SBRIDGE'
1079       include 'COMMON.NAMES'
1080       include 'COMMON.IOUNITS'
1081       include 'COMMON.CONTACTS'
1082       dimension gg(3)
1083 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1084       evdw=0.0D0
1085       do i=iatsc_s,iatsc_e
1086         itypi=iabs(itype(i))
1087         if (itypi.eq.ntyp1) cycle
1088         itypi1=iabs(itype(i+1))
1089         xi=c(1,nres+i)
1090         yi=c(2,nres+i)
1091         zi=c(3,nres+i)
1092 C Change 12/1/95
1093         num_conti=0
1094 C
1095 C Calculate SC interaction energy.
1096 C
1097         do iint=1,nint_gr(i)
1098 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1099 cd   &                  'iend=',iend(i,iint)
1100           do j=istart(i,iint),iend(i,iint)
1101             itypj=iabs(itype(j))
1102             if (itypj.eq.ntyp1) cycle
1103             xj=c(1,nres+j)-xi
1104             yj=c(2,nres+j)-yi
1105             zj=c(3,nres+j)-zi
1106 C Change 12/1/95 to calculate four-body interactions
1107             rij=xj*xj+yj*yj+zj*zj
1108             rrij=1.0D0/rij
1109 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1110             eps0ij=eps(itypi,itypj)
1111             fac=rrij**expon2
1112 C have you changed here?
1113             e1=fac*fac*aa(itypi,itypj)
1114             e2=fac*bb(itypi,itypj)
1115             evdwij=e1+e2
1116 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1117 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1118 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1119 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1120 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1121 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1122             evdw=evdw+evdwij
1123 C
1124 C Calculate the components of the gradient in DC and X
1125 C
1126             fac=-rrij*(e1+evdwij)
1127             gg(1)=xj*fac
1128             gg(2)=yj*fac
1129             gg(3)=zj*fac
1130             do k=1,3
1131               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1132               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1133               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1134               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1135             enddo
1136 cgrad            do k=i,j-1
1137 cgrad              do l=1,3
1138 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1139 cgrad              enddo
1140 cgrad            enddo
1141 C
1142 C 12/1/95, revised on 5/20/97
1143 C
1144 C Calculate the contact function. The ith column of the array JCONT will
1145 C contain the numbers of atoms that make contacts with the atom I (of numbers
1146 C greater than I). The arrays FACONT and GACONT will contain the values of
1147 C the contact function and its derivative.
1148 C
1149 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1150 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1151 C Uncomment next line, if the correlation interactions are contact function only
1152             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1153               rij=dsqrt(rij)
1154               sigij=sigma(itypi,itypj)
1155               r0ij=rs0(itypi,itypj)
1156 C
1157 C Check whether the SC's are not too far to make a contact.
1158 C
1159               rcut=1.5d0*r0ij
1160               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1161 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1162 C
1163               if (fcont.gt.0.0D0) then
1164 C If the SC-SC distance if close to sigma, apply spline.
1165 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1166 cAdam &             fcont1,fprimcont1)
1167 cAdam           fcont1=1.0d0-fcont1
1168 cAdam           if (fcont1.gt.0.0d0) then
1169 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1170 cAdam             fcont=fcont*fcont1
1171 cAdam           endif
1172 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1173 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1174 cga             do k=1,3
1175 cga               gg(k)=gg(k)*eps0ij
1176 cga             enddo
1177 cga             eps0ij=-evdwij*eps0ij
1178 C Uncomment for AL's type of SC correlation interactions.
1179 cadam           eps0ij=-evdwij
1180                 num_conti=num_conti+1
1181                 jcont(num_conti,i)=j
1182                 facont(num_conti,i)=fcont*eps0ij
1183                 fprimcont=eps0ij*fprimcont/rij
1184                 fcont=expon*fcont
1185 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1186 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1187 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1188 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1189                 gacont(1,num_conti,i)=-fprimcont*xj
1190                 gacont(2,num_conti,i)=-fprimcont*yj
1191                 gacont(3,num_conti,i)=-fprimcont*zj
1192 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1193 cd              write (iout,'(2i3,3f10.5)')
1194 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1195               endif
1196             endif
1197           enddo      ! j
1198         enddo        ! iint
1199 C Change 12/1/95
1200         num_cont(i)=num_conti
1201       enddo          ! i
1202       do i=1,nct
1203         do j=1,3
1204           gvdwc(j,i)=expon*gvdwc(j,i)
1205           gvdwx(j,i)=expon*gvdwx(j,i)
1206         enddo
1207       enddo
1208 C******************************************************************************
1209 C
1210 C                              N O T E !!!
1211 C
1212 C To save time, the factor of EXPON has been extracted from ALL components
1213 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1214 C use!
1215 C
1216 C******************************************************************************
1217       return
1218       end
1219 C-----------------------------------------------------------------------------
1220       subroutine eljk(evdw)
1221 C
1222 C This subroutine calculates the interaction energy of nonbonded side chains
1223 C assuming the LJK potential of interaction.
1224 C
1225       implicit real*8 (a-h,o-z)
1226       include 'DIMENSIONS'
1227       include 'COMMON.GEO'
1228       include 'COMMON.VAR'
1229       include 'COMMON.LOCAL'
1230       include 'COMMON.CHAIN'
1231       include 'COMMON.DERIV'
1232       include 'COMMON.INTERACT'
1233       include 'COMMON.IOUNITS'
1234       include 'COMMON.NAMES'
1235       dimension gg(3)
1236       logical scheck
1237 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1238       evdw=0.0D0
1239       do i=iatsc_s,iatsc_e
1240         itypi=iabs(itype(i))
1241         if (itypi.eq.ntyp1) cycle
1242         itypi1=iabs(itype(i+1))
1243         xi=c(1,nres+i)
1244         yi=c(2,nres+i)
1245         zi=c(3,nres+i)
1246 C
1247 C Calculate SC interaction energy.
1248 C
1249         do iint=1,nint_gr(i)
1250           do j=istart(i,iint),iend(i,iint)
1251             itypj=iabs(itype(j))
1252             if (itypj.eq.ntyp1) cycle
1253             xj=c(1,nres+j)-xi
1254             yj=c(2,nres+j)-yi
1255             zj=c(3,nres+j)-zi
1256             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1257             fac_augm=rrij**expon
1258             e_augm=augm(itypi,itypj)*fac_augm
1259             r_inv_ij=dsqrt(rrij)
1260             rij=1.0D0/r_inv_ij
1261             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1262             fac=r_shift_inv**expon
1263 C have you changed here?
1264             e1=fac*fac*aa(itypi,itypj)
1265             e2=fac*bb(itypi,itypj)
1266             evdwij=e_augm+e1+e2
1267 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1268 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1269 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1270 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1271 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1272 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1273 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1274             evdw=evdw+evdwij
1275 C
1276 C Calculate the components of the gradient in DC and X
1277 C
1278             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1279             gg(1)=xj*fac
1280             gg(2)=yj*fac
1281             gg(3)=zj*fac
1282             do k=1,3
1283               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1284               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1285               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1286               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1287             enddo
1288 cgrad            do k=i,j-1
1289 cgrad              do l=1,3
1290 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1291 cgrad              enddo
1292 cgrad            enddo
1293           enddo      ! j
1294         enddo        ! iint
1295       enddo          ! i
1296       do i=1,nct
1297         do j=1,3
1298           gvdwc(j,i)=expon*gvdwc(j,i)
1299           gvdwx(j,i)=expon*gvdwx(j,i)
1300         enddo
1301       enddo
1302       return
1303       end
1304 C-----------------------------------------------------------------------------
1305       subroutine ebp(evdw)
1306 C
1307 C This subroutine calculates the interaction energy of nonbonded side chains
1308 C assuming the Berne-Pechukas potential of interaction.
1309 C
1310       implicit real*8 (a-h,o-z)
1311       include 'DIMENSIONS'
1312       include 'COMMON.GEO'
1313       include 'COMMON.VAR'
1314       include 'COMMON.LOCAL'
1315       include 'COMMON.CHAIN'
1316       include 'COMMON.DERIV'
1317       include 'COMMON.NAMES'
1318       include 'COMMON.INTERACT'
1319       include 'COMMON.IOUNITS'
1320       include 'COMMON.CALC'
1321       common /srutu/ icall
1322 c     double precision rrsave(maxdim)
1323       logical lprn
1324       evdw=0.0D0
1325 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1326       evdw=0.0D0
1327 c     if (icall.eq.0) then
1328 c       lprn=.true.
1329 c     else
1330         lprn=.false.
1331 c     endif
1332       ind=0
1333       do i=iatsc_s,iatsc_e
1334         itypi=iabs(itype(i))
1335         if (itypi.eq.ntyp1) cycle
1336         itypi1=iabs(itype(i+1))
1337         xi=c(1,nres+i)
1338         yi=c(2,nres+i)
1339         zi=c(3,nres+i)
1340         dxi=dc_norm(1,nres+i)
1341         dyi=dc_norm(2,nres+i)
1342         dzi=dc_norm(3,nres+i)
1343 c        dsci_inv=dsc_inv(itypi)
1344         dsci_inv=vbld_inv(i+nres)
1345 C
1346 C Calculate SC interaction energy.
1347 C
1348         do iint=1,nint_gr(i)
1349           do j=istart(i,iint),iend(i,iint)
1350             ind=ind+1
1351             itypj=iabs(itype(j))
1352             if (itypj.eq.ntyp1) cycle
1353 c            dscj_inv=dsc_inv(itypj)
1354             dscj_inv=vbld_inv(j+nres)
1355             chi1=chi(itypi,itypj)
1356             chi2=chi(itypj,itypi)
1357             chi12=chi1*chi2
1358             chip1=chip(itypi)
1359             chip2=chip(itypj)
1360             chip12=chip1*chip2
1361             alf1=alp(itypi)
1362             alf2=alp(itypj)
1363             alf12=0.5D0*(alf1+alf2)
1364 C For diagnostics only!!!
1365 c           chi1=0.0D0
1366 c           chi2=0.0D0
1367 c           chi12=0.0D0
1368 c           chip1=0.0D0
1369 c           chip2=0.0D0
1370 c           chip12=0.0D0
1371 c           alf1=0.0D0
1372 c           alf2=0.0D0
1373 c           alf12=0.0D0
1374             xj=c(1,nres+j)-xi
1375             yj=c(2,nres+j)-yi
1376             zj=c(3,nres+j)-zi
1377             dxj=dc_norm(1,nres+j)
1378             dyj=dc_norm(2,nres+j)
1379             dzj=dc_norm(3,nres+j)
1380             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1381 cd          if (icall.eq.0) then
1382 cd            rrsave(ind)=rrij
1383 cd          else
1384 cd            rrij=rrsave(ind)
1385 cd          endif
1386             rij=dsqrt(rrij)
1387 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1388             call sc_angular
1389 C Calculate whole angle-dependent part of epsilon and contributions
1390 C to its derivatives
1391 C have you changed here?
1392             fac=(rrij*sigsq)**expon2
1393             e1=fac*fac*aa(itypi,itypj)
1394             e2=fac*bb(itypi,itypj)
1395             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1396             eps2der=evdwij*eps3rt
1397             eps3der=evdwij*eps2rt
1398             evdwij=evdwij*eps2rt*eps3rt
1399             evdw=evdw+evdwij
1400             if (lprn) then
1401             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1402             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1403 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1404 cd     &        restyp(itypi),i,restyp(itypj),j,
1405 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1406 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1407 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1408 cd     &        evdwij
1409             endif
1410 C Calculate gradient components.
1411             e1=e1*eps1*eps2rt**2*eps3rt**2
1412             fac=-expon*(e1+evdwij)
1413             sigder=fac/sigsq
1414             fac=rrij*fac
1415 C Calculate radial part of the gradient
1416             gg(1)=xj*fac
1417             gg(2)=yj*fac
1418             gg(3)=zj*fac
1419 C Calculate the angular part of the gradient and sum add the contributions
1420 C to the appropriate components of the Cartesian gradient.
1421             call sc_grad
1422           enddo      ! j
1423         enddo        ! iint
1424       enddo          ! i
1425 c     stop
1426       return
1427       end
1428 C-----------------------------------------------------------------------------
1429       subroutine egb(evdw)
1430 C
1431 C This subroutine calculates the interaction energy of nonbonded side chains
1432 C assuming the Gay-Berne potential of interaction.
1433 C
1434       implicit real*8 (a-h,o-z)
1435       include 'DIMENSIONS'
1436       include 'COMMON.GEO'
1437       include 'COMMON.VAR'
1438       include 'COMMON.LOCAL'
1439       include 'COMMON.CHAIN'
1440       include 'COMMON.DERIV'
1441       include 'COMMON.NAMES'
1442       include 'COMMON.INTERACT'
1443       include 'COMMON.IOUNITS'
1444       include 'COMMON.CALC'
1445       include 'COMMON.CONTROL'
1446       include 'COMMON.SPLITELE'
1447       include 'COMMON.SBRIDGE'
1448       logical lprn
1449       integer xshift,yshift,zshift
1450       evdw=0.0D0
1451 ccccc      energy_dec=.false.
1452 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1453       evdw=0.0D0
1454       lprn=.false.
1455 c     if (icall.eq.0) lprn=.false.
1456       ind=0
1457 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1458 C we have the original box)
1459 C      do xshift=-1,1
1460 C      do yshift=-1,1
1461 C      do zshift=-1,1
1462       do i=iatsc_s,iatsc_e
1463         itypi=iabs(itype(i))
1464         if (itypi.eq.ntyp1) cycle
1465         itypi1=iabs(itype(i+1))
1466         xi=c(1,nres+i)
1467         yi=c(2,nres+i)
1468         zi=c(3,nres+i)
1469 C Return atom into box, boxxsize is size of box in x dimension
1470 c  134   continue
1471 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1472 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1473 C Condition for being inside the proper box
1474 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1475 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1476 c        go to 134
1477 c        endif
1478 c  135   continue
1479 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1480 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1481 C Condition for being inside the proper box
1482 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1483 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1484 c        go to 135
1485 c        endif
1486 c  136   continue
1487 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1488 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1489 C Condition for being inside the proper box
1490 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1491 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1492 c        go to 136
1493 c        endif
1494           xi=mod(xi,boxxsize)
1495           if (xi.lt.0) xi=xi+boxxsize
1496           yi=mod(yi,boxysize)
1497           if (yi.lt.0) yi=yi+boxysize
1498           zi=mod(zi,boxzsize)
1499           if (zi.lt.0) zi=zi+boxzsize
1500 C          xi=xi+xshift*boxxsize
1501 C          yi=yi+yshift*boxysize
1502 C          zi=zi+zshift*boxzsize
1503
1504         dxi=dc_norm(1,nres+i)
1505         dyi=dc_norm(2,nres+i)
1506         dzi=dc_norm(3,nres+i)
1507 c        dsci_inv=dsc_inv(itypi)
1508         dsci_inv=vbld_inv(i+nres)
1509 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1510 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1511 C
1512 C Calculate SC interaction energy.
1513 C
1514         do iint=1,nint_gr(i)
1515           do j=istart(i,iint),iend(i,iint)
1516             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1517               call dyn_ssbond_ene(i,j,evdwij)
1518               evdw=evdw+evdwij
1519               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1520      &                        'evdw',i,j,evdwij,' ss'
1521             ELSE
1522             ind=ind+1
1523             itypj=iabs(itype(j))
1524             if (itypj.eq.ntyp1) cycle
1525 c            dscj_inv=dsc_inv(itypj)
1526             dscj_inv=vbld_inv(j+nres)
1527 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1528 c     &       1.0d0/vbld(j+nres)
1529 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1530             sig0ij=sigma(itypi,itypj)
1531             chi1=chi(itypi,itypj)
1532             chi2=chi(itypj,itypi)
1533             chi12=chi1*chi2
1534             chip1=chip(itypi)
1535             chip2=chip(itypj)
1536             chip12=chip1*chip2
1537             alf1=alp(itypi)
1538             alf2=alp(itypj)
1539             alf12=0.5D0*(alf1+alf2)
1540 C For diagnostics only!!!
1541 c           chi1=0.0D0
1542 c           chi2=0.0D0
1543 c           chi12=0.0D0
1544 c           chip1=0.0D0
1545 c           chip2=0.0D0
1546 c           chip12=0.0D0
1547 c           alf1=0.0D0
1548 c           alf2=0.0D0
1549 c           alf12=0.0D0
1550             xj=c(1,nres+j)
1551             yj=c(2,nres+j)
1552             zj=c(3,nres+j)
1553 C Return atom J into box the original box
1554 c  137   continue
1555 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1556 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1557 C Condition for being inside the proper box
1558 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1559 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1560 c        go to 137
1561 c        endif
1562 c  138   continue
1563 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1564 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1565 C Condition for being inside the proper box
1566 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1567 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1568 c        go to 138
1569 c        endif
1570 c  139   continue
1571 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1572 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1573 C Condition for being inside the proper box
1574 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1575 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1576 c        go to 139
1577 c        endif
1578           xj=mod(xj,boxxsize)
1579           if (xj.lt.0) xj=xj+boxxsize
1580           yj=mod(yj,boxysize)
1581           if (yj.lt.0) yj=yj+boxysize
1582           zj=mod(zj,boxzsize)
1583           if (zj.lt.0) zj=zj+boxzsize
1584       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1585       xj_safe=xj
1586       yj_safe=yj
1587       zj_safe=zj
1588       subchap=0
1589       do xshift=-1,1
1590       do yshift=-1,1
1591       do zshift=-1,1
1592           xj=xj_safe+xshift*boxxsize
1593           yj=yj_safe+yshift*boxysize
1594           zj=zj_safe+zshift*boxzsize
1595           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1596           if(dist_temp.lt.dist_init) then
1597             dist_init=dist_temp
1598             xj_temp=xj
1599             yj_temp=yj
1600             zj_temp=zj
1601             subchap=1
1602           endif
1603        enddo
1604        enddo
1605        enddo
1606        if (subchap.eq.1) then
1607           xj=xj_temp-xi
1608           yj=yj_temp-yi
1609           zj=zj_temp-zi
1610        else
1611           xj=xj_safe-xi
1612           yj=yj_safe-yi
1613           zj=zj_safe-zi
1614        endif
1615             dxj=dc_norm(1,nres+j)
1616             dyj=dc_norm(2,nres+j)
1617             dzj=dc_norm(3,nres+j)
1618 C            xj=xj-xi
1619 C            yj=yj-yi
1620 C            zj=zj-zi
1621 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1622 c            write (iout,*) "j",j," dc_norm",
1623 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1624             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1625             rij=dsqrt(rrij)
1626             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1627             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1628
1629 c            write (iout,'(a7,4f8.3)')
1630 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1631             if (sss.gt.0.0d0) then
1632 C Calculate angle-dependent terms of energy and contributions to their
1633 C derivatives.
1634             call sc_angular
1635             sigsq=1.0D0/sigsq
1636             sig=sig0ij*dsqrt(sigsq)
1637             rij_shift=1.0D0/rij-sig+sig0ij
1638 c for diagnostics; uncomment
1639 c            rij_shift=1.2*sig0ij
1640 C I hate to put IF's in the loops, but here don't have another choice!!!!
1641             if (rij_shift.le.0.0D0) then
1642               evdw=1.0D20
1643 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1644 cd     &        restyp(itypi),i,restyp(itypj),j,
1645 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1646               return
1647             endif
1648             sigder=-sig*sigsq
1649 c---------------------------------------------------------------
1650             rij_shift=1.0D0/rij_shift
1651             fac=rij_shift**expon
1652 C here to start with
1653 C            if (c(i,3).gt.
1654             e1=fac*fac*aa(itypi,itypj)
1655             e2=fac*bb(itypi,itypj)
1656             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1657             eps2der=evdwij*eps3rt
1658             eps3der=evdwij*eps2rt
1659 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1660 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1661             evdwij=evdwij*eps2rt*eps3rt
1662             evdw=evdw+evdwij*sss
1663             if (lprn) then
1664             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1665             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1666             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1667      &        restyp(itypi),i,restyp(itypj),j,
1668      &        epsi,sigm,chi1,chi2,chip1,chip2,
1669      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1670      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1671      &        evdwij
1672             endif
1673
1674             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1675      &                        'evdw',i,j,evdwij
1676
1677 C Calculate gradient components.
1678             e1=e1*eps1*eps2rt**2*eps3rt**2
1679             fac=-expon*(e1+evdwij)*rij_shift
1680             sigder=fac*sigder
1681             fac=rij*fac
1682 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1683 c     &      evdwij,fac,sigma(itypi,itypj),expon
1684             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1685 c            fac=0.0d0
1686 C Calculate the radial part of the gradient
1687             gg(1)=xj*fac
1688             gg(2)=yj*fac
1689             gg(3)=zj*fac
1690 C Calculate angular part of the gradient.
1691             call sc_grad
1692             endif
1693             ENDIF    ! dyn_ss
1694           enddo      ! j
1695         enddo        ! iint
1696       enddo          ! i
1697 C      enddo          ! zshift
1698 C      enddo          ! yshift
1699 C      enddo          ! xshift
1700 c      write (iout,*) "Number of loop steps in EGB:",ind
1701 cccc      energy_dec=.false.
1702       return
1703       end
1704 C-----------------------------------------------------------------------------
1705       subroutine egbv(evdw)
1706 C
1707 C This subroutine calculates the interaction energy of nonbonded side chains
1708 C assuming the Gay-Berne-Vorobjev potential of interaction.
1709 C
1710       implicit real*8 (a-h,o-z)
1711       include 'DIMENSIONS'
1712       include 'COMMON.GEO'
1713       include 'COMMON.VAR'
1714       include 'COMMON.LOCAL'
1715       include 'COMMON.CHAIN'
1716       include 'COMMON.DERIV'
1717       include 'COMMON.NAMES'
1718       include 'COMMON.INTERACT'
1719       include 'COMMON.IOUNITS'
1720       include 'COMMON.CALC'
1721       common /srutu/ icall
1722       logical lprn
1723       evdw=0.0D0
1724 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1725       evdw=0.0D0
1726       lprn=.false.
1727 c     if (icall.eq.0) lprn=.true.
1728       ind=0
1729       do i=iatsc_s,iatsc_e
1730         itypi=iabs(itype(i))
1731         if (itypi.eq.ntyp1) cycle
1732         itypi1=iabs(itype(i+1))
1733         xi=c(1,nres+i)
1734         yi=c(2,nres+i)
1735         zi=c(3,nres+i)
1736         dxi=dc_norm(1,nres+i)
1737         dyi=dc_norm(2,nres+i)
1738         dzi=dc_norm(3,nres+i)
1739 c        dsci_inv=dsc_inv(itypi)
1740         dsci_inv=vbld_inv(i+nres)
1741 C
1742 C Calculate SC interaction energy.
1743 C
1744         do iint=1,nint_gr(i)
1745           do j=istart(i,iint),iend(i,iint)
1746             ind=ind+1
1747             itypj=iabs(itype(j))
1748             if (itypj.eq.ntyp1) cycle
1749 c            dscj_inv=dsc_inv(itypj)
1750             dscj_inv=vbld_inv(j+nres)
1751             sig0ij=sigma(itypi,itypj)
1752             r0ij=r0(itypi,itypj)
1753             chi1=chi(itypi,itypj)
1754             chi2=chi(itypj,itypi)
1755             chi12=chi1*chi2
1756             chip1=chip(itypi)
1757             chip2=chip(itypj)
1758             chip12=chip1*chip2
1759             alf1=alp(itypi)
1760             alf2=alp(itypj)
1761             alf12=0.5D0*(alf1+alf2)
1762 C For diagnostics only!!!
1763 c           chi1=0.0D0
1764 c           chi2=0.0D0
1765 c           chi12=0.0D0
1766 c           chip1=0.0D0
1767 c           chip2=0.0D0
1768 c           chip12=0.0D0
1769 c           alf1=0.0D0
1770 c           alf2=0.0D0
1771 c           alf12=0.0D0
1772             xj=c(1,nres+j)-xi
1773             yj=c(2,nres+j)-yi
1774             zj=c(3,nres+j)-zi
1775             dxj=dc_norm(1,nres+j)
1776             dyj=dc_norm(2,nres+j)
1777             dzj=dc_norm(3,nres+j)
1778             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1779             rij=dsqrt(rrij)
1780 C Calculate angle-dependent terms of energy and contributions to their
1781 C derivatives.
1782             call sc_angular
1783             sigsq=1.0D0/sigsq
1784             sig=sig0ij*dsqrt(sigsq)
1785             rij_shift=1.0D0/rij-sig+r0ij
1786 C I hate to put IF's in the loops, but here don't have another choice!!!!
1787             if (rij_shift.le.0.0D0) then
1788               evdw=1.0D20
1789               return
1790             endif
1791             sigder=-sig*sigsq
1792 c---------------------------------------------------------------
1793             rij_shift=1.0D0/rij_shift
1794             fac=rij_shift**expon
1795             e1=fac*fac*aa(itypi,itypj)
1796             e2=fac*bb(itypi,itypj)
1797             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1798             eps2der=evdwij*eps3rt
1799             eps3der=evdwij*eps2rt
1800             fac_augm=rrij**expon
1801             e_augm=augm(itypi,itypj)*fac_augm
1802             evdwij=evdwij*eps2rt*eps3rt
1803             evdw=evdw+evdwij+e_augm
1804             if (lprn) then
1805             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1806             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1807             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1808      &        restyp(itypi),i,restyp(itypj),j,
1809      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1810      &        chi1,chi2,chip1,chip2,
1811      &        eps1,eps2rt**2,eps3rt**2,
1812      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1813      &        evdwij+e_augm
1814             endif
1815 C Calculate gradient components.
1816             e1=e1*eps1*eps2rt**2*eps3rt**2
1817             fac=-expon*(e1+evdwij)*rij_shift
1818             sigder=fac*sigder
1819             fac=rij*fac-2*expon*rrij*e_augm
1820 C Calculate the radial part of the gradient
1821             gg(1)=xj*fac
1822             gg(2)=yj*fac
1823             gg(3)=zj*fac
1824 C Calculate angular part of the gradient.
1825             call sc_grad
1826           enddo      ! j
1827         enddo        ! iint
1828       enddo          ! i
1829       end
1830 C-----------------------------------------------------------------------------
1831       subroutine sc_angular
1832 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1833 C om12. Called by ebp, egb, and egbv.
1834       implicit none
1835       include 'COMMON.CALC'
1836       include 'COMMON.IOUNITS'
1837       erij(1)=xj*rij
1838       erij(2)=yj*rij
1839       erij(3)=zj*rij
1840       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1841       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1842       om12=dxi*dxj+dyi*dyj+dzi*dzj
1843       chiom12=chi12*om12
1844 C Calculate eps1(om12) and its derivative in om12
1845       faceps1=1.0D0-om12*chiom12
1846       faceps1_inv=1.0D0/faceps1
1847       eps1=dsqrt(faceps1_inv)
1848 C Following variable is eps1*deps1/dom12
1849       eps1_om12=faceps1_inv*chiom12
1850 c diagnostics only
1851 c      faceps1_inv=om12
1852 c      eps1=om12
1853 c      eps1_om12=1.0d0
1854 c      write (iout,*) "om12",om12," eps1",eps1
1855 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1856 C and om12.
1857       om1om2=om1*om2
1858       chiom1=chi1*om1
1859       chiom2=chi2*om2
1860       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1861       sigsq=1.0D0-facsig*faceps1_inv
1862       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1863       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1864       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1865 c diagnostics only
1866 c      sigsq=1.0d0
1867 c      sigsq_om1=0.0d0
1868 c      sigsq_om2=0.0d0
1869 c      sigsq_om12=0.0d0
1870 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1871 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1872 c     &    " eps1",eps1
1873 C Calculate eps2 and its derivatives in om1, om2, and om12.
1874       chipom1=chip1*om1
1875       chipom2=chip2*om2
1876       chipom12=chip12*om12
1877       facp=1.0D0-om12*chipom12
1878       facp_inv=1.0D0/facp
1879       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1880 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1881 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1882 C Following variable is the square root of eps2
1883       eps2rt=1.0D0-facp1*facp_inv
1884 C Following three variables are the derivatives of the square root of eps
1885 C in om1, om2, and om12.
1886       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1887       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1888       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1889 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1890       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1891 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1892 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1893 c     &  " eps2rt_om12",eps2rt_om12
1894 C Calculate whole angle-dependent part of epsilon and contributions
1895 C to its derivatives
1896       return
1897       end
1898 C----------------------------------------------------------------------------
1899       subroutine sc_grad
1900       implicit real*8 (a-h,o-z)
1901       include 'DIMENSIONS'
1902       include 'COMMON.CHAIN'
1903       include 'COMMON.DERIV'
1904       include 'COMMON.CALC'
1905       include 'COMMON.IOUNITS'
1906       double precision dcosom1(3),dcosom2(3)
1907 cc      print *,'sss=',sss
1908       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1909       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1910       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1911      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1912 c diagnostics only
1913 c      eom1=0.0d0
1914 c      eom2=0.0d0
1915 c      eom12=evdwij*eps1_om12
1916 c end diagnostics
1917 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1918 c     &  " sigder",sigder
1919 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1920 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1921       do k=1,3
1922         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1923         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1924       enddo
1925       do k=1,3
1926         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1927       enddo
1928 c      write (iout,*) "gg",(gg(k),k=1,3)
1929       do k=1,3
1930         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1931      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1932      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1933         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1934      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1935      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1936 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1937 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1938 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1939 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1940       enddo
1941 C
1942 C Calculate the components of the gradient in DC and X
1943 C
1944 cgrad      do k=i,j-1
1945 cgrad        do l=1,3
1946 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1947 cgrad        enddo
1948 cgrad      enddo
1949       do l=1,3
1950         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1951         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1952       enddo
1953       return
1954       end
1955 C-----------------------------------------------------------------------
1956       subroutine e_softsphere(evdw)
1957 C
1958 C This subroutine calculates the interaction energy of nonbonded side chains
1959 C assuming the LJ potential of interaction.
1960 C
1961       implicit real*8 (a-h,o-z)
1962       include 'DIMENSIONS'
1963       parameter (accur=1.0d-10)
1964       include 'COMMON.GEO'
1965       include 'COMMON.VAR'
1966       include 'COMMON.LOCAL'
1967       include 'COMMON.CHAIN'
1968       include 'COMMON.DERIV'
1969       include 'COMMON.INTERACT'
1970       include 'COMMON.TORSION'
1971       include 'COMMON.SBRIDGE'
1972       include 'COMMON.NAMES'
1973       include 'COMMON.IOUNITS'
1974       include 'COMMON.CONTACTS'
1975       dimension gg(3)
1976 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1977       evdw=0.0D0
1978       do i=iatsc_s,iatsc_e
1979         itypi=iabs(itype(i))
1980         if (itypi.eq.ntyp1) cycle
1981         itypi1=iabs(itype(i+1))
1982         xi=c(1,nres+i)
1983         yi=c(2,nres+i)
1984         zi=c(3,nres+i)
1985 C
1986 C Calculate SC interaction energy.
1987 C
1988         do iint=1,nint_gr(i)
1989 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1990 cd   &                  'iend=',iend(i,iint)
1991           do j=istart(i,iint),iend(i,iint)
1992             itypj=iabs(itype(j))
1993             if (itypj.eq.ntyp1) cycle
1994             xj=c(1,nres+j)-xi
1995             yj=c(2,nres+j)-yi
1996             zj=c(3,nres+j)-zi
1997             rij=xj*xj+yj*yj+zj*zj
1998 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1999             r0ij=r0(itypi,itypj)
2000             r0ijsq=r0ij*r0ij
2001 c            print *,i,j,r0ij,dsqrt(rij)
2002             if (rij.lt.r0ijsq) then
2003               evdwij=0.25d0*(rij-r0ijsq)**2
2004               fac=rij-r0ijsq
2005             else
2006               evdwij=0.0d0
2007               fac=0.0d0
2008             endif
2009             evdw=evdw+evdwij
2010 C
2011 C Calculate the components of the gradient in DC and X
2012 C
2013             gg(1)=xj*fac
2014             gg(2)=yj*fac
2015             gg(3)=zj*fac
2016             do k=1,3
2017               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2018               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2019               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2020               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2021             enddo
2022 cgrad            do k=i,j-1
2023 cgrad              do l=1,3
2024 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2025 cgrad              enddo
2026 cgrad            enddo
2027           enddo ! j
2028         enddo ! iint
2029       enddo ! i
2030       return
2031       end
2032 C--------------------------------------------------------------------------
2033       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2034      &              eello_turn4)
2035 C
2036 C Soft-sphere potential of p-p interaction
2037 C
2038       implicit real*8 (a-h,o-z)
2039       include 'DIMENSIONS'
2040       include 'COMMON.CONTROL'
2041       include 'COMMON.IOUNITS'
2042       include 'COMMON.GEO'
2043       include 'COMMON.VAR'
2044       include 'COMMON.LOCAL'
2045       include 'COMMON.CHAIN'
2046       include 'COMMON.DERIV'
2047       include 'COMMON.INTERACT'
2048       include 'COMMON.CONTACTS'
2049       include 'COMMON.TORSION'
2050       include 'COMMON.VECTORS'
2051       include 'COMMON.FFIELD'
2052       dimension ggg(3)
2053 C      write(iout,*) 'In EELEC_soft_sphere'
2054       ees=0.0D0
2055       evdw1=0.0D0
2056       eel_loc=0.0d0
2057       eello_turn3=0.0d0
2058       eello_turn4=0.0d0
2059       ind=0
2060       do i=iatel_s,iatel_e
2061         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2062         dxi=dc(1,i)
2063         dyi=dc(2,i)
2064         dzi=dc(3,i)
2065         xmedi=c(1,i)+0.5d0*dxi
2066         ymedi=c(2,i)+0.5d0*dyi
2067         zmedi=c(3,i)+0.5d0*dzi
2068           xmedi=mod(xmedi,boxxsize)
2069           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2070           ymedi=mod(ymedi,boxysize)
2071           if (ymedi.lt.0) ymedi=ymedi+boxysize
2072           zmedi=mod(zmedi,boxzsize)
2073           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2074         num_conti=0
2075 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2076         do j=ielstart(i),ielend(i)
2077           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2078           ind=ind+1
2079           iteli=itel(i)
2080           itelj=itel(j)
2081           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2082           r0ij=rpp(iteli,itelj)
2083           r0ijsq=r0ij*r0ij
2084           dxj=dc(1,j)
2085           dyj=dc(2,j)
2086           dzj=dc(3,j)
2087           xj=c(1,j)+0.5D0*dxj
2088           yj=c(2,j)+0.5D0*dyj
2089           zj=c(3,j)+0.5D0*dzj
2090           xj=mod(xj,boxxsize)
2091           if (xj.lt.0) xj=xj+boxxsize
2092           yj=mod(yj,boxysize)
2093           if (yj.lt.0) yj=yj+boxysize
2094           zj=mod(zj,boxzsize)
2095           if (zj.lt.0) zj=zj+boxzsize
2096       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2097       xj_safe=xj
2098       yj_safe=yj
2099       zj_safe=zj
2100       isubchap=0
2101       do xshift=-1,1
2102       do yshift=-1,1
2103       do zshift=-1,1
2104           xj=xj_safe+xshift*boxxsize
2105           yj=yj_safe+yshift*boxysize
2106           zj=zj_safe+zshift*boxzsize
2107           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2108           if(dist_temp.lt.dist_init) then
2109             dist_init=dist_temp
2110             xj_temp=xj
2111             yj_temp=yj
2112             zj_temp=zj
2113             isubchap=1
2114           endif
2115        enddo
2116        enddo
2117        enddo
2118        if (isubchap.eq.1) then
2119           xj=xj_temp-xmedi
2120           yj=yj_temp-ymedi
2121           zj=zj_temp-zmedi
2122        else
2123           xj=xj_safe-xmedi
2124           yj=yj_safe-ymedi
2125           zj=zj_safe-zmedi
2126        endif
2127           rij=xj*xj+yj*yj+zj*zj
2128             sss=sscale(sqrt(rij))
2129             sssgrad=sscagrad(sqrt(rij))
2130           if (rij.lt.r0ijsq) then
2131             evdw1ij=0.25d0*(rij-r0ijsq)**2
2132             fac=rij-r0ijsq
2133           else
2134             evdw1ij=0.0d0
2135             fac=0.0d0
2136           endif
2137           evdw1=evdw1+evdw1ij*sss
2138 C
2139 C Calculate contributions to the Cartesian gradient.
2140 C
2141           ggg(1)=fac*xj*sssgrad
2142           ggg(2)=fac*yj*sssgrad
2143           ggg(3)=fac*zj*sssgrad
2144           do k=1,3
2145             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2146             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2147           enddo
2148 *
2149 * Loop over residues i+1 thru j-1.
2150 *
2151 cgrad          do k=i+1,j-1
2152 cgrad            do l=1,3
2153 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2154 cgrad            enddo
2155 cgrad          enddo
2156         enddo ! j
2157       enddo   ! i
2158 cgrad      do i=nnt,nct-1
2159 cgrad        do k=1,3
2160 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2161 cgrad        enddo
2162 cgrad        do j=i+1,nct-1
2163 cgrad          do k=1,3
2164 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2165 cgrad          enddo
2166 cgrad        enddo
2167 cgrad      enddo
2168       return
2169       end
2170 c------------------------------------------------------------------------------
2171       subroutine vec_and_deriv
2172       implicit real*8 (a-h,o-z)
2173       include 'DIMENSIONS'
2174 #ifdef MPI
2175       include 'mpif.h'
2176 #endif
2177       include 'COMMON.IOUNITS'
2178       include 'COMMON.GEO'
2179       include 'COMMON.VAR'
2180       include 'COMMON.LOCAL'
2181       include 'COMMON.CHAIN'
2182       include 'COMMON.VECTORS'
2183       include 'COMMON.SETUP'
2184       include 'COMMON.TIME1'
2185       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2186 C Compute the local reference systems. For reference system (i), the
2187 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2188 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2189 #ifdef PARVEC
2190       do i=ivec_start,ivec_end
2191 #else
2192       do i=1,nres-1
2193 #endif
2194           if (i.eq.nres-1) then
2195 C Case of the last full residue
2196 C Compute the Z-axis
2197             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2198             costh=dcos(pi-theta(nres))
2199             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2200             do k=1,3
2201               uz(k,i)=fac*uz(k,i)
2202             enddo
2203 C Compute the derivatives of uz
2204             uzder(1,1,1)= 0.0d0
2205             uzder(2,1,1)=-dc_norm(3,i-1)
2206             uzder(3,1,1)= dc_norm(2,i-1)
2207             uzder(1,2,1)= dc_norm(3,i-1)
2208             uzder(2,2,1)= 0.0d0
2209             uzder(3,2,1)=-dc_norm(1,i-1)
2210             uzder(1,3,1)=-dc_norm(2,i-1)
2211             uzder(2,3,1)= dc_norm(1,i-1)
2212             uzder(3,3,1)= 0.0d0
2213             uzder(1,1,2)= 0.0d0
2214             uzder(2,1,2)= dc_norm(3,i)
2215             uzder(3,1,2)=-dc_norm(2,i)
2216             uzder(1,2,2)=-dc_norm(3,i)
2217             uzder(2,2,2)= 0.0d0
2218             uzder(3,2,2)= dc_norm(1,i)
2219             uzder(1,3,2)= dc_norm(2,i)
2220             uzder(2,3,2)=-dc_norm(1,i)
2221             uzder(3,3,2)= 0.0d0
2222 C Compute the Y-axis
2223             facy=fac
2224             do k=1,3
2225               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2226             enddo
2227 C Compute the derivatives of uy
2228             do j=1,3
2229               do k=1,3
2230                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2231      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2232                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2233               enddo
2234               uyder(j,j,1)=uyder(j,j,1)-costh
2235               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2236             enddo
2237             do j=1,2
2238               do k=1,3
2239                 do l=1,3
2240                   uygrad(l,k,j,i)=uyder(l,k,j)
2241                   uzgrad(l,k,j,i)=uzder(l,k,j)
2242                 enddo
2243               enddo
2244             enddo
2245             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2246             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2247             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2248             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2249           else
2250 C Other residues
2251 C Compute the Z-axis
2252             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2253             costh=dcos(pi-theta(i+2))
2254             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2255             do k=1,3
2256               uz(k,i)=fac*uz(k,i)
2257             enddo
2258 C Compute the derivatives of uz
2259             uzder(1,1,1)= 0.0d0
2260             uzder(2,1,1)=-dc_norm(3,i+1)
2261             uzder(3,1,1)= dc_norm(2,i+1)
2262             uzder(1,2,1)= dc_norm(3,i+1)
2263             uzder(2,2,1)= 0.0d0
2264             uzder(3,2,1)=-dc_norm(1,i+1)
2265             uzder(1,3,1)=-dc_norm(2,i+1)
2266             uzder(2,3,1)= dc_norm(1,i+1)
2267             uzder(3,3,1)= 0.0d0
2268             uzder(1,1,2)= 0.0d0
2269             uzder(2,1,2)= dc_norm(3,i)
2270             uzder(3,1,2)=-dc_norm(2,i)
2271             uzder(1,2,2)=-dc_norm(3,i)
2272             uzder(2,2,2)= 0.0d0
2273             uzder(3,2,2)= dc_norm(1,i)
2274             uzder(1,3,2)= dc_norm(2,i)
2275             uzder(2,3,2)=-dc_norm(1,i)
2276             uzder(3,3,2)= 0.0d0
2277 C Compute the Y-axis
2278             facy=fac
2279             do k=1,3
2280               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2281             enddo
2282 C Compute the derivatives of uy
2283             do j=1,3
2284               do k=1,3
2285                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2286      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2287                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2288               enddo
2289               uyder(j,j,1)=uyder(j,j,1)-costh
2290               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2291             enddo
2292             do j=1,2
2293               do k=1,3
2294                 do l=1,3
2295                   uygrad(l,k,j,i)=uyder(l,k,j)
2296                   uzgrad(l,k,j,i)=uzder(l,k,j)
2297                 enddo
2298               enddo
2299             enddo
2300             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2301             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2302             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2303             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2304           endif
2305       enddo
2306       do i=1,nres-1
2307         vbld_inv_temp(1)=vbld_inv(i+1)
2308         if (i.lt.nres-1) then
2309           vbld_inv_temp(2)=vbld_inv(i+2)
2310           else
2311           vbld_inv_temp(2)=vbld_inv(i)
2312           endif
2313         do j=1,2
2314           do k=1,3
2315             do l=1,3
2316               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2317               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2318             enddo
2319           enddo
2320         enddo
2321       enddo
2322 #if defined(PARVEC) && defined(MPI)
2323       if (nfgtasks1.gt.1) then
2324         time00=MPI_Wtime()
2325 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2326 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2327 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2328         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2329      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2330      &   FG_COMM1,IERR)
2331         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2332      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2333      &   FG_COMM1,IERR)
2334         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2335      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2336      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2337         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2338      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2339      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2340         time_gather=time_gather+MPI_Wtime()-time00
2341       endif
2342 c      if (fg_rank.eq.0) then
2343 c        write (iout,*) "Arrays UY and UZ"
2344 c        do i=1,nres-1
2345 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2346 c     &     (uz(k,i),k=1,3)
2347 c        enddo
2348 c      endif
2349 #endif
2350       return
2351       end
2352 C-----------------------------------------------------------------------------
2353       subroutine check_vecgrad
2354       implicit real*8 (a-h,o-z)
2355       include 'DIMENSIONS'
2356       include 'COMMON.IOUNITS'
2357       include 'COMMON.GEO'
2358       include 'COMMON.VAR'
2359       include 'COMMON.LOCAL'
2360       include 'COMMON.CHAIN'
2361       include 'COMMON.VECTORS'
2362       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2363       dimension uyt(3,maxres),uzt(3,maxres)
2364       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2365       double precision delta /1.0d-7/
2366       call vec_and_deriv
2367 cd      do i=1,nres
2368 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2369 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2370 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2371 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2372 cd     &     (dc_norm(if90,i),if90=1,3)
2373 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2374 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2375 cd          write(iout,'(a)')
2376 cd      enddo
2377       do i=1,nres
2378         do j=1,2
2379           do k=1,3
2380             do l=1,3
2381               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2382               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2383             enddo
2384           enddo
2385         enddo
2386       enddo
2387       call vec_and_deriv
2388       do i=1,nres
2389         do j=1,3
2390           uyt(j,i)=uy(j,i)
2391           uzt(j,i)=uz(j,i)
2392         enddo
2393       enddo
2394       do i=1,nres
2395 cd        write (iout,*) 'i=',i
2396         do k=1,3
2397           erij(k)=dc_norm(k,i)
2398         enddo
2399         do j=1,3
2400           do k=1,3
2401             dc_norm(k,i)=erij(k)
2402           enddo
2403           dc_norm(j,i)=dc_norm(j,i)+delta
2404 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2405 c          do k=1,3
2406 c            dc_norm(k,i)=dc_norm(k,i)/fac
2407 c          enddo
2408 c          write (iout,*) (dc_norm(k,i),k=1,3)
2409 c          write (iout,*) (erij(k),k=1,3)
2410           call vec_and_deriv
2411           do k=1,3
2412             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2413             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2414             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2415             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2416           enddo
2417 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2418 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2419 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2420         enddo
2421         do k=1,3
2422           dc_norm(k,i)=erij(k)
2423         enddo
2424 cd        do k=1,3
2425 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2426 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2427 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2428 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2429 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2430 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2431 cd          write (iout,'(a)')
2432 cd        enddo
2433       enddo
2434       return
2435       end
2436 C--------------------------------------------------------------------------
2437       subroutine set_matrices
2438       implicit real*8 (a-h,o-z)
2439       include 'DIMENSIONS'
2440 #ifdef MPI
2441       include "mpif.h"
2442       include "COMMON.SETUP"
2443       integer IERR
2444       integer status(MPI_STATUS_SIZE)
2445 #endif
2446       include 'COMMON.IOUNITS'
2447       include 'COMMON.GEO'
2448       include 'COMMON.VAR'
2449       include 'COMMON.LOCAL'
2450       include 'COMMON.CHAIN'
2451       include 'COMMON.DERIV'
2452       include 'COMMON.INTERACT'
2453       include 'COMMON.CONTACTS'
2454       include 'COMMON.TORSION'
2455       include 'COMMON.VECTORS'
2456       include 'COMMON.FFIELD'
2457       double precision auxvec(2),auxmat(2,2)
2458 C
2459 C Compute the virtual-bond-torsional-angle dependent quantities needed
2460 C to calculate the el-loc multibody terms of various order.
2461 C
2462 #ifdef PARMAT
2463       do i=ivec_start+2,ivec_end+2
2464 #else
2465       do i=3,nres+1
2466 #endif
2467         if (i .lt. nres+1) then
2468           sin1=dsin(phi(i))
2469           cos1=dcos(phi(i))
2470           sintab(i-2)=sin1
2471           costab(i-2)=cos1
2472           obrot(1,i-2)=cos1
2473           obrot(2,i-2)=sin1
2474           sin2=dsin(2*phi(i))
2475           cos2=dcos(2*phi(i))
2476           sintab2(i-2)=sin2
2477           costab2(i-2)=cos2
2478           obrot2(1,i-2)=cos2
2479           obrot2(2,i-2)=sin2
2480           Ug(1,1,i-2)=-cos1
2481           Ug(1,2,i-2)=-sin1
2482           Ug(2,1,i-2)=-sin1
2483           Ug(2,2,i-2)= cos1
2484           Ug2(1,1,i-2)=-cos2
2485           Ug2(1,2,i-2)=-sin2
2486           Ug2(2,1,i-2)=-sin2
2487           Ug2(2,2,i-2)= cos2
2488         else
2489           costab(i-2)=1.0d0
2490           sintab(i-2)=0.0d0
2491           obrot(1,i-2)=1.0d0
2492           obrot(2,i-2)=0.0d0
2493           obrot2(1,i-2)=0.0d0
2494           obrot2(2,i-2)=0.0d0
2495           Ug(1,1,i-2)=1.0d0
2496           Ug(1,2,i-2)=0.0d0
2497           Ug(2,1,i-2)=0.0d0
2498           Ug(2,2,i-2)=1.0d0
2499           Ug2(1,1,i-2)=0.0d0
2500           Ug2(1,2,i-2)=0.0d0
2501           Ug2(2,1,i-2)=0.0d0
2502           Ug2(2,2,i-2)=0.0d0
2503         endif
2504         if (i .gt. 3 .and. i .lt. nres+1) then
2505           obrot_der(1,i-2)=-sin1
2506           obrot_der(2,i-2)= cos1
2507           Ugder(1,1,i-2)= sin1
2508           Ugder(1,2,i-2)=-cos1
2509           Ugder(2,1,i-2)=-cos1
2510           Ugder(2,2,i-2)=-sin1
2511           dwacos2=cos2+cos2
2512           dwasin2=sin2+sin2
2513           obrot2_der(1,i-2)=-dwasin2
2514           obrot2_der(2,i-2)= dwacos2
2515           Ug2der(1,1,i-2)= dwasin2
2516           Ug2der(1,2,i-2)=-dwacos2
2517           Ug2der(2,1,i-2)=-dwacos2
2518           Ug2der(2,2,i-2)=-dwasin2
2519         else
2520           obrot_der(1,i-2)=0.0d0
2521           obrot_der(2,i-2)=0.0d0
2522           Ugder(1,1,i-2)=0.0d0
2523           Ugder(1,2,i-2)=0.0d0
2524           Ugder(2,1,i-2)=0.0d0
2525           Ugder(2,2,i-2)=0.0d0
2526           obrot2_der(1,i-2)=0.0d0
2527           obrot2_der(2,i-2)=0.0d0
2528           Ug2der(1,1,i-2)=0.0d0
2529           Ug2der(1,2,i-2)=0.0d0
2530           Ug2der(2,1,i-2)=0.0d0
2531           Ug2der(2,2,i-2)=0.0d0
2532         endif
2533 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2534         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2535           iti = itortyp(itype(i-2))
2536         else
2537           iti=ntortyp
2538         endif
2539 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2540         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2541           iti1 = itortyp(itype(i-1))
2542         else
2543           iti1=ntortyp
2544         endif
2545 cd        write (iout,*) '*******i',i,' iti1',iti
2546 cd        write (iout,*) 'b1',b1(:,iti)
2547 cd        write (iout,*) 'b2',b2(:,iti)
2548 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2549 c        if (i .gt. iatel_s+2) then
2550         if (i .gt. nnt+2) then
2551           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2552           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2553           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2554      &    then
2555           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2556           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2557           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2558           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2559           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2560           endif
2561         else
2562           do k=1,2
2563             Ub2(k,i-2)=0.0d0
2564             Ctobr(k,i-2)=0.0d0
2565             Dtobr2(k,i-2)=0.0d0
2566             do l=1,2
2567               EUg(l,k,i-2)=0.0d0
2568               CUg(l,k,i-2)=0.0d0
2569               DUg(l,k,i-2)=0.0d0
2570               DtUg2(l,k,i-2)=0.0d0
2571             enddo
2572           enddo
2573         endif
2574         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2575         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2576         do k=1,2
2577           muder(k,i-2)=Ub2der(k,i-2)
2578         enddo
2579 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2580         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2581           if (itype(i-1).le.ntyp) then
2582             iti1 = itortyp(itype(i-1))
2583           else
2584             iti1=ntortyp
2585           endif
2586         else
2587           iti1=ntortyp
2588         endif
2589         do k=1,2
2590           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2591         enddo
2592 cd        write (iout,*) 'mu ',mu(:,i-2)
2593 cd        write (iout,*) 'mu1',mu1(:,i-2)
2594 cd        write (iout,*) 'mu2',mu2(:,i-2)
2595         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2596      &  then
2597         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2598         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2599         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2600         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2601         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2602 C Vectors and matrices dependent on a single virtual-bond dihedral.
2603         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2604         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2605         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2606         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2607         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2608         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2609         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2610         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2611         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2612         endif
2613       enddo
2614 C Matrices dependent on two consecutive virtual-bond dihedrals.
2615 C The order of matrices is from left to right.
2616       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2617      &then
2618 c      do i=max0(ivec_start,2),ivec_end
2619       do i=2,nres-1
2620         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2621         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2622         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2623         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2624         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2625         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2626         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2627         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2628       enddo
2629       endif
2630 #if defined(MPI) && defined(PARMAT)
2631 #ifdef DEBUG
2632 c      if (fg_rank.eq.0) then
2633         write (iout,*) "Arrays UG and UGDER before GATHER"
2634         do i=1,nres-1
2635           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2636      &     ((ug(l,k,i),l=1,2),k=1,2),
2637      &     ((ugder(l,k,i),l=1,2),k=1,2)
2638         enddo
2639         write (iout,*) "Arrays UG2 and UG2DER"
2640         do i=1,nres-1
2641           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2642      &     ((ug2(l,k,i),l=1,2),k=1,2),
2643      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2644         enddo
2645         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2646         do i=1,nres-1
2647           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2648      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2649      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2650         enddo
2651         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2652         do i=1,nres-1
2653           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2654      &     costab(i),sintab(i),costab2(i),sintab2(i)
2655         enddo
2656         write (iout,*) "Array MUDER"
2657         do i=1,nres-1
2658           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2659         enddo
2660 c      endif
2661 #endif
2662       if (nfgtasks.gt.1) then
2663         time00=MPI_Wtime()
2664 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2665 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2666 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2667 #ifdef MATGATHER
2668         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2669      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2670      &   FG_COMM1,IERR)
2671         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2672      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2673      &   FG_COMM1,IERR)
2674         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2675      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2676      &   FG_COMM1,IERR)
2677         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2678      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2679      &   FG_COMM1,IERR)
2680         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2681      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2682      &   FG_COMM1,IERR)
2683         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2684      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2685      &   FG_COMM1,IERR)
2686         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2687      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2688      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2689         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2690      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2691      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2692         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2693      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2694      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2695         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2696      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2697      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2698         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2699      &  then
2700         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2704      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2705      &   FG_COMM1,IERR)
2706         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2707      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2708      &   FG_COMM1,IERR)
2709        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2710      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2711      &   FG_COMM1,IERR)
2712         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2713      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2714      &   FG_COMM1,IERR)
2715         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2716      &   ivec_count(fg_rank1),
2717      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2718      &   FG_COMM1,IERR)
2719         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2720      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2724      &   FG_COMM1,IERR)
2725         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2730      &   FG_COMM1,IERR)
2731         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2736      &   FG_COMM1,IERR)
2737         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2741      &   ivec_count(fg_rank1),
2742      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2743      &   FG_COMM1,IERR)
2744         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2745      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2746      &   FG_COMM1,IERR)
2747        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2748      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2752      &   FG_COMM1,IERR)
2753        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2754      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2755      &   FG_COMM1,IERR)
2756         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2757      &   ivec_count(fg_rank1),
2758      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2759      &   FG_COMM1,IERR)
2760         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2761      &   ivec_count(fg_rank1),
2762      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2765      &   ivec_count(fg_rank1),
2766      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2767      &   MPI_MAT2,FG_COMM1,IERR)
2768         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2769      &   ivec_count(fg_rank1),
2770      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2771      &   MPI_MAT2,FG_COMM1,IERR)
2772         endif
2773 #else
2774 c Passes matrix info through the ring
2775       isend=fg_rank1
2776       irecv=fg_rank1-1
2777       if (irecv.lt.0) irecv=nfgtasks1-1
2778       iprev=irecv
2779       inext=fg_rank1+1
2780       if (inext.ge.nfgtasks1) inext=0
2781       do i=1,nfgtasks1-1
2782 c        write (iout,*) "isend",isend," irecv",irecv
2783 c        call flush(iout)
2784         lensend=lentyp(isend)
2785         lenrecv=lentyp(irecv)
2786 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2787 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2788 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2789 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2790 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2791 c        write (iout,*) "Gather ROTAT1"
2792 c        call flush(iout)
2793 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2794 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2795 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2796 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2797 c        write (iout,*) "Gather ROTAT2"
2798 c        call flush(iout)
2799         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2800      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2801      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2802      &   iprev,4400+irecv,FG_COMM,status,IERR)
2803 c        write (iout,*) "Gather ROTAT_OLD"
2804 c        call flush(iout)
2805         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2806      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2807      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2808      &   iprev,5500+irecv,FG_COMM,status,IERR)
2809 c        write (iout,*) "Gather PRECOMP11"
2810 c        call flush(iout)
2811         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2812      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2813      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2814      &   iprev,6600+irecv,FG_COMM,status,IERR)
2815 c        write (iout,*) "Gather PRECOMP12"
2816 c        call flush(iout)
2817         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2818      &  then
2819         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2820      &   MPI_ROTAT2(lensend),inext,7700+isend,
2821      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2822      &   iprev,7700+irecv,FG_COMM,status,IERR)
2823 c        write (iout,*) "Gather PRECOMP21"
2824 c        call flush(iout)
2825         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2826      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2827      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2828      &   iprev,8800+irecv,FG_COMM,status,IERR)
2829 c        write (iout,*) "Gather PRECOMP22"
2830 c        call flush(iout)
2831         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2832      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2833      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2834      &   MPI_PRECOMP23(lenrecv),
2835      &   iprev,9900+irecv,FG_COMM,status,IERR)
2836 c        write (iout,*) "Gather PRECOMP23"
2837 c        call flush(iout)
2838         endif
2839         isend=irecv
2840         irecv=irecv-1
2841         if (irecv.lt.0) irecv=nfgtasks1-1
2842       enddo
2843 #endif
2844         time_gather=time_gather+MPI_Wtime()-time00
2845       endif
2846 #ifdef DEBUG
2847 c      if (fg_rank.eq.0) then
2848         write (iout,*) "Arrays UG and UGDER"
2849         do i=1,nres-1
2850           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2851      &     ((ug(l,k,i),l=1,2),k=1,2),
2852      &     ((ugder(l,k,i),l=1,2),k=1,2)
2853         enddo
2854         write (iout,*) "Arrays UG2 and UG2DER"
2855         do i=1,nres-1
2856           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2857      &     ((ug2(l,k,i),l=1,2),k=1,2),
2858      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2859         enddo
2860         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2861         do i=1,nres-1
2862           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2863      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2864      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2865         enddo
2866         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2867         do i=1,nres-1
2868           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2869      &     costab(i),sintab(i),costab2(i),sintab2(i)
2870         enddo
2871         write (iout,*) "Array MUDER"
2872         do i=1,nres-1
2873           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2874         enddo
2875 c      endif
2876 #endif
2877 #endif
2878 cd      do i=1,nres
2879 cd        iti = itortyp(itype(i))
2880 cd        write (iout,*) i
2881 cd        do j=1,2
2882 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2883 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2884 cd        enddo
2885 cd      enddo
2886       return
2887       end
2888 C--------------------------------------------------------------------------
2889       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2890 C
2891 C This subroutine calculates the average interaction energy and its gradient
2892 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2893 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2894 C The potential depends both on the distance of peptide-group centers and on
2895 C the orientation of the CA-CA virtual bonds.
2896 C
2897       implicit real*8 (a-h,o-z)
2898 #ifdef MPI
2899       include 'mpif.h'
2900 #endif
2901       include 'DIMENSIONS'
2902       include 'COMMON.CONTROL'
2903       include 'COMMON.SETUP'
2904       include 'COMMON.IOUNITS'
2905       include 'COMMON.GEO'
2906       include 'COMMON.VAR'
2907       include 'COMMON.LOCAL'
2908       include 'COMMON.CHAIN'
2909       include 'COMMON.DERIV'
2910       include 'COMMON.INTERACT'
2911       include 'COMMON.CONTACTS'
2912       include 'COMMON.TORSION'
2913       include 'COMMON.VECTORS'
2914       include 'COMMON.FFIELD'
2915       include 'COMMON.TIME1'
2916       include 'COMMON.SPLITELE'
2917       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2918      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2919       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2920      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2921       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2922      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2923      &    num_conti,j1,j2
2924 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2925 #ifdef MOMENT
2926       double precision scal_el /1.0d0/
2927 #else
2928       double precision scal_el /0.5d0/
2929 #endif
2930 C 12/13/98
2931 C 13-go grudnia roku pamietnego...
2932       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2933      &                   0.0d0,1.0d0,0.0d0,
2934      &                   0.0d0,0.0d0,1.0d0/
2935 cd      write(iout,*) 'In EELEC'
2936 cd      do i=1,nloctyp
2937 cd        write(iout,*) 'Type',i
2938 cd        write(iout,*) 'B1',B1(:,i)
2939 cd        write(iout,*) 'B2',B2(:,i)
2940 cd        write(iout,*) 'CC',CC(:,:,i)
2941 cd        write(iout,*) 'DD',DD(:,:,i)
2942 cd        write(iout,*) 'EE',EE(:,:,i)
2943 cd      enddo
2944 cd      call check_vecgrad
2945 cd      stop
2946       if (icheckgrad.eq.1) then
2947         do i=1,nres-1
2948           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2949           do k=1,3
2950             dc_norm(k,i)=dc(k,i)*fac
2951           enddo
2952 c          write (iout,*) 'i',i,' fac',fac
2953         enddo
2954       endif
2955       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2956      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2957      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2958 c        call vec_and_deriv
2959 #ifdef TIMING
2960         time01=MPI_Wtime()
2961 #endif
2962         call set_matrices
2963 #ifdef TIMING
2964         time_mat=time_mat+MPI_Wtime()-time01
2965 #endif
2966       endif
2967 cd      do i=1,nres-1
2968 cd        write (iout,*) 'i=',i
2969 cd        do k=1,3
2970 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2971 cd        enddo
2972 cd        do k=1,3
2973 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2974 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2975 cd        enddo
2976 cd      enddo
2977       t_eelecij=0.0d0
2978       ees=0.0D0
2979       evdw1=0.0D0
2980       eel_loc=0.0d0
2981       eello_turn3=0.0d0
2982       eello_turn4=0.0d0
2983       ind=0
2984       do i=1,nres
2985         num_cont_hb(i)=0
2986       enddo
2987 cd      print '(a)','Enter EELEC'
2988 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2989       do i=1,nres
2990         gel_loc_loc(i)=0.0d0
2991         gcorr_loc(i)=0.0d0
2992       enddo
2993 c
2994 c
2995 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2996 C
2997 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2998 C
2999 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3000       do i=iturn3_start,iturn3_end
3001         if (i.le.1) cycle
3002 C        write(iout,*) "tu jest i",i
3003         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3004      &  .or. itype(i+2).eq.ntyp1
3005      &  .or. itype(i+3).eq.ntyp1
3006      &  .or. itype(i-1).eq.ntyp1
3007      &  .or. itype(i+4).eq.ntyp1
3008      &  ) cycle
3009         dxi=dc(1,i)
3010         dyi=dc(2,i)
3011         dzi=dc(3,i)
3012         dx_normi=dc_norm(1,i)
3013         dy_normi=dc_norm(2,i)
3014         dz_normi=dc_norm(3,i)
3015         xmedi=c(1,i)+0.5d0*dxi
3016         ymedi=c(2,i)+0.5d0*dyi
3017         zmedi=c(3,i)+0.5d0*dzi
3018           xmedi=mod(xmedi,boxxsize)
3019           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3020           ymedi=mod(ymedi,boxysize)
3021           if (ymedi.lt.0) ymedi=ymedi+boxysize
3022           zmedi=mod(zmedi,boxzsize)
3023           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3024         num_conti=0
3025         call eelecij(i,i+2,ees,evdw1,eel_loc)
3026         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3027         num_cont_hb(i)=num_conti
3028       enddo
3029       do i=iturn4_start,iturn4_end
3030         if (i.le.1) cycle
3031         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3032      &    .or. itype(i+3).eq.ntyp1
3033      &    .or. itype(i+4).eq.ntyp1
3034      &    .or. itype(i+5).eq.ntyp1
3035      &    .or. itype(i).eq.ntyp1
3036      &    .or. itype(i-1).eq.ntyp1
3037      &                             ) cycle
3038         dxi=dc(1,i)
3039         dyi=dc(2,i)
3040         dzi=dc(3,i)
3041         dx_normi=dc_norm(1,i)
3042         dy_normi=dc_norm(2,i)
3043         dz_normi=dc_norm(3,i)
3044         xmedi=c(1,i)+0.5d0*dxi
3045         ymedi=c(2,i)+0.5d0*dyi
3046         zmedi=c(3,i)+0.5d0*dzi
3047 C Return atom into box, boxxsize is size of box in x dimension
3048 c  194   continue
3049 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3050 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3051 C Condition for being inside the proper box
3052 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3053 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3054 c        go to 194
3055 c        endif
3056 c  195   continue
3057 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3058 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3059 C Condition for being inside the proper box
3060 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3061 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3062 c        go to 195
3063 c        endif
3064 c  196   continue
3065 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3066 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3067 C Condition for being inside the proper box
3068 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3069 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3070 c        go to 196
3071 c        endif
3072           xmedi=mod(xmedi,boxxsize)
3073           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3074           ymedi=mod(ymedi,boxysize)
3075           if (ymedi.lt.0) ymedi=ymedi+boxysize
3076           zmedi=mod(zmedi,boxzsize)
3077           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3078
3079         num_conti=num_cont_hb(i)
3080         call eelecij(i,i+3,ees,evdw1,eel_loc)
3081         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3082      &   call eturn4(i,eello_turn4)
3083         num_cont_hb(i)=num_conti
3084       enddo   ! i
3085 C Loop over all neighbouring boxes
3086 C      do xshift=-1,1
3087 C      do yshift=-1,1
3088 C      do zshift=-1,1
3089 c
3090 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3091 c
3092       do i=iatel_s,iatel_e
3093         if (i.le.1) cycle
3094         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3095      &  .or. itype(i+2).eq.ntyp1
3096      &  .or. itype(i-1).eq.ntyp1
3097      &                ) cycle
3098         dxi=dc(1,i)
3099         dyi=dc(2,i)
3100         dzi=dc(3,i)
3101         dx_normi=dc_norm(1,i)
3102         dy_normi=dc_norm(2,i)
3103         dz_normi=dc_norm(3,i)
3104         xmedi=c(1,i)+0.5d0*dxi
3105         ymedi=c(2,i)+0.5d0*dyi
3106         zmedi=c(3,i)+0.5d0*dzi
3107           xmedi=mod(xmedi,boxxsize)
3108           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3109           ymedi=mod(ymedi,boxysize)
3110           if (ymedi.lt.0) ymedi=ymedi+boxysize
3111           zmedi=mod(zmedi,boxzsize)
3112           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3113 C          xmedi=xmedi+xshift*boxxsize
3114 C          ymedi=ymedi+yshift*boxysize
3115 C          zmedi=zmedi+zshift*boxzsize
3116
3117 C Return tom into box, boxxsize is size of box in x dimension
3118 c  164   continue
3119 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3120 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3121 C Condition for being inside the proper box
3122 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3123 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3124 c        go to 164
3125 c        endif
3126 c  165   continue
3127 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3128 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3129 C Condition for being inside the proper box
3130 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3131 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3132 c        go to 165
3133 c        endif
3134 c  166   continue
3135 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3136 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3137 cC Condition for being inside the proper box
3138 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3139 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3140 c        go to 166
3141 c        endif
3142
3143 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3144         num_conti=num_cont_hb(i)
3145         do j=ielstart(i),ielend(i)
3146 C          write (iout,*) i,j
3147          if (j.le.1) cycle
3148           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3149      & .or.itype(j+2).eq.ntyp1
3150      & .or.itype(j-1).eq.ntyp1
3151      &) cycle
3152           call eelecij(i,j,ees,evdw1,eel_loc)
3153         enddo ! j
3154         num_cont_hb(i)=num_conti
3155       enddo   ! i
3156 C     enddo   ! zshift
3157 C      enddo   ! yshift
3158 C      enddo   ! xshift
3159
3160 c      write (iout,*) "Number of loop steps in EELEC:",ind
3161 cd      do i=1,nres
3162 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3163 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3164 cd      enddo
3165 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3166 ccc      eel_loc=eel_loc+eello_turn3
3167 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3168       return
3169       end
3170 C-------------------------------------------------------------------------------
3171       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3172       implicit real*8 (a-h,o-z)
3173       include 'DIMENSIONS'
3174 #ifdef MPI
3175       include "mpif.h"
3176 #endif
3177       include 'COMMON.CONTROL'
3178       include 'COMMON.IOUNITS'
3179       include 'COMMON.GEO'
3180       include 'COMMON.VAR'
3181       include 'COMMON.LOCAL'
3182       include 'COMMON.CHAIN'
3183       include 'COMMON.DERIV'
3184       include 'COMMON.INTERACT'
3185       include 'COMMON.CONTACTS'
3186       include 'COMMON.TORSION'
3187       include 'COMMON.VECTORS'
3188       include 'COMMON.FFIELD'
3189       include 'COMMON.TIME1'
3190       include 'COMMON.SPLITELE'
3191       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3192      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3193       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3194      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3195       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3196      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3197      &    num_conti,j1,j2
3198 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3199 #ifdef MOMENT
3200       double precision scal_el /1.0d0/
3201 #else
3202       double precision scal_el /0.5d0/
3203 #endif
3204 C 12/13/98
3205 C 13-go grudnia roku pamietnego...
3206       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3207      &                   0.0d0,1.0d0,0.0d0,
3208      &                   0.0d0,0.0d0,1.0d0/
3209 c          time00=MPI_Wtime()
3210 cd      write (iout,*) "eelecij",i,j
3211 c          ind=ind+1
3212           iteli=itel(i)
3213           itelj=itel(j)
3214           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3215           aaa=app(iteli,itelj)
3216           bbb=bpp(iteli,itelj)
3217           ael6i=ael6(iteli,itelj)
3218           ael3i=ael3(iteli,itelj)
3219           dxj=dc(1,j)
3220           dyj=dc(2,j)
3221           dzj=dc(3,j)
3222           dx_normj=dc_norm(1,j)
3223           dy_normj=dc_norm(2,j)
3224           dz_normj=dc_norm(3,j)
3225 C          xj=c(1,j)+0.5D0*dxj-xmedi
3226 C          yj=c(2,j)+0.5D0*dyj-ymedi
3227 C          zj=c(3,j)+0.5D0*dzj-zmedi
3228           xj=c(1,j)+0.5D0*dxj
3229           yj=c(2,j)+0.5D0*dyj
3230           zj=c(3,j)+0.5D0*dzj
3231           xj=mod(xj,boxxsize)
3232           if (xj.lt.0) xj=xj+boxxsize
3233           yj=mod(yj,boxysize)
3234           if (yj.lt.0) yj=yj+boxysize
3235           zj=mod(zj,boxzsize)
3236           if (zj.lt.0) zj=zj+boxzsize
3237           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3238       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3239       xj_safe=xj
3240       yj_safe=yj
3241       zj_safe=zj
3242       isubchap=0
3243       do xshift=-1,1
3244       do yshift=-1,1
3245       do zshift=-1,1
3246           xj=xj_safe+xshift*boxxsize
3247           yj=yj_safe+yshift*boxysize
3248           zj=zj_safe+zshift*boxzsize
3249           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3250           if(dist_temp.lt.dist_init) then
3251             dist_init=dist_temp
3252             xj_temp=xj
3253             yj_temp=yj
3254             zj_temp=zj
3255             isubchap=1
3256           endif
3257        enddo
3258        enddo
3259        enddo
3260        if (isubchap.eq.1) then
3261           xj=xj_temp-xmedi
3262           yj=yj_temp-ymedi
3263           zj=zj_temp-zmedi
3264        else
3265           xj=xj_safe-xmedi
3266           yj=yj_safe-ymedi
3267           zj=zj_safe-zmedi
3268        endif
3269 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3270 c  174   continue
3271 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3272 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3273 C Condition for being inside the proper box
3274 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3275 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3276 c        go to 174
3277 c        endif
3278 c  175   continue
3279 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3280 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3281 C Condition for being inside the proper box
3282 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3283 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3284 c        go to 175
3285 c        endif
3286 c  176   continue
3287 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3288 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3289 C Condition for being inside the proper box
3290 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3291 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3292 c        go to 176
3293 c        endif
3294 C        endif !endPBC condintion
3295 C        xj=xj-xmedi
3296 C        yj=yj-ymedi
3297 C        zj=zj-zmedi
3298           rij=xj*xj+yj*yj+zj*zj
3299
3300             sss=sscale(sqrt(rij))
3301             sssgrad=sscagrad(sqrt(rij))
3302 c            if (sss.gt.0.0d0) then
3303           rrmij=1.0D0/rij
3304           rij=dsqrt(rij)
3305           rmij=1.0D0/rij
3306           r3ij=rrmij*rmij
3307           r6ij=r3ij*r3ij
3308           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3309           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3310           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3311           fac=cosa-3.0D0*cosb*cosg
3312           ev1=aaa*r6ij*r6ij
3313 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3314           if (j.eq.i+2) ev1=scal_el*ev1
3315           ev2=bbb*r6ij
3316           fac3=ael6i*r6ij
3317           fac4=ael3i*r3ij
3318           evdwij=(ev1+ev2)
3319           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3320           el2=fac4*fac
3321 C MARYSIA
3322           eesij=(el1+el2)
3323 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3324           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3325           ees=ees+eesij
3326           evdw1=evdw1+evdwij*sss
3327 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3328 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3329 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3330 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3331
3332           if (energy_dec) then
3333               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3334      &'evdw1',i,j,evdwij
3335      &,iteli,itelj,aaa,evdw1
3336               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3337           endif
3338
3339 C
3340 C Calculate contributions to the Cartesian gradient.
3341 C
3342 #ifdef SPLITELE
3343           facvdw=-6*rrmij*(ev1+evdwij)*sss
3344           facel=-3*rrmij*(el1+eesij)
3345           fac1=fac
3346           erij(1)=xj*rmij
3347           erij(2)=yj*rmij
3348           erij(3)=zj*rmij
3349 *
3350 * Radial derivatives. First process both termini of the fragment (i,j)
3351 *
3352           ggg(1)=facel*xj
3353           ggg(2)=facel*yj
3354           ggg(3)=facel*zj
3355 c          do k=1,3
3356 c            ghalf=0.5D0*ggg(k)
3357 c            gelc(k,i)=gelc(k,i)+ghalf
3358 c            gelc(k,j)=gelc(k,j)+ghalf
3359 c          enddo
3360 c 9/28/08 AL Gradient compotents will be summed only at the end
3361           do k=1,3
3362             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3363             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3364           enddo
3365 *
3366 * Loop over residues i+1 thru j-1.
3367 *
3368 cgrad          do k=i+1,j-1
3369 cgrad            do l=1,3
3370 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3371 cgrad            enddo
3372 cgrad          enddo
3373           if (sss.gt.0.0) then
3374           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3375           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3376           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3377           else
3378           ggg(1)=0.0
3379           ggg(2)=0.0
3380           ggg(3)=0.0
3381           endif
3382 c          do k=1,3
3383 c            ghalf=0.5D0*ggg(k)
3384 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3385 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3386 c          enddo
3387 c 9/28/08 AL Gradient compotents will be summed only at the end
3388           do k=1,3
3389             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3390             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3391           enddo
3392 *
3393 * Loop over residues i+1 thru j-1.
3394 *
3395 cgrad          do k=i+1,j-1
3396 cgrad            do l=1,3
3397 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3398 cgrad            enddo
3399 cgrad          enddo
3400 #else
3401 C MARYSIA
3402           facvdw=(ev1+evdwij)*sss
3403           facel=(el1+eesij)
3404           fac1=fac
3405           fac=-3*rrmij*(facvdw+facvdw+facel)
3406           erij(1)=xj*rmij
3407           erij(2)=yj*rmij
3408           erij(3)=zj*rmij
3409 *
3410 * Radial derivatives. First process both termini of the fragment (i,j)
3411 *
3412           ggg(1)=fac*xj
3413           ggg(2)=fac*yj
3414           ggg(3)=fac*zj
3415 c          do k=1,3
3416 c            ghalf=0.5D0*ggg(k)
3417 c            gelc(k,i)=gelc(k,i)+ghalf
3418 c            gelc(k,j)=gelc(k,j)+ghalf
3419 c          enddo
3420 c 9/28/08 AL Gradient compotents will be summed only at the end
3421           do k=1,3
3422             gelc_long(k,j)=gelc(k,j)+ggg(k)
3423             gelc_long(k,i)=gelc(k,i)-ggg(k)
3424           enddo
3425 *
3426 * Loop over residues i+1 thru j-1.
3427 *
3428 cgrad          do k=i+1,j-1
3429 cgrad            do l=1,3
3430 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3431 cgrad            enddo
3432 cgrad          enddo
3433 c 9/28/08 AL Gradient compotents will be summed only at the end
3434           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3435           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3436           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3437           do k=1,3
3438             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3439             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3440           enddo
3441 #endif
3442 *
3443 * Angular part
3444 *
3445           ecosa=2.0D0*fac3*fac1+fac4
3446           fac4=-3.0D0*fac4
3447           fac3=-6.0D0*fac3
3448           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3449           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3450           do k=1,3
3451             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3452             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3453           enddo
3454 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3455 cd   &          (dcosg(k),k=1,3)
3456           do k=1,3
3457             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3458           enddo
3459 c          do k=1,3
3460 c            ghalf=0.5D0*ggg(k)
3461 c            gelc(k,i)=gelc(k,i)+ghalf
3462 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3463 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3464 c            gelc(k,j)=gelc(k,j)+ghalf
3465 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3466 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3467 c          enddo
3468 cgrad          do k=i+1,j-1
3469 cgrad            do l=1,3
3470 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3471 cgrad            enddo
3472 cgrad          enddo
3473           do k=1,3
3474             gelc(k,i)=gelc(k,i)
3475      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3476      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3477             gelc(k,j)=gelc(k,j)
3478      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3479      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3480             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3481             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3482           enddo
3483 C MARYSIA
3484 c          endif !sscale
3485           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3486      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3487      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3488 C
3489 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3490 C   energy of a peptide unit is assumed in the form of a second-order
3491 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3492 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3493 C   are computed for EVERY pair of non-contiguous peptide groups.
3494 C
3495           if (j.lt.nres-1) then
3496             j1=j+1
3497             j2=j-1
3498           else
3499             j1=j-1
3500             j2=j-2
3501           endif
3502           kkk=0
3503           do k=1,2
3504             do l=1,2
3505               kkk=kkk+1
3506               muij(kkk)=mu(k,i)*mu(l,j)
3507             enddo
3508           enddo
3509 cd         write (iout,*) 'EELEC: i',i,' j',j
3510 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3511 cd          write(iout,*) 'muij',muij
3512           ury=scalar(uy(1,i),erij)
3513           urz=scalar(uz(1,i),erij)
3514           vry=scalar(uy(1,j),erij)
3515           vrz=scalar(uz(1,j),erij)
3516           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3517           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3518           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3519           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3520           fac=dsqrt(-ael6i)*r3ij
3521           a22=a22*fac
3522           a23=a23*fac
3523           a32=a32*fac
3524           a33=a33*fac
3525 cd          write (iout,'(4i5,4f10.5)')
3526 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3527 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3528 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3529 cd     &      uy(:,j),uz(:,j)
3530 cd          write (iout,'(4f10.5)')
3531 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3532 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3533 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3534 cd           write (iout,'(9f10.5/)')
3535 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3536 C Derivatives of the elements of A in virtual-bond vectors
3537           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3538           do k=1,3
3539             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3540             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3541             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3542             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3543             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3544             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3545             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3546             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3547             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3548             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3549             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3550             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3551           enddo
3552 C Compute radial contributions to the gradient
3553           facr=-3.0d0*rrmij
3554           a22der=a22*facr
3555           a23der=a23*facr
3556           a32der=a32*facr
3557           a33der=a33*facr
3558           agg(1,1)=a22der*xj
3559           agg(2,1)=a22der*yj
3560           agg(3,1)=a22der*zj
3561           agg(1,2)=a23der*xj
3562           agg(2,2)=a23der*yj
3563           agg(3,2)=a23der*zj
3564           agg(1,3)=a32der*xj
3565           agg(2,3)=a32der*yj
3566           agg(3,3)=a32der*zj
3567           agg(1,4)=a33der*xj
3568           agg(2,4)=a33der*yj
3569           agg(3,4)=a33der*zj
3570 C Add the contributions coming from er
3571           fac3=-3.0d0*fac
3572           do k=1,3
3573             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3574             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3575             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3576             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3577           enddo
3578           do k=1,3
3579 C Derivatives in DC(i)
3580 cgrad            ghalf1=0.5d0*agg(k,1)
3581 cgrad            ghalf2=0.5d0*agg(k,2)
3582 cgrad            ghalf3=0.5d0*agg(k,3)
3583 cgrad            ghalf4=0.5d0*agg(k,4)
3584             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3585      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3586             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3587      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3588             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3589      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3590             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3591      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3592 C Derivatives in DC(i+1)
3593             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3594      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3595             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3596      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3597             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3598      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3599             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3600      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3601 C Derivatives in DC(j)
3602             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3603      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3604             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3605      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3606             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3607      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3608             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3609      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3610 C Derivatives in DC(j+1) or DC(nres-1)
3611             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3612      &      -3.0d0*vryg(k,3)*ury)
3613             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3614      &      -3.0d0*vrzg(k,3)*ury)
3615             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3616      &      -3.0d0*vryg(k,3)*urz)
3617             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3618      &      -3.0d0*vrzg(k,3)*urz)
3619 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3620 cgrad              do l=1,4
3621 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3622 cgrad              enddo
3623 cgrad            endif
3624           enddo
3625           acipa(1,1)=a22
3626           acipa(1,2)=a23
3627           acipa(2,1)=a32
3628           acipa(2,2)=a33
3629           a22=-a22
3630           a23=-a23
3631           do l=1,2
3632             do k=1,3
3633               agg(k,l)=-agg(k,l)
3634               aggi(k,l)=-aggi(k,l)
3635               aggi1(k,l)=-aggi1(k,l)
3636               aggj(k,l)=-aggj(k,l)
3637               aggj1(k,l)=-aggj1(k,l)
3638             enddo
3639           enddo
3640           if (j.lt.nres-1) then
3641             a22=-a22
3642             a32=-a32
3643             do l=1,3,2
3644               do k=1,3
3645                 agg(k,l)=-agg(k,l)
3646                 aggi(k,l)=-aggi(k,l)
3647                 aggi1(k,l)=-aggi1(k,l)
3648                 aggj(k,l)=-aggj(k,l)
3649                 aggj1(k,l)=-aggj1(k,l)
3650               enddo
3651             enddo
3652           else
3653             a22=-a22
3654             a23=-a23
3655             a32=-a32
3656             a33=-a33
3657             do l=1,4
3658               do k=1,3
3659                 agg(k,l)=-agg(k,l)
3660                 aggi(k,l)=-aggi(k,l)
3661                 aggi1(k,l)=-aggi1(k,l)
3662                 aggj(k,l)=-aggj(k,l)
3663                 aggj1(k,l)=-aggj1(k,l)
3664               enddo
3665             enddo
3666           endif
3667           ENDIF ! WCORR
3668           IF (wel_loc.gt.0.0d0) THEN
3669 C Contribution to the local-electrostatic energy coming from the i-j pair
3670           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3671      &     +a33*muij(4)
3672 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3673 c     &                     ' eel_loc_ij',eel_loc_ij
3674
3675           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3676      &            'eelloc',i,j,eel_loc_ij
3677 c           if (eel_loc_ij.ne.0)
3678 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3679 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3680
3681           eel_loc=eel_loc+eel_loc_ij
3682 C Partial derivatives in virtual-bond dihedral angles gamma
3683           if (i.gt.1)
3684      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3685      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3686      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3687           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3688      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3689      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3690 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3691           do l=1,3
3692             ggg(l)=agg(l,1)*muij(1)+
3693      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3694             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3695             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3696 cgrad            ghalf=0.5d0*ggg(l)
3697 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3698 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3699           enddo
3700 cgrad          do k=i+1,j2
3701 cgrad            do l=1,3
3702 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3703 cgrad            enddo
3704 cgrad          enddo
3705 C Remaining derivatives of eello
3706           do l=1,3
3707             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3708      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3709             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3710      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3711             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3712      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3713             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3714      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3715           enddo
3716           ENDIF
3717 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3718 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3719           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3720      &       .and. num_conti.le.maxconts) then
3721 c            write (iout,*) i,j," entered corr"
3722 C
3723 C Calculate the contact function. The ith column of the array JCONT will
3724 C contain the numbers of atoms that make contacts with the atom I (of numbers
3725 C greater than I). The arrays FACONT and GACONT will contain the values of
3726 C the contact function and its derivative.
3727 c           r0ij=1.02D0*rpp(iteli,itelj)
3728 c           r0ij=1.11D0*rpp(iteli,itelj)
3729             r0ij=2.20D0*rpp(iteli,itelj)
3730 c           r0ij=1.55D0*rpp(iteli,itelj)
3731             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3732             if (fcont.gt.0.0D0) then
3733               num_conti=num_conti+1
3734               if (num_conti.gt.maxconts) then
3735                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3736      &                         ' will skip next contacts for this conf.'
3737               else
3738                 jcont_hb(num_conti,i)=j
3739 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3740 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3741                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3742      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3743 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3744 C  terms.
3745                 d_cont(num_conti,i)=rij
3746 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3747 C     --- Electrostatic-interaction matrix ---
3748                 a_chuj(1,1,num_conti,i)=a22
3749                 a_chuj(1,2,num_conti,i)=a23
3750                 a_chuj(2,1,num_conti,i)=a32
3751                 a_chuj(2,2,num_conti,i)=a33
3752 C     --- Gradient of rij
3753                 do kkk=1,3
3754                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3755                 enddo
3756                 kkll=0
3757                 do k=1,2
3758                   do l=1,2
3759                     kkll=kkll+1
3760                     do m=1,3
3761                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3762                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3763                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3764                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3765                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3766                     enddo
3767                   enddo
3768                 enddo
3769                 ENDIF
3770                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3771 C Calculate contact energies
3772                 cosa4=4.0D0*cosa
3773                 wij=cosa-3.0D0*cosb*cosg
3774                 cosbg1=cosb+cosg
3775                 cosbg2=cosb-cosg
3776 c               fac3=dsqrt(-ael6i)/r0ij**3
3777                 fac3=dsqrt(-ael6i)*r3ij
3778 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3779                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3780                 if (ees0tmp.gt.0) then
3781                   ees0pij=dsqrt(ees0tmp)
3782                 else
3783                   ees0pij=0
3784                 endif
3785 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3786                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3787                 if (ees0tmp.gt.0) then
3788                   ees0mij=dsqrt(ees0tmp)
3789                 else
3790                   ees0mij=0
3791                 endif
3792 c               ees0mij=0.0D0
3793                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3794                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3795 C Diagnostics. Comment out or remove after debugging!
3796 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3797 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3798 c               ees0m(num_conti,i)=0.0D0
3799 C End diagnostics.
3800 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3801 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3802 C Angular derivatives of the contact function
3803                 ees0pij1=fac3/ees0pij
3804                 ees0mij1=fac3/ees0mij
3805                 fac3p=-3.0D0*fac3*rrmij
3806                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3807                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3808 c               ees0mij1=0.0D0
3809                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3810                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3811                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3812                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3813                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3814                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3815                 ecosap=ecosa1+ecosa2
3816                 ecosbp=ecosb1+ecosb2
3817                 ecosgp=ecosg1+ecosg2
3818                 ecosam=ecosa1-ecosa2
3819                 ecosbm=ecosb1-ecosb2
3820                 ecosgm=ecosg1-ecosg2
3821 C Diagnostics
3822 c               ecosap=ecosa1
3823 c               ecosbp=ecosb1
3824 c               ecosgp=ecosg1
3825 c               ecosam=0.0D0
3826 c               ecosbm=0.0D0
3827 c               ecosgm=0.0D0
3828 C End diagnostics
3829                 facont_hb(num_conti,i)=fcont
3830                 fprimcont=fprimcont/rij
3831 cd              facont_hb(num_conti,i)=1.0D0
3832 C Following line is for diagnostics.
3833 cd              fprimcont=0.0D0
3834                 do k=1,3
3835                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3836                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3837                 enddo
3838                 do k=1,3
3839                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3840                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3841                 enddo
3842                 gggp(1)=gggp(1)+ees0pijp*xj
3843                 gggp(2)=gggp(2)+ees0pijp*yj
3844                 gggp(3)=gggp(3)+ees0pijp*zj
3845                 gggm(1)=gggm(1)+ees0mijp*xj
3846                 gggm(2)=gggm(2)+ees0mijp*yj
3847                 gggm(3)=gggm(3)+ees0mijp*zj
3848 C Derivatives due to the contact function
3849                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3850                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3851                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3852                 do k=1,3
3853 c
3854 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3855 c          following the change of gradient-summation algorithm.
3856 c
3857 cgrad                  ghalfp=0.5D0*gggp(k)
3858 cgrad                  ghalfm=0.5D0*gggm(k)
3859                   gacontp_hb1(k,num_conti,i)=!ghalfp
3860      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3861      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3862                   gacontp_hb2(k,num_conti,i)=!ghalfp
3863      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3864      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3865                   gacontp_hb3(k,num_conti,i)=gggp(k)
3866                   gacontm_hb1(k,num_conti,i)=!ghalfm
3867      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3868      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3869                   gacontm_hb2(k,num_conti,i)=!ghalfm
3870      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3871      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3872                   gacontm_hb3(k,num_conti,i)=gggm(k)
3873                 enddo
3874 C Diagnostics. Comment out or remove after debugging!
3875 cdiag           do k=1,3
3876 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3877 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3878 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3879 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3880 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3881 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3882 cdiag           enddo
3883               ENDIF ! wcorr
3884               endif  ! num_conti.le.maxconts
3885             endif  ! fcont.gt.0
3886           endif    ! j.gt.i+1
3887           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3888             do k=1,4
3889               do l=1,3
3890                 ghalf=0.5d0*agg(l,k)
3891                 aggi(l,k)=aggi(l,k)+ghalf
3892                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3893                 aggj(l,k)=aggj(l,k)+ghalf
3894               enddo
3895             enddo
3896             if (j.eq.nres-1 .and. i.lt.j-2) then
3897               do k=1,4
3898                 do l=1,3
3899                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3900                 enddo
3901               enddo
3902             endif
3903           endif
3904 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3905       return
3906       end
3907 C-----------------------------------------------------------------------------
3908       subroutine eturn3(i,eello_turn3)
3909 C Third- and fourth-order contributions from turns
3910       implicit real*8 (a-h,o-z)
3911       include 'DIMENSIONS'
3912       include 'COMMON.IOUNITS'
3913       include 'COMMON.GEO'
3914       include 'COMMON.VAR'
3915       include 'COMMON.LOCAL'
3916       include 'COMMON.CHAIN'
3917       include 'COMMON.DERIV'
3918       include 'COMMON.INTERACT'
3919       include 'COMMON.CONTACTS'
3920       include 'COMMON.TORSION'
3921       include 'COMMON.VECTORS'
3922       include 'COMMON.FFIELD'
3923       include 'COMMON.CONTROL'
3924       dimension ggg(3)
3925       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3926      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3927      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3928       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3929      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3930       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3931      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3932      &    num_conti,j1,j2
3933       j=i+2
3934 c      write (iout,*) "eturn3",i,j,j1,j2
3935       a_temp(1,1)=a22
3936       a_temp(1,2)=a23
3937       a_temp(2,1)=a32
3938       a_temp(2,2)=a33
3939 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3940 C
3941 C               Third-order contributions
3942 C
3943 C                 (i+2)o----(i+3)
3944 C                      | |
3945 C                      | |
3946 C                 (i+1)o----i
3947 C
3948 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3949 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3950         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3951         call transpose2(auxmat(1,1),auxmat1(1,1))
3952         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3953         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3954         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3955      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3956 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3957 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3958 cd     &    ' eello_turn3_num',4*eello_turn3_num
3959 C Derivatives in gamma(i)
3960         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3961         call transpose2(auxmat2(1,1),auxmat3(1,1))
3962         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3963         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3964 C Derivatives in gamma(i+1)
3965         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3966         call transpose2(auxmat2(1,1),auxmat3(1,1))
3967         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3968         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3969      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3970 C Cartesian derivatives
3971         do l=1,3
3972 c            ghalf1=0.5d0*agg(l,1)
3973 c            ghalf2=0.5d0*agg(l,2)
3974 c            ghalf3=0.5d0*agg(l,3)
3975 c            ghalf4=0.5d0*agg(l,4)
3976           a_temp(1,1)=aggi(l,1)!+ghalf1
3977           a_temp(1,2)=aggi(l,2)!+ghalf2
3978           a_temp(2,1)=aggi(l,3)!+ghalf3
3979           a_temp(2,2)=aggi(l,4)!+ghalf4
3980           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3981           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3982      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3983           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3984           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3985           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3986           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3987           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3988           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3989      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3990           a_temp(1,1)=aggj(l,1)!+ghalf1
3991           a_temp(1,2)=aggj(l,2)!+ghalf2
3992           a_temp(2,1)=aggj(l,3)!+ghalf3
3993           a_temp(2,2)=aggj(l,4)!+ghalf4
3994           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3995           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3996      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3997           a_temp(1,1)=aggj1(l,1)
3998           a_temp(1,2)=aggj1(l,2)
3999           a_temp(2,1)=aggj1(l,3)
4000           a_temp(2,2)=aggj1(l,4)
4001           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4002           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4003      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4004         enddo
4005       return
4006       end
4007 C-------------------------------------------------------------------------------
4008       subroutine eturn4(i,eello_turn4)
4009 C Third- and fourth-order contributions from turns
4010       implicit real*8 (a-h,o-z)
4011       include 'DIMENSIONS'
4012       include 'COMMON.IOUNITS'
4013       include 'COMMON.GEO'
4014       include 'COMMON.VAR'
4015       include 'COMMON.LOCAL'
4016       include 'COMMON.CHAIN'
4017       include 'COMMON.DERIV'
4018       include 'COMMON.INTERACT'
4019       include 'COMMON.CONTACTS'
4020       include 'COMMON.TORSION'
4021       include 'COMMON.VECTORS'
4022       include 'COMMON.FFIELD'
4023       include 'COMMON.CONTROL'
4024       dimension ggg(3)
4025       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4026      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4027      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4028       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4029      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4030       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4031      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4032      &    num_conti,j1,j2
4033       j=i+3
4034 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4035 C
4036 C               Fourth-order contributions
4037 C
4038 C                 (i+3)o----(i+4)
4039 C                     /  |
4040 C               (i+2)o   |
4041 C                     \  |
4042 C                 (i+1)o----i
4043 C
4044 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4045 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4046 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4047         a_temp(1,1)=a22
4048         a_temp(1,2)=a23
4049         a_temp(2,1)=a32
4050         a_temp(2,2)=a33
4051         iti1=itortyp(itype(i+1))
4052         iti2=itortyp(itype(i+2))
4053         iti3=itortyp(itype(i+3))
4054 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4055         call transpose2(EUg(1,1,i+1),e1t(1,1))
4056         call transpose2(Eug(1,1,i+2),e2t(1,1))
4057         call transpose2(Eug(1,1,i+3),e3t(1,1))
4058         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4059         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4060         s1=scalar2(b1(1,iti2),auxvec(1))
4061         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4062         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4063         s2=scalar2(b1(1,iti1),auxvec(1))
4064         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4065         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4066         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4067         eello_turn4=eello_turn4-(s1+s2+s3)
4068 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4069         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4070      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4071 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4072 cd     &    ' eello_turn4_num',8*eello_turn4_num
4073 C Derivatives in gamma(i)
4074         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4075         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4076         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4077         s1=scalar2(b1(1,iti2),auxvec(1))
4078         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4079         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4080         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4081 C Derivatives in gamma(i+1)
4082         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4083         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4084         s2=scalar2(b1(1,iti1),auxvec(1))
4085         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4086         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4087         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4088         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4089 C Derivatives in gamma(i+2)
4090         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4091         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4092         s1=scalar2(b1(1,iti2),auxvec(1))
4093         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4094         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4095         s2=scalar2(b1(1,iti1),auxvec(1))
4096         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4097         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4098         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4099         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4100 C Cartesian derivatives
4101 C Derivatives of this turn contributions in DC(i+2)
4102         if (j.lt.nres-1) then
4103           do l=1,3
4104             a_temp(1,1)=agg(l,1)
4105             a_temp(1,2)=agg(l,2)
4106             a_temp(2,1)=agg(l,3)
4107             a_temp(2,2)=agg(l,4)
4108             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4109             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4110             s1=scalar2(b1(1,iti2),auxvec(1))
4111             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4112             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4113             s2=scalar2(b1(1,iti1),auxvec(1))
4114             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4115             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4116             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4117             ggg(l)=-(s1+s2+s3)
4118             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4119           enddo
4120         endif
4121 C Remaining derivatives of this turn contribution
4122         do l=1,3
4123           a_temp(1,1)=aggi(l,1)
4124           a_temp(1,2)=aggi(l,2)
4125           a_temp(2,1)=aggi(l,3)
4126           a_temp(2,2)=aggi(l,4)
4127           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4128           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4129           s1=scalar2(b1(1,iti2),auxvec(1))
4130           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4131           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4132           s2=scalar2(b1(1,iti1),auxvec(1))
4133           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4134           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4135           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4136           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4137           a_temp(1,1)=aggi1(l,1)
4138           a_temp(1,2)=aggi1(l,2)
4139           a_temp(2,1)=aggi1(l,3)
4140           a_temp(2,2)=aggi1(l,4)
4141           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4142           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4143           s1=scalar2(b1(1,iti2),auxvec(1))
4144           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4145           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4146           s2=scalar2(b1(1,iti1),auxvec(1))
4147           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4148           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4149           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4150           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4151           a_temp(1,1)=aggj(l,1)
4152           a_temp(1,2)=aggj(l,2)
4153           a_temp(2,1)=aggj(l,3)
4154           a_temp(2,2)=aggj(l,4)
4155           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4156           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4157           s1=scalar2(b1(1,iti2),auxvec(1))
4158           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4159           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4160           s2=scalar2(b1(1,iti1),auxvec(1))
4161           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4162           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4163           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4164           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4165           a_temp(1,1)=aggj1(l,1)
4166           a_temp(1,2)=aggj1(l,2)
4167           a_temp(2,1)=aggj1(l,3)
4168           a_temp(2,2)=aggj1(l,4)
4169           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4170           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4171           s1=scalar2(b1(1,iti2),auxvec(1))
4172           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4173           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4174           s2=scalar2(b1(1,iti1),auxvec(1))
4175           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4176           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4177           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4178 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4179           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4180         enddo
4181       return
4182       end
4183 C-----------------------------------------------------------------------------
4184       subroutine vecpr(u,v,w)
4185       implicit real*8(a-h,o-z)
4186       dimension u(3),v(3),w(3)
4187       w(1)=u(2)*v(3)-u(3)*v(2)
4188       w(2)=-u(1)*v(3)+u(3)*v(1)
4189       w(3)=u(1)*v(2)-u(2)*v(1)
4190       return
4191       end
4192 C-----------------------------------------------------------------------------
4193       subroutine unormderiv(u,ugrad,unorm,ungrad)
4194 C This subroutine computes the derivatives of a normalized vector u, given
4195 C the derivatives computed without normalization conditions, ugrad. Returns
4196 C ungrad.
4197       implicit none
4198       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4199       double precision vec(3)
4200       double precision scalar
4201       integer i,j
4202 c      write (2,*) 'ugrad',ugrad
4203 c      write (2,*) 'u',u
4204       do i=1,3
4205         vec(i)=scalar(ugrad(1,i),u(1))
4206       enddo
4207 c      write (2,*) 'vec',vec
4208       do i=1,3
4209         do j=1,3
4210           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4211         enddo
4212       enddo
4213 c      write (2,*) 'ungrad',ungrad
4214       return
4215       end
4216 C-----------------------------------------------------------------------------
4217       subroutine escp_soft_sphere(evdw2,evdw2_14)
4218 C
4219 C This subroutine calculates the excluded-volume interaction energy between
4220 C peptide-group centers and side chains and its gradient in virtual-bond and
4221 C side-chain vectors.
4222 C
4223       implicit real*8 (a-h,o-z)
4224       include 'DIMENSIONS'
4225       include 'COMMON.GEO'
4226       include 'COMMON.VAR'
4227       include 'COMMON.LOCAL'
4228       include 'COMMON.CHAIN'
4229       include 'COMMON.DERIV'
4230       include 'COMMON.INTERACT'
4231       include 'COMMON.FFIELD'
4232       include 'COMMON.IOUNITS'
4233       include 'COMMON.CONTROL'
4234       dimension ggg(3)
4235       evdw2=0.0D0
4236       evdw2_14=0.0d0
4237       r0_scp=4.5d0
4238 cd    print '(a)','Enter ESCP'
4239 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4240 C      do xshift=-1,1
4241 C      do yshift=-1,1
4242 C      do zshift=-1,1
4243       do i=iatscp_s,iatscp_e
4244         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4245         iteli=itel(i)
4246         xi=0.5D0*(c(1,i)+c(1,i+1))
4247         yi=0.5D0*(c(2,i)+c(2,i+1))
4248         zi=0.5D0*(c(3,i)+c(3,i+1))
4249 C Return atom into box, boxxsize is size of box in x dimension
4250 c  134   continue
4251 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4252 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4253 C Condition for being inside the proper box
4254 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4255 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4256 c        go to 134
4257 c        endif
4258 c  135   continue
4259 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4260 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4261 C Condition for being inside the proper box
4262 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4263 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4264 c        go to 135
4265 c c       endif
4266 c  136   continue
4267 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4268 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4269 cC Condition for being inside the proper box
4270 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4271 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4272 c        go to 136
4273 c        endif
4274           xi=mod(xi,boxxsize)
4275           if (xi.lt.0) xi=xi+boxxsize
4276           yi=mod(yi,boxysize)
4277           if (yi.lt.0) yi=yi+boxysize
4278           zi=mod(zi,boxzsize)
4279           if (zi.lt.0) zi=zi+boxzsize
4280 C          xi=xi+xshift*boxxsize
4281 C          yi=yi+yshift*boxysize
4282 C          zi=zi+zshift*boxzsize
4283         do iint=1,nscp_gr(i)
4284
4285         do j=iscpstart(i,iint),iscpend(i,iint)
4286           if (itype(j).eq.ntyp1) cycle
4287           itypj=iabs(itype(j))
4288 C Uncomment following three lines for SC-p interactions
4289 c         xj=c(1,nres+j)-xi
4290 c         yj=c(2,nres+j)-yi
4291 c         zj=c(3,nres+j)-zi
4292 C Uncomment following three lines for Ca-p interactions
4293           xj=c(1,j)
4294           yj=c(2,j)
4295           zj=c(3,j)
4296 c  174   continue
4297 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4298 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4299 C Condition for being inside the proper box
4300 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4301 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4302 c        go to 174
4303 c        endif
4304 c  175   continue
4305 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4306 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4307 cC Condition for being inside the proper box
4308 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4309 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4310 c        go to 175
4311 c        endif
4312 c  176   continue
4313 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4314 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4315 C Condition for being inside the proper box
4316 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4317 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4318 c        go to 176
4319           xj=mod(xj,boxxsize)
4320           if (xj.lt.0) xj=xj+boxxsize
4321           yj=mod(yj,boxysize)
4322           if (yj.lt.0) yj=yj+boxysize
4323           zj=mod(zj,boxzsize)
4324           if (zj.lt.0) zj=zj+boxzsize
4325       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4326       xj_safe=xj
4327       yj_safe=yj
4328       zj_safe=zj
4329       subchap=0
4330       do xshift=-1,1
4331       do yshift=-1,1
4332       do zshift=-1,1
4333           xj=xj_safe+xshift*boxxsize
4334           yj=yj_safe+yshift*boxysize
4335           zj=zj_safe+zshift*boxzsize
4336           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4337           if(dist_temp.lt.dist_init) then
4338             dist_init=dist_temp
4339             xj_temp=xj
4340             yj_temp=yj
4341             zj_temp=zj
4342             subchap=1
4343           endif
4344        enddo
4345        enddo
4346        enddo
4347        if (subchap.eq.1) then
4348           xj=xj_temp-xi
4349           yj=yj_temp-yi
4350           zj=zj_temp-zi
4351        else
4352           xj=xj_safe-xi
4353           yj=yj_safe-yi
4354           zj=zj_safe-zi
4355        endif
4356 c c       endif
4357 C          xj=xj-xi
4358 C          yj=yj-yi
4359 C          zj=zj-zi
4360           rij=xj*xj+yj*yj+zj*zj
4361
4362           r0ij=r0_scp
4363           r0ijsq=r0ij*r0ij
4364           if (rij.lt.r0ijsq) then
4365             evdwij=0.25d0*(rij-r0ijsq)**2
4366             fac=rij-r0ijsq
4367           else
4368             evdwij=0.0d0
4369             fac=0.0d0
4370           endif
4371           evdw2=evdw2+evdwij
4372 C
4373 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4374 C
4375           ggg(1)=xj*fac
4376           ggg(2)=yj*fac
4377           ggg(3)=zj*fac
4378 cgrad          if (j.lt.i) then
4379 cd          write (iout,*) 'j<i'
4380 C Uncomment following three lines for SC-p interactions
4381 c           do k=1,3
4382 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4383 c           enddo
4384 cgrad          else
4385 cd          write (iout,*) 'j>i'
4386 cgrad            do k=1,3
4387 cgrad              ggg(k)=-ggg(k)
4388 C Uncomment following line for SC-p interactions
4389 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4390 cgrad            enddo
4391 cgrad          endif
4392 cgrad          do k=1,3
4393 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4394 cgrad          enddo
4395 cgrad          kstart=min0(i+1,j)
4396 cgrad          kend=max0(i-1,j-1)
4397 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4398 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4399 cgrad          do k=kstart,kend
4400 cgrad            do l=1,3
4401 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4402 cgrad            enddo
4403 cgrad          enddo
4404           do k=1,3
4405             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4406             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4407           enddo
4408         enddo
4409
4410         enddo ! iint
4411       enddo ! i
4412 C      enddo !zshift
4413 C      enddo !yshift
4414 C      enddo !xshift
4415       return
4416       end
4417 C-----------------------------------------------------------------------------
4418       subroutine escp(evdw2,evdw2_14)
4419 C
4420 C This subroutine calculates the excluded-volume interaction energy between
4421 C peptide-group centers and side chains and its gradient in virtual-bond and
4422 C side-chain vectors.
4423 C
4424       implicit real*8 (a-h,o-z)
4425       include 'DIMENSIONS'
4426       include 'COMMON.GEO'
4427       include 'COMMON.VAR'
4428       include 'COMMON.LOCAL'
4429       include 'COMMON.CHAIN'
4430       include 'COMMON.DERIV'
4431       include 'COMMON.INTERACT'
4432       include 'COMMON.FFIELD'
4433       include 'COMMON.IOUNITS'
4434       include 'COMMON.CONTROL'
4435       include 'COMMON.SPLITELE'
4436       dimension ggg(3)
4437       evdw2=0.0D0
4438       evdw2_14=0.0d0
4439 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4440 cd    print '(a)','Enter ESCP'
4441 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4442 C      do xshift=-1,1
4443 C      do yshift=-1,1
4444 C      do zshift=-1,1
4445       do i=iatscp_s,iatscp_e
4446         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4447         iteli=itel(i)
4448         xi=0.5D0*(c(1,i)+c(1,i+1))
4449         yi=0.5D0*(c(2,i)+c(2,i+1))
4450         zi=0.5D0*(c(3,i)+c(3,i+1))
4451           xi=mod(xi,boxxsize)
4452           if (xi.lt.0) xi=xi+boxxsize
4453           yi=mod(yi,boxysize)
4454           if (yi.lt.0) yi=yi+boxysize
4455           zi=mod(zi,boxzsize)
4456           if (zi.lt.0) zi=zi+boxzsize
4457 c          xi=xi+xshift*boxxsize
4458 c          yi=yi+yshift*boxysize
4459 c          zi=zi+zshift*boxzsize
4460 c        print *,xi,yi,zi,'polozenie i'
4461 C Return atom into box, boxxsize is size of box in x dimension
4462 c  134   continue
4463 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4464 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4465 C Condition for being inside the proper box
4466 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4467 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4468 c        go to 134
4469 c        endif
4470 c  135   continue
4471 c          print *,xi,boxxsize,"pierwszy"
4472
4473 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4474 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4475 C Condition for being inside the proper box
4476 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4477 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4478 c        go to 135
4479 c        endif
4480 c  136   continue
4481 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4482 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4483 C Condition for being inside the proper box
4484 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4485 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4486 c        go to 136
4487 c        endif
4488         do iint=1,nscp_gr(i)
4489
4490         do j=iscpstart(i,iint),iscpend(i,iint)
4491           itypj=iabs(itype(j))
4492           if (itypj.eq.ntyp1) cycle
4493 C Uncomment following three lines for SC-p interactions
4494 c         xj=c(1,nres+j)-xi
4495 c         yj=c(2,nres+j)-yi
4496 c         zj=c(3,nres+j)-zi
4497 C Uncomment following three lines for Ca-p interactions
4498           xj=c(1,j)
4499           yj=c(2,j)
4500           zj=c(3,j)
4501           xj=mod(xj,boxxsize)
4502           if (xj.lt.0) xj=xj+boxxsize
4503           yj=mod(yj,boxysize)
4504           if (yj.lt.0) yj=yj+boxysize
4505           zj=mod(zj,boxzsize)
4506           if (zj.lt.0) zj=zj+boxzsize
4507 c  174   continue
4508 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4509 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4510 C Condition for being inside the proper box
4511 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4512 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4513 c        go to 174
4514 c        endif
4515 c  175   continue
4516 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4517 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4518 cC Condition for being inside the proper box
4519 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4520 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4521 c        go to 175
4522 c        endif
4523 c  176   continue
4524 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4525 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4526 C Condition for being inside the proper box
4527 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4528 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4529 c        go to 176
4530 c        endif
4531 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4532       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4533       xj_safe=xj
4534       yj_safe=yj
4535       zj_safe=zj
4536       subchap=0
4537       do xshift=-1,1
4538       do yshift=-1,1
4539       do zshift=-1,1
4540           xj=xj_safe+xshift*boxxsize
4541           yj=yj_safe+yshift*boxysize
4542           zj=zj_safe+zshift*boxzsize
4543           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4544           if(dist_temp.lt.dist_init) then
4545             dist_init=dist_temp
4546             xj_temp=xj
4547             yj_temp=yj
4548             zj_temp=zj
4549             subchap=1
4550           endif
4551        enddo
4552        enddo
4553        enddo
4554        if (subchap.eq.1) then
4555           xj=xj_temp-xi
4556           yj=yj_temp-yi
4557           zj=zj_temp-zi
4558        else
4559           xj=xj_safe-xi
4560           yj=yj_safe-yi
4561           zj=zj_safe-zi
4562        endif
4563 c          print *,xj,yj,zj,'polozenie j'
4564           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4565 c          print *,rrij
4566           sss=sscale(1.0d0/(dsqrt(rrij)))
4567 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4568 c          if (sss.eq.0) print *,'czasem jest OK'
4569           if (sss.le.0.0d0) cycle
4570           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4571           fac=rrij**expon2
4572           e1=fac*fac*aad(itypj,iteli)
4573           e2=fac*bad(itypj,iteli)
4574           if (iabs(j-i) .le. 2) then
4575             e1=scal14*e1
4576             e2=scal14*e2
4577             evdw2_14=evdw2_14+(e1+e2)*sss
4578           endif
4579           evdwij=e1+e2
4580           evdw2=evdw2+evdwij*sss
4581           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4582      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4583      &       bad(itypj,iteli)
4584 C
4585 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4586 C
4587           fac=-(evdwij+e1)*rrij*sss
4588           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4589           ggg(1)=xj*fac
4590           ggg(2)=yj*fac
4591           ggg(3)=zj*fac
4592 cgrad          if (j.lt.i) then
4593 cd          write (iout,*) 'j<i'
4594 C Uncomment following three lines for SC-p interactions
4595 c           do k=1,3
4596 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4597 c           enddo
4598 cgrad          else
4599 cd          write (iout,*) 'j>i'
4600 cgrad            do k=1,3
4601 cgrad              ggg(k)=-ggg(k)
4602 C Uncomment following line for SC-p interactions
4603 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4604 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4605 cgrad            enddo
4606 cgrad          endif
4607 cgrad          do k=1,3
4608 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4609 cgrad          enddo
4610 cgrad          kstart=min0(i+1,j)
4611 cgrad          kend=max0(i-1,j-1)
4612 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4613 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4614 cgrad          do k=kstart,kend
4615 cgrad            do l=1,3
4616 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4617 cgrad            enddo
4618 cgrad          enddo
4619           do k=1,3
4620             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4621             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4622           enddo
4623 c        endif !endif for sscale cutoff
4624         enddo ! j
4625
4626         enddo ! iint
4627       enddo ! i
4628 c      enddo !zshift
4629 c      enddo !yshift
4630 c      enddo !xshift
4631       do i=1,nct
4632         do j=1,3
4633           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4634           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4635           gradx_scp(j,i)=expon*gradx_scp(j,i)
4636         enddo
4637       enddo
4638 C******************************************************************************
4639 C
4640 C                              N O T E !!!
4641 C
4642 C To save time the factor EXPON has been extracted from ALL components
4643 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4644 C use!
4645 C
4646 C******************************************************************************
4647       return
4648       end
4649 C--------------------------------------------------------------------------
4650       subroutine edis(ehpb)
4651 C
4652 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4653 C
4654       implicit real*8 (a-h,o-z)
4655       include 'DIMENSIONS'
4656       include 'COMMON.SBRIDGE'
4657       include 'COMMON.CHAIN'
4658       include 'COMMON.DERIV'
4659       include 'COMMON.VAR'
4660       include 'COMMON.INTERACT'
4661       include 'COMMON.IOUNITS'
4662       dimension ggg(3)
4663       ehpb=0.0D0
4664 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4665 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4666       if (link_end.eq.0) return
4667       do i=link_start,link_end
4668 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4669 C CA-CA distance used in regularization of structure.
4670         ii=ihpb(i)
4671         jj=jhpb(i)
4672 C iii and jjj point to the residues for which the distance is assigned.
4673         if (ii.gt.nres) then
4674           iii=ii-nres
4675           jjj=jj-nres
4676         else
4677           iii=ii
4678           jjj=jj
4679         endif
4680 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4681 c     &    dhpb(i),dhpb1(i),forcon(i)
4682 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4683 C    distance and angle dependent SS bond potential.
4684 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4685 C     & iabs(itype(jjj)).eq.1) then
4686 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4687 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4688         if (.not.dyn_ss .and. i.le.nss) then
4689 C 15/02/13 CC dynamic SSbond - additional check
4690          if (ii.gt.nres
4691      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4692           call ssbond_ene(iii,jjj,eij)
4693           ehpb=ehpb+2*eij
4694          endif
4695 cd          write (iout,*) "eij",eij
4696         else
4697 C Calculate the distance between the two points and its difference from the
4698 C target distance.
4699           dd=dist(ii,jj)
4700             rdis=dd-dhpb(i)
4701 C Get the force constant corresponding to this distance.
4702             waga=forcon(i)
4703 C Calculate the contribution to energy.
4704             ehpb=ehpb+waga*rdis*rdis
4705 C
4706 C Evaluate gradient.
4707 C
4708             fac=waga*rdis/dd
4709 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4710 cd   &   ' waga=',waga,' fac=',fac
4711             do j=1,3
4712               ggg(j)=fac*(c(j,jj)-c(j,ii))
4713             enddo
4714 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4715 C If this is a SC-SC distance, we need to calculate the contributions to the
4716 C Cartesian gradient in the SC vectors (ghpbx).
4717           if (iii.lt.ii) then
4718           do j=1,3
4719             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4720             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4721           enddo
4722           endif
4723 cgrad        do j=iii,jjj-1
4724 cgrad          do k=1,3
4725 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4726 cgrad          enddo
4727 cgrad        enddo
4728           do k=1,3
4729             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4730             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4731           enddo
4732         endif
4733       enddo
4734       ehpb=0.5D0*ehpb
4735       return
4736       end
4737 C--------------------------------------------------------------------------
4738       subroutine ssbond_ene(i,j,eij)
4739 C
4740 C Calculate the distance and angle dependent SS-bond potential energy
4741 C using a free-energy function derived based on RHF/6-31G** ab initio
4742 C calculations of diethyl disulfide.
4743 C
4744 C A. Liwo and U. Kozlowska, 11/24/03
4745 C
4746       implicit real*8 (a-h,o-z)
4747       include 'DIMENSIONS'
4748       include 'COMMON.SBRIDGE'
4749       include 'COMMON.CHAIN'
4750       include 'COMMON.DERIV'
4751       include 'COMMON.LOCAL'
4752       include 'COMMON.INTERACT'
4753       include 'COMMON.VAR'
4754       include 'COMMON.IOUNITS'
4755       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4756       itypi=iabs(itype(i))
4757       xi=c(1,nres+i)
4758       yi=c(2,nres+i)
4759       zi=c(3,nres+i)
4760       dxi=dc_norm(1,nres+i)
4761       dyi=dc_norm(2,nres+i)
4762       dzi=dc_norm(3,nres+i)
4763 c      dsci_inv=dsc_inv(itypi)
4764       dsci_inv=vbld_inv(nres+i)
4765       itypj=iabs(itype(j))
4766 c      dscj_inv=dsc_inv(itypj)
4767       dscj_inv=vbld_inv(nres+j)
4768       xj=c(1,nres+j)-xi
4769       yj=c(2,nres+j)-yi
4770       zj=c(3,nres+j)-zi
4771       dxj=dc_norm(1,nres+j)
4772       dyj=dc_norm(2,nres+j)
4773       dzj=dc_norm(3,nres+j)
4774       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4775       rij=dsqrt(rrij)
4776       erij(1)=xj*rij
4777       erij(2)=yj*rij
4778       erij(3)=zj*rij
4779       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4780       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4781       om12=dxi*dxj+dyi*dyj+dzi*dzj
4782       do k=1,3
4783         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4784         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4785       enddo
4786       rij=1.0d0/rij
4787       deltad=rij-d0cm
4788       deltat1=1.0d0-om1
4789       deltat2=1.0d0+om2
4790       deltat12=om2-om1+2.0d0
4791       cosphi=om12-om1*om2
4792       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4793      &  +akct*deltad*deltat12
4794      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4795 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4796 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4797 c     &  " deltat12",deltat12," eij",eij
4798       ed=2*akcm*deltad+akct*deltat12
4799       pom1=akct*deltad
4800       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4801       eom1=-2*akth*deltat1-pom1-om2*pom2
4802       eom2= 2*akth*deltat2+pom1-om1*pom2
4803       eom12=pom2
4804       do k=1,3
4805         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4806         ghpbx(k,i)=ghpbx(k,i)-ggk
4807      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4808      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4809         ghpbx(k,j)=ghpbx(k,j)+ggk
4810      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4811      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4812         ghpbc(k,i)=ghpbc(k,i)-ggk
4813         ghpbc(k,j)=ghpbc(k,j)+ggk
4814       enddo
4815 C
4816 C Calculate the components of the gradient in DC and X
4817 C
4818 cgrad      do k=i,j-1
4819 cgrad        do l=1,3
4820 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4821 cgrad        enddo
4822 cgrad      enddo
4823       return
4824       end
4825 C--------------------------------------------------------------------------
4826       subroutine ebond(estr)
4827 c
4828 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4829 c
4830       implicit real*8 (a-h,o-z)
4831       include 'DIMENSIONS'
4832       include 'COMMON.LOCAL'
4833       include 'COMMON.GEO'
4834       include 'COMMON.INTERACT'
4835       include 'COMMON.DERIV'
4836       include 'COMMON.VAR'
4837       include 'COMMON.CHAIN'
4838       include 'COMMON.IOUNITS'
4839       include 'COMMON.NAMES'
4840       include 'COMMON.FFIELD'
4841       include 'COMMON.CONTROL'
4842       include 'COMMON.SETUP'
4843       double precision u(3),ud(3)
4844       estr=0.0d0
4845       estr1=0.0d0
4846       do i=ibondp_start,ibondp_end
4847         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4848 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4849 c          do j=1,3
4850 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4851 c     &      *dc(j,i-1)/vbld(i)
4852 c          enddo
4853 c          if (energy_dec) write(iout,*)
4854 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4855 c        else
4856 C       Checking if it involves dummy (NH3+ or COO-) group
4857          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4858 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4859         diff = vbld(i)-vbldpDUM
4860          else
4861 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4862         diff = vbld(i)-vbldp0
4863          endif
4864         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4865      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4866         estr=estr+diff*diff
4867         do j=1,3
4868           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4869         enddo
4870 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4871 c        endif
4872       enddo
4873       estr=0.5d0*AKP*estr+estr1
4874 c
4875 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4876 c
4877       do i=ibond_start,ibond_end
4878         iti=iabs(itype(i))
4879         if (iti.ne.10 .and. iti.ne.ntyp1) then
4880           nbi=nbondterm(iti)
4881           if (nbi.eq.1) then
4882             diff=vbld(i+nres)-vbldsc0(1,iti)
4883             if (energy_dec)  write (iout,*)
4884      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4885      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4886             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4887             do j=1,3
4888               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4889             enddo
4890           else
4891             do j=1,nbi
4892               diff=vbld(i+nres)-vbldsc0(j,iti)
4893               ud(j)=aksc(j,iti)*diff
4894               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4895             enddo
4896             uprod=u(1)
4897             do j=2,nbi
4898               uprod=uprod*u(j)
4899             enddo
4900             usum=0.0d0
4901             usumsqder=0.0d0
4902             do j=1,nbi
4903               uprod1=1.0d0
4904               uprod2=1.0d0
4905               do k=1,nbi
4906                 if (k.ne.j) then
4907                   uprod1=uprod1*u(k)
4908                   uprod2=uprod2*u(k)*u(k)
4909                 endif
4910               enddo
4911               usum=usum+uprod1
4912               usumsqder=usumsqder+ud(j)*uprod2
4913             enddo
4914             estr=estr+uprod/usum
4915             do j=1,3
4916              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4917             enddo
4918           endif
4919         endif
4920       enddo
4921       return
4922       end
4923 #ifdef CRYST_THETA
4924 C--------------------------------------------------------------------------
4925       subroutine ebend(etheta)
4926 C
4927 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4928 C angles gamma and its derivatives in consecutive thetas and gammas.
4929 C
4930       implicit real*8 (a-h,o-z)
4931       include 'DIMENSIONS'
4932       include 'COMMON.LOCAL'
4933       include 'COMMON.GEO'
4934       include 'COMMON.INTERACT'
4935       include 'COMMON.DERIV'
4936       include 'COMMON.VAR'
4937       include 'COMMON.CHAIN'
4938       include 'COMMON.IOUNITS'
4939       include 'COMMON.NAMES'
4940       include 'COMMON.FFIELD'
4941       include 'COMMON.CONTROL'
4942       common /calcthet/ term1,term2,termm,diffak,ratak,
4943      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4944      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4945       double precision y(2),z(2)
4946       delta=0.02d0*pi
4947 c      time11=dexp(-2*time)
4948 c      time12=1.0d0
4949       etheta=0.0D0
4950 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4951       do i=ithet_start,ithet_end
4952         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4953      &  .or.itype(i).eq.ntyp1) cycle
4954 C Zero the energy function and its derivative at 0 or pi.
4955         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4956         it=itype(i-1)
4957         ichir1=isign(1,itype(i-2))
4958         ichir2=isign(1,itype(i))
4959          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4960          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4961          if (itype(i-1).eq.10) then
4962           itype1=isign(10,itype(i-2))
4963           ichir11=isign(1,itype(i-2))
4964           ichir12=isign(1,itype(i-2))
4965           itype2=isign(10,itype(i))
4966           ichir21=isign(1,itype(i))
4967           ichir22=isign(1,itype(i))
4968          endif
4969
4970         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4971 #ifdef OSF
4972           phii=phi(i)
4973           if (phii.ne.phii) phii=150.0
4974 #else
4975           phii=phi(i)
4976 #endif
4977           y(1)=dcos(phii)
4978           y(2)=dsin(phii)
4979         else
4980           y(1)=0.0D0
4981           y(2)=0.0D0
4982         endif
4983         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4984 #ifdef OSF
4985           phii1=phi(i+1)
4986           if (phii1.ne.phii1) phii1=150.0
4987           phii1=pinorm(phii1)
4988           z(1)=cos(phii1)
4989 #else
4990           phii1=phi(i+1)
4991 #endif
4992           z(1)=dcos(phii1)
4993           z(2)=dsin(phii1)
4994         else
4995           z(1)=0.0D0
4996           z(2)=0.0D0
4997         endif
4998 C Calculate the "mean" value of theta from the part of the distribution
4999 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5000 C In following comments this theta will be referred to as t_c.
5001         thet_pred_mean=0.0d0
5002         do k=1,2
5003             athetk=athet(k,it,ichir1,ichir2)
5004             bthetk=bthet(k,it,ichir1,ichir2)
5005           if (it.eq.10) then
5006              athetk=athet(k,itype1,ichir11,ichir12)
5007              bthetk=bthet(k,itype2,ichir21,ichir22)
5008           endif
5009          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5010 c         write(iout,*) 'chuj tu', y(k),z(k)
5011         enddo
5012         dthett=thet_pred_mean*ssd
5013         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5014 C Derivatives of the "mean" values in gamma1 and gamma2.
5015         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5016      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5017          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5018      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5019          if (it.eq.10) then
5020       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5021      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5022         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5023      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5024          endif
5025         if (theta(i).gt.pi-delta) then
5026           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5027      &         E_tc0)
5028           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5029           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5030           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5031      &        E_theta)
5032           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5033      &        E_tc)
5034         else if (theta(i).lt.delta) then
5035           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5036           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5037           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5038      &        E_theta)
5039           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5040           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5041      &        E_tc)
5042         else
5043           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5044      &        E_theta,E_tc)
5045         endif
5046         etheta=etheta+ethetai
5047         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5048      &      'ebend',i,ethetai,theta(i),itype(i)
5049         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5050         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5051         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5052       enddo
5053 C Ufff.... We've done all this!!!
5054       return
5055       end
5056 C---------------------------------------------------------------------------
5057       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5058      &     E_tc)
5059       implicit real*8 (a-h,o-z)
5060       include 'DIMENSIONS'
5061       include 'COMMON.LOCAL'
5062       include 'COMMON.IOUNITS'
5063       common /calcthet/ term1,term2,termm,diffak,ratak,
5064      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5065      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5066 C Calculate the contributions to both Gaussian lobes.
5067 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5068 C The "polynomial part" of the "standard deviation" of this part of
5069 C the distributioni.
5070 ccc        write (iout,*) thetai,thet_pred_mean
5071         sig=polthet(3,it)
5072         do j=2,0,-1
5073           sig=sig*thet_pred_mean+polthet(j,it)
5074         enddo
5075 C Derivative of the "interior part" of the "standard deviation of the"
5076 C gamma-dependent Gaussian lobe in t_c.
5077         sigtc=3*polthet(3,it)
5078         do j=2,1,-1
5079           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5080         enddo
5081         sigtc=sig*sigtc
5082 C Set the parameters of both Gaussian lobes of the distribution.
5083 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5084         fac=sig*sig+sigc0(it)
5085         sigcsq=fac+fac
5086         sigc=1.0D0/sigcsq
5087 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5088         sigsqtc=-4.0D0*sigcsq*sigtc
5089 c       print *,i,sig,sigtc,sigsqtc
5090 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5091         sigtc=-sigtc/(fac*fac)
5092 C Following variable is sigma(t_c)**(-2)
5093         sigcsq=sigcsq*sigcsq
5094         sig0i=sig0(it)
5095         sig0inv=1.0D0/sig0i**2
5096         delthec=thetai-thet_pred_mean
5097         delthe0=thetai-theta0i
5098         term1=-0.5D0*sigcsq*delthec*delthec
5099         term2=-0.5D0*sig0inv*delthe0*delthe0
5100 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5101 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5102 C NaNs in taking the logarithm. We extract the largest exponent which is added
5103 C to the energy (this being the log of the distribution) at the end of energy
5104 C term evaluation for this virtual-bond angle.
5105         if (term1.gt.term2) then
5106           termm=term1
5107           term2=dexp(term2-termm)
5108           term1=1.0d0
5109         else
5110           termm=term2
5111           term1=dexp(term1-termm)
5112           term2=1.0d0
5113         endif
5114 C The ratio between the gamma-independent and gamma-dependent lobes of
5115 C the distribution is a Gaussian function of thet_pred_mean too.
5116         diffak=gthet(2,it)-thet_pred_mean
5117         ratak=diffak/gthet(3,it)**2
5118         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5119 C Let's differentiate it in thet_pred_mean NOW.
5120         aktc=ak*ratak
5121 C Now put together the distribution terms to make complete distribution.
5122         termexp=term1+ak*term2
5123         termpre=sigc+ak*sig0i
5124 C Contribution of the bending energy from this theta is just the -log of
5125 C the sum of the contributions from the two lobes and the pre-exponential
5126 C factor. Simple enough, isn't it?
5127         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5128 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5129 C NOW the derivatives!!!
5130 C 6/6/97 Take into account the deformation.
5131         E_theta=(delthec*sigcsq*term1
5132      &       +ak*delthe0*sig0inv*term2)/termexp
5133         E_tc=((sigtc+aktc*sig0i)/termpre
5134      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5135      &       aktc*term2)/termexp)
5136       return
5137       end
5138 c-----------------------------------------------------------------------------
5139       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5140       implicit real*8 (a-h,o-z)
5141       include 'DIMENSIONS'
5142       include 'COMMON.LOCAL'
5143       include 'COMMON.IOUNITS'
5144       common /calcthet/ term1,term2,termm,diffak,ratak,
5145      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5146      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5147       delthec=thetai-thet_pred_mean
5148       delthe0=thetai-theta0i
5149 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5150       t3 = thetai-thet_pred_mean
5151       t6 = t3**2
5152       t9 = term1
5153       t12 = t3*sigcsq
5154       t14 = t12+t6*sigsqtc
5155       t16 = 1.0d0
5156       t21 = thetai-theta0i
5157       t23 = t21**2
5158       t26 = term2
5159       t27 = t21*t26
5160       t32 = termexp
5161       t40 = t32**2
5162       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5163      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5164      & *(-t12*t9-ak*sig0inv*t27)
5165       return
5166       end
5167 #else
5168 C--------------------------------------------------------------------------
5169       subroutine ebend(etheta)
5170 C
5171 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5172 C angles gamma and its derivatives in consecutive thetas and gammas.
5173 C ab initio-derived potentials from
5174 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5175 C
5176       implicit real*8 (a-h,o-z)
5177       include 'DIMENSIONS'
5178       include 'COMMON.LOCAL'
5179       include 'COMMON.GEO'
5180       include 'COMMON.INTERACT'
5181       include 'COMMON.DERIV'
5182       include 'COMMON.VAR'
5183       include 'COMMON.CHAIN'
5184       include 'COMMON.IOUNITS'
5185       include 'COMMON.NAMES'
5186       include 'COMMON.FFIELD'
5187       include 'COMMON.CONTROL'
5188       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5189      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5190      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5191      & sinph1ph2(maxdouble,maxdouble)
5192       logical lprn /.false./, lprn1 /.false./
5193       etheta=0.0D0
5194       do i=ithet_start,ithet_end
5195 c        print *,i,itype(i-1),itype(i),itype(i-2)
5196         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5197      &  .or.itype(i).eq.ntyp1) cycle
5198 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5199
5200         if (iabs(itype(i+1)).eq.20) iblock=2
5201         if (iabs(itype(i+1)).ne.20) iblock=1
5202         dethetai=0.0d0
5203         dephii=0.0d0
5204         dephii1=0.0d0
5205         theti2=0.5d0*theta(i)
5206         ityp2=ithetyp((itype(i-1)))
5207         do k=1,nntheterm
5208           coskt(k)=dcos(k*theti2)
5209           sinkt(k)=dsin(k*theti2)
5210         enddo
5211         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5212 #ifdef OSF
5213           phii=phi(i)
5214           if (phii.ne.phii) phii=150.0
5215 #else
5216           phii=phi(i)
5217 #endif
5218           ityp1=ithetyp((itype(i-2)))
5219 C propagation of chirality for glycine type
5220           do k=1,nsingle
5221             cosph1(k)=dcos(k*phii)
5222             sinph1(k)=dsin(k*phii)
5223           enddo
5224         else
5225           phii=0.0d0
5226           ityp1=nthetyp+1
5227           do k=1,nsingle
5228             cosph1(k)=0.0d0
5229             sinph1(k)=0.0d0
5230           enddo
5231         endif
5232         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5233 #ifdef OSF
5234           phii1=phi(i+1)
5235           if (phii1.ne.phii1) phii1=150.0
5236           phii1=pinorm(phii1)
5237 #else
5238           phii1=phi(i+1)
5239 #endif
5240           ityp3=ithetyp((itype(i)))
5241           do k=1,nsingle
5242             cosph2(k)=dcos(k*phii1)
5243             sinph2(k)=dsin(k*phii1)
5244           enddo
5245         else
5246           phii1=0.0d0
5247           ityp3=nthetyp+1
5248           do k=1,nsingle
5249             cosph2(k)=0.0d0
5250             sinph2(k)=0.0d0
5251           enddo
5252         endif
5253         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5254         do k=1,ndouble
5255           do l=1,k-1
5256             ccl=cosph1(l)*cosph2(k-l)
5257             ssl=sinph1(l)*sinph2(k-l)
5258             scl=sinph1(l)*cosph2(k-l)
5259             csl=cosph1(l)*sinph2(k-l)
5260             cosph1ph2(l,k)=ccl-ssl
5261             cosph1ph2(k,l)=ccl+ssl
5262             sinph1ph2(l,k)=scl+csl
5263             sinph1ph2(k,l)=scl-csl
5264           enddo
5265         enddo
5266         if (lprn) then
5267         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5268      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5269         write (iout,*) "coskt and sinkt"
5270         do k=1,nntheterm
5271           write (iout,*) k,coskt(k),sinkt(k)
5272         enddo
5273         endif
5274         do k=1,ntheterm
5275           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5276           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5277      &      *coskt(k)
5278           if (lprn)
5279      &    write (iout,*) "k",k,"
5280      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5281      &     " ethetai",ethetai
5282         enddo
5283         if (lprn) then
5284         write (iout,*) "cosph and sinph"
5285         do k=1,nsingle
5286           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5287         enddo
5288         write (iout,*) "cosph1ph2 and sinph2ph2"
5289         do k=2,ndouble
5290           do l=1,k-1
5291             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5292      &         sinph1ph2(l,k),sinph1ph2(k,l)
5293           enddo
5294         enddo
5295         write(iout,*) "ethetai",ethetai
5296         endif
5297         do m=1,ntheterm2
5298           do k=1,nsingle
5299             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5300      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5301      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5302      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5303             ethetai=ethetai+sinkt(m)*aux
5304             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5305             dephii=dephii+k*sinkt(m)*(
5306      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5307      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5308             dephii1=dephii1+k*sinkt(m)*(
5309      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5310      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5311             if (lprn)
5312      &      write (iout,*) "m",m," k",k," bbthet",
5313      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5314      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5315      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5316      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5317           enddo
5318         enddo
5319         if (lprn)
5320      &  write(iout,*) "ethetai",ethetai
5321         do m=1,ntheterm3
5322           do k=2,ndouble
5323             do l=1,k-1
5324               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5325      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5326      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5327      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5328               ethetai=ethetai+sinkt(m)*aux
5329               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5330               dephii=dephii+l*sinkt(m)*(
5331      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5332      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5333      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5334      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5335               dephii1=dephii1+(k-l)*sinkt(m)*(
5336      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5337      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5338      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5339      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5340               if (lprn) then
5341               write (iout,*) "m",m," k",k," l",l," ffthet",
5342      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5343      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5344      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5345      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5346      &            " ethetai",ethetai
5347               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5348      &            cosph1ph2(k,l)*sinkt(m),
5349      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5350               endif
5351             enddo
5352           enddo
5353         enddo
5354 10      continue
5355 c        lprn1=.true.
5356         if (lprn1)
5357      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5358      &   i,theta(i)*rad2deg,phii*rad2deg,
5359      &   phii1*rad2deg,ethetai
5360 c        lprn1=.false.
5361         etheta=etheta+ethetai
5362         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5363         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5364         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5365       enddo
5366       return
5367       end
5368 #endif
5369 #ifdef CRYST_SC
5370 c-----------------------------------------------------------------------------
5371       subroutine esc(escloc)
5372 C Calculate the local energy of a side chain and its derivatives in the
5373 C corresponding virtual-bond valence angles THETA and the spherical angles
5374 C ALPHA and OMEGA.
5375       implicit real*8 (a-h,o-z)
5376       include 'DIMENSIONS'
5377       include 'COMMON.GEO'
5378       include 'COMMON.LOCAL'
5379       include 'COMMON.VAR'
5380       include 'COMMON.INTERACT'
5381       include 'COMMON.DERIV'
5382       include 'COMMON.CHAIN'
5383       include 'COMMON.IOUNITS'
5384       include 'COMMON.NAMES'
5385       include 'COMMON.FFIELD'
5386       include 'COMMON.CONTROL'
5387       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5388      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5389       common /sccalc/ time11,time12,time112,theti,it,nlobit
5390       delta=0.02d0*pi
5391       escloc=0.0D0
5392 c     write (iout,'(a)') 'ESC'
5393       do i=loc_start,loc_end
5394         it=itype(i)
5395         if (it.eq.ntyp1) cycle
5396         if (it.eq.10) goto 1
5397         nlobit=nlob(iabs(it))
5398 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5399 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5400         theti=theta(i+1)-pipol
5401         x(1)=dtan(theti)
5402         x(2)=alph(i)
5403         x(3)=omeg(i)
5404
5405         if (x(2).gt.pi-delta) then
5406           xtemp(1)=x(1)
5407           xtemp(2)=pi-delta
5408           xtemp(3)=x(3)
5409           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5410           xtemp(2)=pi
5411           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5412           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5413      &        escloci,dersc(2))
5414           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5415      &        ddersc0(1),dersc(1))
5416           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5417      &        ddersc0(3),dersc(3))
5418           xtemp(2)=pi-delta
5419           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5420           xtemp(2)=pi
5421           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5422           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5423      &            dersc0(2),esclocbi,dersc02)
5424           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5425      &            dersc12,dersc01)
5426           call splinthet(x(2),0.5d0*delta,ss,ssd)
5427           dersc0(1)=dersc01
5428           dersc0(2)=dersc02
5429           dersc0(3)=0.0d0
5430           do k=1,3
5431             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5432           enddo
5433           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5434 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5435 c    &             esclocbi,ss,ssd
5436           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5437 c         escloci=esclocbi
5438 c         write (iout,*) escloci
5439         else if (x(2).lt.delta) then
5440           xtemp(1)=x(1)
5441           xtemp(2)=delta
5442           xtemp(3)=x(3)
5443           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5444           xtemp(2)=0.0d0
5445           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5446           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5447      &        escloci,dersc(2))
5448           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5449      &        ddersc0(1),dersc(1))
5450           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5451      &        ddersc0(3),dersc(3))
5452           xtemp(2)=delta
5453           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5454           xtemp(2)=0.0d0
5455           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5456           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5457      &            dersc0(2),esclocbi,dersc02)
5458           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5459      &            dersc12,dersc01)
5460           dersc0(1)=dersc01
5461           dersc0(2)=dersc02
5462           dersc0(3)=0.0d0
5463           call splinthet(x(2),0.5d0*delta,ss,ssd)
5464           do k=1,3
5465             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5466           enddo
5467           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5468 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5469 c    &             esclocbi,ss,ssd
5470           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5471 c         write (iout,*) escloci
5472         else
5473           call enesc(x,escloci,dersc,ddummy,.false.)
5474         endif
5475
5476         escloc=escloc+escloci
5477         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5478      &     'escloc',i,escloci
5479 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5480
5481         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5482      &   wscloc*dersc(1)
5483         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5484         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5485     1   continue
5486       enddo
5487       return
5488       end
5489 C---------------------------------------------------------------------------
5490       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5491       implicit real*8 (a-h,o-z)
5492       include 'DIMENSIONS'
5493       include 'COMMON.GEO'
5494       include 'COMMON.LOCAL'
5495       include 'COMMON.IOUNITS'
5496       common /sccalc/ time11,time12,time112,theti,it,nlobit
5497       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5498       double precision contr(maxlob,-1:1)
5499       logical mixed
5500 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5501         escloc_i=0.0D0
5502         do j=1,3
5503           dersc(j)=0.0D0
5504           if (mixed) ddersc(j)=0.0d0
5505         enddo
5506         x3=x(3)
5507
5508 C Because of periodicity of the dependence of the SC energy in omega we have
5509 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5510 C To avoid underflows, first compute & store the exponents.
5511
5512         do iii=-1,1
5513
5514           x(3)=x3+iii*dwapi
5515
5516           do j=1,nlobit
5517             do k=1,3
5518               z(k)=x(k)-censc(k,j,it)
5519             enddo
5520             do k=1,3
5521               Axk=0.0D0
5522               do l=1,3
5523                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5524               enddo
5525               Ax(k,j,iii)=Axk
5526             enddo
5527             expfac=0.0D0
5528             do k=1,3
5529               expfac=expfac+Ax(k,j,iii)*z(k)
5530             enddo
5531             contr(j,iii)=expfac
5532           enddo ! j
5533
5534         enddo ! iii
5535
5536         x(3)=x3
5537 C As in the case of ebend, we want to avoid underflows in exponentiation and
5538 C subsequent NaNs and INFs in energy calculation.
5539 C Find the largest exponent
5540         emin=contr(1,-1)
5541         do iii=-1,1
5542           do j=1,nlobit
5543             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5544           enddo
5545         enddo
5546         emin=0.5D0*emin
5547 cd      print *,'it=',it,' emin=',emin
5548
5549 C Compute the contribution to SC energy and derivatives
5550         do iii=-1,1
5551
5552           do j=1,nlobit
5553 #ifdef OSF
5554             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5555             if(adexp.ne.adexp) adexp=1.0
5556             expfac=dexp(adexp)
5557 #else
5558             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5559 #endif
5560 cd          print *,'j=',j,' expfac=',expfac
5561             escloc_i=escloc_i+expfac
5562             do k=1,3
5563               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5564             enddo
5565             if (mixed) then
5566               do k=1,3,2
5567                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5568      &            +gaussc(k,2,j,it))*expfac
5569               enddo
5570             endif
5571           enddo
5572
5573         enddo ! iii
5574
5575         dersc(1)=dersc(1)/cos(theti)**2
5576         ddersc(1)=ddersc(1)/cos(theti)**2
5577         ddersc(3)=ddersc(3)
5578
5579         escloci=-(dlog(escloc_i)-emin)
5580         do j=1,3
5581           dersc(j)=dersc(j)/escloc_i
5582         enddo
5583         if (mixed) then
5584           do j=1,3,2
5585             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5586           enddo
5587         endif
5588       return
5589       end
5590 C------------------------------------------------------------------------------
5591       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5592       implicit real*8 (a-h,o-z)
5593       include 'DIMENSIONS'
5594       include 'COMMON.GEO'
5595       include 'COMMON.LOCAL'
5596       include 'COMMON.IOUNITS'
5597       common /sccalc/ time11,time12,time112,theti,it,nlobit
5598       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5599       double precision contr(maxlob)
5600       logical mixed
5601
5602       escloc_i=0.0D0
5603
5604       do j=1,3
5605         dersc(j)=0.0D0
5606       enddo
5607
5608       do j=1,nlobit
5609         do k=1,2
5610           z(k)=x(k)-censc(k,j,it)
5611         enddo
5612         z(3)=dwapi
5613         do k=1,3
5614           Axk=0.0D0
5615           do l=1,3
5616             Axk=Axk+gaussc(l,k,j,it)*z(l)
5617           enddo
5618           Ax(k,j)=Axk
5619         enddo
5620         expfac=0.0D0
5621         do k=1,3
5622           expfac=expfac+Ax(k,j)*z(k)
5623         enddo
5624         contr(j)=expfac
5625       enddo ! j
5626
5627 C As in the case of ebend, we want to avoid underflows in exponentiation and
5628 C subsequent NaNs and INFs in energy calculation.
5629 C Find the largest exponent
5630       emin=contr(1)
5631       do j=1,nlobit
5632         if (emin.gt.contr(j)) emin=contr(j)
5633       enddo
5634       emin=0.5D0*emin
5635
5636 C Compute the contribution to SC energy and derivatives
5637
5638       dersc12=0.0d0
5639       do j=1,nlobit
5640         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5641         escloc_i=escloc_i+expfac
5642         do k=1,2
5643           dersc(k)=dersc(k)+Ax(k,j)*expfac
5644         enddo
5645         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5646      &            +gaussc(1,2,j,it))*expfac
5647         dersc(3)=0.0d0
5648       enddo
5649
5650       dersc(1)=dersc(1)/cos(theti)**2
5651       dersc12=dersc12/cos(theti)**2
5652       escloci=-(dlog(escloc_i)-emin)
5653       do j=1,2
5654         dersc(j)=dersc(j)/escloc_i
5655       enddo
5656       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5657       return
5658       end
5659 #else
5660 c----------------------------------------------------------------------------------
5661       subroutine esc(escloc)
5662 C Calculate the local energy of a side chain and its derivatives in the
5663 C corresponding virtual-bond valence angles THETA and the spherical angles
5664 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5665 C added by Urszula Kozlowska. 07/11/2007
5666 C
5667       implicit real*8 (a-h,o-z)
5668       include 'DIMENSIONS'
5669       include 'COMMON.GEO'
5670       include 'COMMON.LOCAL'
5671       include 'COMMON.VAR'
5672       include 'COMMON.SCROT'
5673       include 'COMMON.INTERACT'
5674       include 'COMMON.DERIV'
5675       include 'COMMON.CHAIN'
5676       include 'COMMON.IOUNITS'
5677       include 'COMMON.NAMES'
5678       include 'COMMON.FFIELD'
5679       include 'COMMON.CONTROL'
5680       include 'COMMON.VECTORS'
5681       double precision x_prime(3),y_prime(3),z_prime(3)
5682      &    , sumene,dsc_i,dp2_i,x(65),
5683      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5684      &    de_dxx,de_dyy,de_dzz,de_dt
5685       double precision s1_t,s1_6_t,s2_t,s2_6_t
5686       double precision
5687      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5688      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5689      & dt_dCi(3),dt_dCi1(3)
5690       common /sccalc/ time11,time12,time112,theti,it,nlobit
5691       delta=0.02d0*pi
5692       escloc=0.0D0
5693       do i=loc_start,loc_end
5694         if (itype(i).eq.ntyp1) cycle
5695         costtab(i+1) =dcos(theta(i+1))
5696         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5697         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5698         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5699         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5700         cosfac=dsqrt(cosfac2)
5701         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5702         sinfac=dsqrt(sinfac2)
5703         it=iabs(itype(i))
5704         if (it.eq.10) goto 1
5705 c
5706 C  Compute the axes of tghe local cartesian coordinates system; store in
5707 c   x_prime, y_prime and z_prime
5708 c
5709         do j=1,3
5710           x_prime(j) = 0.00
5711           y_prime(j) = 0.00
5712           z_prime(j) = 0.00
5713         enddo
5714 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5715 C     &   dc_norm(3,i+nres)
5716         do j = 1,3
5717           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5718           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5719         enddo
5720         do j = 1,3
5721           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5722         enddo
5723 c       write (2,*) "i",i
5724 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5725 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5726 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5727 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5728 c      & " xy",scalar(x_prime(1),y_prime(1)),
5729 c      & " xz",scalar(x_prime(1),z_prime(1)),
5730 c      & " yy",scalar(y_prime(1),y_prime(1)),
5731 c      & " yz",scalar(y_prime(1),z_prime(1)),
5732 c      & " zz",scalar(z_prime(1),z_prime(1))
5733 c
5734 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5735 C to local coordinate system. Store in xx, yy, zz.
5736 c
5737         xx=0.0d0
5738         yy=0.0d0
5739         zz=0.0d0
5740         do j = 1,3
5741           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5742           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5743           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5744         enddo
5745
5746         xxtab(i)=xx
5747         yytab(i)=yy
5748         zztab(i)=zz
5749 C
5750 C Compute the energy of the ith side cbain
5751 C
5752 c        write (2,*) "xx",xx," yy",yy," zz",zz
5753         it=iabs(itype(i))
5754         do j = 1,65
5755           x(j) = sc_parmin(j,it)
5756         enddo
5757 #ifdef CHECK_COORD
5758 Cc diagnostics - remove later
5759         xx1 = dcos(alph(2))
5760         yy1 = dsin(alph(2))*dcos(omeg(2))
5761         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5762         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5763      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5764      &    xx1,yy1,zz1
5765 C,"  --- ", xx_w,yy_w,zz_w
5766 c end diagnostics
5767 #endif
5768         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5769      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5770      &   + x(10)*yy*zz
5771         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5772      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5773      & + x(20)*yy*zz
5774         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5775      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5776      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5777      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5778      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5779      &  +x(40)*xx*yy*zz
5780         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5781      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5782      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5783      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5784      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5785      &  +x(60)*xx*yy*zz
5786         dsc_i   = 0.743d0+x(61)
5787         dp2_i   = 1.9d0+x(62)
5788         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5789      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5790         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5791      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5792         s1=(1+x(63))/(0.1d0 + dscp1)
5793         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5794         s2=(1+x(65))/(0.1d0 + dscp2)
5795         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5796         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5797      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5798 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5799 c     &   sumene4,
5800 c     &   dscp1,dscp2,sumene
5801 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5802         escloc = escloc + sumene
5803 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5804 c     & ,zz,xx,yy
5805 c#define DEBUG
5806 #ifdef DEBUG
5807 C
5808 C This section to check the numerical derivatives of the energy of ith side
5809 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5810 C #define DEBUG in the code to turn it on.
5811 C
5812         write (2,*) "sumene               =",sumene
5813         aincr=1.0d-7
5814         xxsave=xx
5815         xx=xx+aincr
5816         write (2,*) xx,yy,zz
5817         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5818         de_dxx_num=(sumenep-sumene)/aincr
5819         xx=xxsave
5820         write (2,*) "xx+ sumene from enesc=",sumenep
5821         yysave=yy
5822         yy=yy+aincr
5823         write (2,*) xx,yy,zz
5824         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5825         de_dyy_num=(sumenep-sumene)/aincr
5826         yy=yysave
5827         write (2,*) "yy+ sumene from enesc=",sumenep
5828         zzsave=zz
5829         zz=zz+aincr
5830         write (2,*) xx,yy,zz
5831         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5832         de_dzz_num=(sumenep-sumene)/aincr
5833         zz=zzsave
5834         write (2,*) "zz+ sumene from enesc=",sumenep
5835         costsave=cost2tab(i+1)
5836         sintsave=sint2tab(i+1)
5837         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5838         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5839         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5840         de_dt_num=(sumenep-sumene)/aincr
5841         write (2,*) " t+ sumene from enesc=",sumenep
5842         cost2tab(i+1)=costsave
5843         sint2tab(i+1)=sintsave
5844 C End of diagnostics section.
5845 #endif
5846 C
5847 C Compute the gradient of esc
5848 C
5849 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5850         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5851         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5852         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5853         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5854         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5855         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5856         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5857         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5858         pom1=(sumene3*sint2tab(i+1)+sumene1)
5859      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5860         pom2=(sumene4*cost2tab(i+1)+sumene2)
5861      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5862         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5863         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5864      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5865      &  +x(40)*yy*zz
5866         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5867         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5868      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5869      &  +x(60)*yy*zz
5870         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5871      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5872      &        +(pom1+pom2)*pom_dx
5873 #ifdef DEBUG
5874         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5875 #endif
5876 C
5877         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5878         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5879      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5880      &  +x(40)*xx*zz
5881         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5882         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5883      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5884      &  +x(59)*zz**2 +x(60)*xx*zz
5885         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5886      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5887      &        +(pom1-pom2)*pom_dy
5888 #ifdef DEBUG
5889         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5890 #endif
5891 C
5892         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5893      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5894      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5895      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5896      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5897      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5898      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5899      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5900 #ifdef DEBUG
5901         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5902 #endif
5903 C
5904         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5905      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5906      &  +pom1*pom_dt1+pom2*pom_dt2
5907 #ifdef DEBUG
5908         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5909 #endif
5910 c#undef DEBUG
5911 c
5912 C
5913        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5914        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5915        cosfac2xx=cosfac2*xx
5916        sinfac2yy=sinfac2*yy
5917        do k = 1,3
5918          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5919      &      vbld_inv(i+1)
5920          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5921      &      vbld_inv(i)
5922          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5923          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5924 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5925 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5926 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5927 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5928          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5929          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5930          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5931          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5932          dZZ_Ci1(k)=0.0d0
5933          dZZ_Ci(k)=0.0d0
5934          do j=1,3
5935            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5936      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5937            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5938      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5939          enddo
5940
5941          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5942          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5943          dZZ_XYZ(k)=vbld_inv(i+nres)*
5944      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5945 c
5946          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5947          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5948        enddo
5949
5950        do k=1,3
5951          dXX_Ctab(k,i)=dXX_Ci(k)
5952          dXX_C1tab(k,i)=dXX_Ci1(k)
5953          dYY_Ctab(k,i)=dYY_Ci(k)
5954          dYY_C1tab(k,i)=dYY_Ci1(k)
5955          dZZ_Ctab(k,i)=dZZ_Ci(k)
5956          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5957          dXX_XYZtab(k,i)=dXX_XYZ(k)
5958          dYY_XYZtab(k,i)=dYY_XYZ(k)
5959          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5960        enddo
5961
5962        do k = 1,3
5963 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5964 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5965 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5966 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5967 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5968 c     &    dt_dci(k)
5969 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5970 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5971          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5972      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5973          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5974      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5975          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5976      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5977        enddo
5978 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5979 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5980
5981 C to check gradient call subroutine check_grad
5982
5983     1 continue
5984       enddo
5985       return
5986       end
5987 c------------------------------------------------------------------------------
5988       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5989       implicit none
5990       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5991      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5992       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5993      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5994      &   + x(10)*yy*zz
5995       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5996      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5997      & + x(20)*yy*zz
5998       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5999      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6000      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6001      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6002      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6003      &  +x(40)*xx*yy*zz
6004       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6005      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6006      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6007      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6008      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6009      &  +x(60)*xx*yy*zz
6010       dsc_i   = 0.743d0+x(61)
6011       dp2_i   = 1.9d0+x(62)
6012       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6013      &          *(xx*cost2+yy*sint2))
6014       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6015      &          *(xx*cost2-yy*sint2))
6016       s1=(1+x(63))/(0.1d0 + dscp1)
6017       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6018       s2=(1+x(65))/(0.1d0 + dscp2)
6019       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6020       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6021      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6022       enesc=sumene
6023       return
6024       end
6025 #endif
6026 c------------------------------------------------------------------------------
6027       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6028 C
6029 C This procedure calculates two-body contact function g(rij) and its derivative:
6030 C
6031 C           eps0ij                                     !       x < -1
6032 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6033 C            0                                         !       x > 1
6034 C
6035 C where x=(rij-r0ij)/delta
6036 C
6037 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6038 C
6039       implicit none
6040       double precision rij,r0ij,eps0ij,fcont,fprimcont
6041       double precision x,x2,x4,delta
6042 c     delta=0.02D0*r0ij
6043 c      delta=0.2D0*r0ij
6044       x=(rij-r0ij)/delta
6045       if (x.lt.-1.0D0) then
6046         fcont=eps0ij
6047         fprimcont=0.0D0
6048       else if (x.le.1.0D0) then
6049         x2=x*x
6050         x4=x2*x2
6051         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6052         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6053       else
6054         fcont=0.0D0
6055         fprimcont=0.0D0
6056       endif
6057       return
6058       end
6059 c------------------------------------------------------------------------------
6060       subroutine splinthet(theti,delta,ss,ssder)
6061       implicit real*8 (a-h,o-z)
6062       include 'DIMENSIONS'
6063       include 'COMMON.VAR'
6064       include 'COMMON.GEO'
6065       thetup=pi-delta
6066       thetlow=delta
6067       if (theti.gt.pipol) then
6068         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6069       else
6070         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6071         ssder=-ssder
6072       endif
6073       return
6074       end
6075 c------------------------------------------------------------------------------
6076       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6077       implicit none
6078       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6079       double precision ksi,ksi2,ksi3,a1,a2,a3
6080       a1=fprim0*delta/(f1-f0)
6081       a2=3.0d0-2.0d0*a1
6082       a3=a1-2.0d0
6083       ksi=(x-x0)/delta
6084       ksi2=ksi*ksi
6085       ksi3=ksi2*ksi
6086       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6087       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6088       return
6089       end
6090 c------------------------------------------------------------------------------
6091       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6092       implicit none
6093       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6094       double precision ksi,ksi2,ksi3,a1,a2,a3
6095       ksi=(x-x0)/delta
6096       ksi2=ksi*ksi
6097       ksi3=ksi2*ksi
6098       a1=fprim0x*delta
6099       a2=3*(f1x-f0x)-2*fprim0x*delta
6100       a3=fprim0x*delta-2*(f1x-f0x)
6101       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6102       return
6103       end
6104 C-----------------------------------------------------------------------------
6105 #ifdef CRYST_TOR
6106 C-----------------------------------------------------------------------------
6107       subroutine etor(etors,edihcnstr)
6108       implicit real*8 (a-h,o-z)
6109       include 'DIMENSIONS'
6110       include 'COMMON.VAR'
6111       include 'COMMON.GEO'
6112       include 'COMMON.LOCAL'
6113       include 'COMMON.TORSION'
6114       include 'COMMON.INTERACT'
6115       include 'COMMON.DERIV'
6116       include 'COMMON.CHAIN'
6117       include 'COMMON.NAMES'
6118       include 'COMMON.IOUNITS'
6119       include 'COMMON.FFIELD'
6120       include 'COMMON.TORCNSTR'
6121       include 'COMMON.CONTROL'
6122       logical lprn
6123 C Set lprn=.true. for debugging
6124       lprn=.false.
6125 c      lprn=.true.
6126       etors=0.0D0
6127       do i=iphi_start,iphi_end
6128       etors_ii=0.0D0
6129         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6130      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6131         itori=itortyp(itype(i-2))
6132         itori1=itortyp(itype(i-1))
6133         phii=phi(i)
6134         gloci=0.0D0
6135 C Proline-Proline pair is a special case...
6136         if (itori.eq.3 .and. itori1.eq.3) then
6137           if (phii.gt.-dwapi3) then
6138             cosphi=dcos(3*phii)
6139             fac=1.0D0/(1.0D0-cosphi)
6140             etorsi=v1(1,3,3)*fac
6141             etorsi=etorsi+etorsi
6142             etors=etors+etorsi-v1(1,3,3)
6143             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6144             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6145           endif
6146           do j=1,3
6147             v1ij=v1(j+1,itori,itori1)
6148             v2ij=v2(j+1,itori,itori1)
6149             cosphi=dcos(j*phii)
6150             sinphi=dsin(j*phii)
6151             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6152             if (energy_dec) etors_ii=etors_ii+
6153      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6154             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6155           enddo
6156         else
6157           do j=1,nterm_old
6158             v1ij=v1(j,itori,itori1)
6159             v2ij=v2(j,itori,itori1)
6160             cosphi=dcos(j*phii)
6161             sinphi=dsin(j*phii)
6162             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6163             if (energy_dec) etors_ii=etors_ii+
6164      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6165             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6166           enddo
6167         endif
6168         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6169              'etor',i,etors_ii
6170         if (lprn)
6171      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6172      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6173      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6174         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6175 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6176       enddo
6177 ! 6/20/98 - dihedral angle constraints
6178       edihcnstr=0.0d0
6179       do i=1,ndih_constr
6180         itori=idih_constr(i)
6181         phii=phi(itori)
6182         difi=phii-phi0(i)
6183         if (difi.gt.drange(i)) then
6184           difi=difi-drange(i)
6185           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6186           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6187         else if (difi.lt.-drange(i)) then
6188           difi=difi+drange(i)
6189           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6190           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6191         endif
6192 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6193 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6194       enddo
6195 !      write (iout,*) 'edihcnstr',edihcnstr
6196       return
6197       end
6198 c------------------------------------------------------------------------------
6199       subroutine etor_d(etors_d)
6200       etors_d=0.0d0
6201       return
6202       end
6203 c----------------------------------------------------------------------------
6204 #else
6205       subroutine etor(etors,edihcnstr)
6206       implicit real*8 (a-h,o-z)
6207       include 'DIMENSIONS'
6208       include 'COMMON.VAR'
6209       include 'COMMON.GEO'
6210       include 'COMMON.LOCAL'
6211       include 'COMMON.TORSION'
6212       include 'COMMON.INTERACT'
6213       include 'COMMON.DERIV'
6214       include 'COMMON.CHAIN'
6215       include 'COMMON.NAMES'
6216       include 'COMMON.IOUNITS'
6217       include 'COMMON.FFIELD'
6218       include 'COMMON.TORCNSTR'
6219       include 'COMMON.CONTROL'
6220       logical lprn
6221 C Set lprn=.true. for debugging
6222       lprn=.false.
6223 c     lprn=.true.
6224       etors=0.0D0
6225       do i=iphi_start,iphi_end
6226 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6227 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6228 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6229 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6230         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6231      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6232 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6233 C For introducing the NH3+ and COO- group please check the etor_d for reference
6234 C and guidance
6235         etors_ii=0.0D0
6236          if (iabs(itype(i)).eq.20) then
6237          iblock=2
6238          else
6239          iblock=1
6240          endif
6241         itori=itortyp(itype(i-2))
6242         itori1=itortyp(itype(i-1))
6243         phii=phi(i)
6244         gloci=0.0D0
6245 C Regular cosine and sine terms
6246         do j=1,nterm(itori,itori1,iblock)
6247           v1ij=v1(j,itori,itori1,iblock)
6248           v2ij=v2(j,itori,itori1,iblock)
6249           cosphi=dcos(j*phii)
6250           sinphi=dsin(j*phii)
6251           etors=etors+v1ij*cosphi+v2ij*sinphi
6252           if (energy_dec) etors_ii=etors_ii+
6253      &                v1ij*cosphi+v2ij*sinphi
6254           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6255         enddo
6256 C Lorentz terms
6257 C                         v1
6258 C  E = SUM ----------------------------------- - v1
6259 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6260 C
6261         cosphi=dcos(0.5d0*phii)
6262         sinphi=dsin(0.5d0*phii)
6263         do j=1,nlor(itori,itori1,iblock)
6264           vl1ij=vlor1(j,itori,itori1)
6265           vl2ij=vlor2(j,itori,itori1)
6266           vl3ij=vlor3(j,itori,itori1)
6267           pom=vl2ij*cosphi+vl3ij*sinphi
6268           pom1=1.0d0/(pom*pom+1.0d0)
6269           etors=etors+vl1ij*pom1
6270           if (energy_dec) etors_ii=etors_ii+
6271      &                vl1ij*pom1
6272           pom=-pom*pom1*pom1
6273           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6274         enddo
6275 C Subtract the constant term
6276         etors=etors-v0(itori,itori1,iblock)
6277           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6278      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6279         if (lprn)
6280      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6281      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6282      &  (v1(j,itori,itori1,iblock),j=1,6),
6283      &  (v2(j,itori,itori1,iblock),j=1,6)
6284         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6285 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6286       enddo
6287 ! 6/20/98 - dihedral angle constraints
6288       edihcnstr=0.0d0
6289 c      do i=1,ndih_constr
6290       do i=idihconstr_start,idihconstr_end
6291         itori=idih_constr(i)
6292         phii=phi(itori)
6293         difi=pinorm(phii-phi0(i))
6294         if (difi.gt.drange(i)) then
6295           difi=difi-drange(i)
6296           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6297           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6298         else if (difi.lt.-drange(i)) then
6299           difi=difi+drange(i)
6300           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6301           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6302         else
6303           difi=0.0
6304         endif
6305 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6306 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6307 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6308       enddo
6309 cd       write (iout,*) 'edihcnstr',edihcnstr
6310       return
6311       end
6312 c----------------------------------------------------------------------------
6313       subroutine etor_d(etors_d)
6314 C 6/23/01 Compute double torsional energy
6315       implicit real*8 (a-h,o-z)
6316       include 'DIMENSIONS'
6317       include 'COMMON.VAR'
6318       include 'COMMON.GEO'
6319       include 'COMMON.LOCAL'
6320       include 'COMMON.TORSION'
6321       include 'COMMON.INTERACT'
6322       include 'COMMON.DERIV'
6323       include 'COMMON.CHAIN'
6324       include 'COMMON.NAMES'
6325       include 'COMMON.IOUNITS'
6326       include 'COMMON.FFIELD'
6327       include 'COMMON.TORCNSTR'
6328       logical lprn
6329 C Set lprn=.true. for debugging
6330       lprn=.false.
6331 c     lprn=.true.
6332       etors_d=0.0D0
6333 c      write(iout,*) "a tu??"
6334       do i=iphid_start,iphid_end
6335 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6336 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6337 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6338 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6339 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6340          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6341      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6342      &  (itype(i+1).eq.ntyp1)) cycle
6343 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6344         itori=itortyp(itype(i-2))
6345         itori1=itortyp(itype(i-1))
6346         itori2=itortyp(itype(i))
6347         phii=phi(i)
6348         phii1=phi(i+1)
6349         gloci1=0.0D0
6350         gloci2=0.0D0
6351         iblock=1
6352         if (iabs(itype(i+1)).eq.20) iblock=2
6353 C Iblock=2 Proline type
6354 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6355 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6356 C        if (itype(i+1).eq.ntyp1) iblock=3
6357 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6358 C IS or IS NOT need for this
6359 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6360 C        is (itype(i-3).eq.ntyp1) ntblock=2
6361 C        ntblock is N-terminal blocking group
6362
6363 C Regular cosine and sine terms
6364         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6365 C Example of changes for NH3+ blocking group
6366 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6367 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6368           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6369           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6370           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6371           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6372           cosphi1=dcos(j*phii)
6373           sinphi1=dsin(j*phii)
6374           cosphi2=dcos(j*phii1)
6375           sinphi2=dsin(j*phii1)
6376           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6377      &     v2cij*cosphi2+v2sij*sinphi2
6378           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6379           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6380         enddo
6381         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6382           do l=1,k-1
6383             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6384             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6385             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6386             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6387             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6388             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6389             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6390             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6391             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6392      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6393             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6394      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6395             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6396      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6397           enddo
6398         enddo
6399         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6400         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6401       enddo
6402       return
6403       end
6404 #endif
6405 c------------------------------------------------------------------------------
6406       subroutine eback_sc_corr(esccor)
6407 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6408 c        conformational states; temporarily implemented as differences
6409 c        between UNRES torsional potentials (dependent on three types of
6410 c        residues) and the torsional potentials dependent on all 20 types
6411 c        of residues computed from AM1  energy surfaces of terminally-blocked
6412 c        amino-acid residues.
6413       implicit real*8 (a-h,o-z)
6414       include 'DIMENSIONS'
6415       include 'COMMON.VAR'
6416       include 'COMMON.GEO'
6417       include 'COMMON.LOCAL'
6418       include 'COMMON.TORSION'
6419       include 'COMMON.SCCOR'
6420       include 'COMMON.INTERACT'
6421       include 'COMMON.DERIV'
6422       include 'COMMON.CHAIN'
6423       include 'COMMON.NAMES'
6424       include 'COMMON.IOUNITS'
6425       include 'COMMON.FFIELD'
6426       include 'COMMON.CONTROL'
6427       logical lprn
6428 C Set lprn=.true. for debugging
6429       lprn=.false.
6430 c      lprn=.true.
6431 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6432       esccor=0.0D0
6433       do i=itau_start,itau_end
6434         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6435         esccor_ii=0.0D0
6436         isccori=isccortyp(itype(i-2))
6437         isccori1=isccortyp(itype(i-1))
6438 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6439         phii=phi(i)
6440         do intertyp=1,3 !intertyp
6441 cc Added 09 May 2012 (Adasko)
6442 cc  Intertyp means interaction type of backbone mainchain correlation:
6443 c   1 = SC...Ca...Ca...Ca
6444 c   2 = Ca...Ca...Ca...SC
6445 c   3 = SC...Ca...Ca...SCi
6446         gloci=0.0D0
6447         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6448      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6449      &      (itype(i-1).eq.ntyp1)))
6450      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6451      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6452      &     .or.(itype(i).eq.ntyp1)))
6453      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6454      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6455      &      (itype(i-3).eq.ntyp1)))) cycle
6456         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6457         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6458      & cycle
6459        do j=1,nterm_sccor(isccori,isccori1)
6460           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6461           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6462           cosphi=dcos(j*tauangle(intertyp,i))
6463           sinphi=dsin(j*tauangle(intertyp,i))
6464           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6465           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6466         enddo
6467 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6468         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6469         if (lprn)
6470      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6471      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6472      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6473      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6474         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6475        enddo !intertyp
6476       enddo
6477
6478       return
6479       end
6480 c----------------------------------------------------------------------------
6481       subroutine multibody(ecorr)
6482 C This subroutine calculates multi-body contributions to energy following
6483 C the idea of Skolnick et al. If side chains I and J make a contact and
6484 C at the same time side chains I+1 and J+1 make a contact, an extra
6485 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6486       implicit real*8 (a-h,o-z)
6487       include 'DIMENSIONS'
6488       include 'COMMON.IOUNITS'
6489       include 'COMMON.DERIV'
6490       include 'COMMON.INTERACT'
6491       include 'COMMON.CONTACTS'
6492       double precision gx(3),gx1(3)
6493       logical lprn
6494
6495 C Set lprn=.true. for debugging
6496       lprn=.false.
6497
6498       if (lprn) then
6499         write (iout,'(a)') 'Contact function values:'
6500         do i=nnt,nct-2
6501           write (iout,'(i2,20(1x,i2,f10.5))')
6502      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6503         enddo
6504       endif
6505       ecorr=0.0D0
6506       do i=nnt,nct
6507         do j=1,3
6508           gradcorr(j,i)=0.0D0
6509           gradxorr(j,i)=0.0D0
6510         enddo
6511       enddo
6512       do i=nnt,nct-2
6513
6514         DO ISHIFT = 3,4
6515
6516         i1=i+ishift
6517         num_conti=num_cont(i)
6518         num_conti1=num_cont(i1)
6519         do jj=1,num_conti
6520           j=jcont(jj,i)
6521           do kk=1,num_conti1
6522             j1=jcont(kk,i1)
6523             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6524 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6525 cd   &                   ' ishift=',ishift
6526 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6527 C The system gains extra energy.
6528               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6529             endif   ! j1==j+-ishift
6530           enddo     ! kk
6531         enddo       ! jj
6532
6533         ENDDO ! ISHIFT
6534
6535       enddo         ! i
6536       return
6537       end
6538 c------------------------------------------------------------------------------
6539       double precision function esccorr(i,j,k,l,jj,kk)
6540       implicit real*8 (a-h,o-z)
6541       include 'DIMENSIONS'
6542       include 'COMMON.IOUNITS'
6543       include 'COMMON.DERIV'
6544       include 'COMMON.INTERACT'
6545       include 'COMMON.CONTACTS'
6546       double precision gx(3),gx1(3)
6547       logical lprn
6548       lprn=.false.
6549       eij=facont(jj,i)
6550       ekl=facont(kk,k)
6551 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6552 C Calculate the multi-body contribution to energy.
6553 C Calculate multi-body contributions to the gradient.
6554 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6555 cd   & k,l,(gacont(m,kk,k),m=1,3)
6556       do m=1,3
6557         gx(m) =ekl*gacont(m,jj,i)
6558         gx1(m)=eij*gacont(m,kk,k)
6559         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6560         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6561         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6562         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6563       enddo
6564       do m=i,j-1
6565         do ll=1,3
6566           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6567         enddo
6568       enddo
6569       do m=k,l-1
6570         do ll=1,3
6571           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6572         enddo
6573       enddo
6574       esccorr=-eij*ekl
6575       return
6576       end
6577 c------------------------------------------------------------------------------
6578       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6579 C This subroutine calculates multi-body contributions to hydrogen-bonding
6580       implicit real*8 (a-h,o-z)
6581       include 'DIMENSIONS'
6582       include 'COMMON.IOUNITS'
6583 #ifdef MPI
6584       include "mpif.h"
6585       parameter (max_cont=maxconts)
6586       parameter (max_dim=26)
6587       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6588       double precision zapas(max_dim,maxconts,max_fg_procs),
6589      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6590       common /przechowalnia/ zapas
6591       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6592      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6593 #endif
6594       include 'COMMON.SETUP'
6595       include 'COMMON.FFIELD'
6596       include 'COMMON.DERIV'
6597       include 'COMMON.INTERACT'
6598       include 'COMMON.CONTACTS'
6599       include 'COMMON.CONTROL'
6600       include 'COMMON.LOCAL'
6601       double precision gx(3),gx1(3),time00
6602       logical lprn,ldone
6603
6604 C Set lprn=.true. for debugging
6605       lprn=.false.
6606 #ifdef MPI
6607       n_corr=0
6608       n_corr1=0
6609       if (nfgtasks.le.1) goto 30
6610       if (lprn) then
6611         write (iout,'(a)') 'Contact function values before RECEIVE:'
6612         do i=nnt,nct-2
6613           write (iout,'(2i3,50(1x,i2,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       call flush(iout)
6619       do i=1,ntask_cont_from
6620         ncont_recv(i)=0
6621       enddo
6622       do i=1,ntask_cont_to
6623         ncont_sent(i)=0
6624       enddo
6625 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6626 c     & ntask_cont_to
6627 C Make the list of contacts to send to send to other procesors
6628 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6629 c      call flush(iout)
6630       do i=iturn3_start,iturn3_end
6631 c        write (iout,*) "make contact list turn3",i," num_cont",
6632 c     &    num_cont_hb(i)
6633         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6634       enddo
6635       do i=iturn4_start,iturn4_end
6636 c        write (iout,*) "make contact list turn4",i," num_cont",
6637 c     &   num_cont_hb(i)
6638         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6639       enddo
6640       do ii=1,nat_sent
6641         i=iat_sent(ii)
6642 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6643 c     &    num_cont_hb(i)
6644         do j=1,num_cont_hb(i)
6645         do k=1,4
6646           jjc=jcont_hb(j,i)
6647           iproc=iint_sent_local(k,jjc,ii)
6648 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6649           if (iproc.gt.0) then
6650             ncont_sent(iproc)=ncont_sent(iproc)+1
6651             nn=ncont_sent(iproc)
6652             zapas(1,nn,iproc)=i
6653             zapas(2,nn,iproc)=jjc
6654             zapas(3,nn,iproc)=facont_hb(j,i)
6655             zapas(4,nn,iproc)=ees0p(j,i)
6656             zapas(5,nn,iproc)=ees0m(j,i)
6657             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6658             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6659             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6660             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6661             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6662             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6663             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6664             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6665             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6666             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6667             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6668             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6669             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6670             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6671             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6672             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6673             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6674             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6675             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6676             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6677             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6678           endif
6679         enddo
6680         enddo
6681       enddo
6682       if (lprn) then
6683       write (iout,*)
6684      &  "Numbers of contacts to be sent to other processors",
6685      &  (ncont_sent(i),i=1,ntask_cont_to)
6686       write (iout,*) "Contacts sent"
6687       do ii=1,ntask_cont_to
6688         nn=ncont_sent(ii)
6689         iproc=itask_cont_to(ii)
6690         write (iout,*) nn," contacts to processor",iproc,
6691      &   " of CONT_TO_COMM group"
6692         do i=1,nn
6693           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6694         enddo
6695       enddo
6696       call flush(iout)
6697       endif
6698       CorrelType=477
6699       CorrelID=fg_rank+1
6700       CorrelType1=478
6701       CorrelID1=nfgtasks+fg_rank+1
6702       ireq=0
6703 C Receive the numbers of needed contacts from other processors
6704       do ii=1,ntask_cont_from
6705         iproc=itask_cont_from(ii)
6706         ireq=ireq+1
6707         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6708      &    FG_COMM,req(ireq),IERR)
6709       enddo
6710 c      write (iout,*) "IRECV ended"
6711 c      call flush(iout)
6712 C Send the number of contacts needed by other processors
6713       do ii=1,ntask_cont_to
6714         iproc=itask_cont_to(ii)
6715         ireq=ireq+1
6716         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6717      &    FG_COMM,req(ireq),IERR)
6718       enddo
6719 c      write (iout,*) "ISEND ended"
6720 c      write (iout,*) "number of requests (nn)",ireq
6721       call flush(iout)
6722       if (ireq.gt.0)
6723      &  call MPI_Waitall(ireq,req,status_array,ierr)
6724 c      write (iout,*)
6725 c     &  "Numbers of contacts to be received from other processors",
6726 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6727 c      call flush(iout)
6728 C Receive contacts
6729       ireq=0
6730       do ii=1,ntask_cont_from
6731         iproc=itask_cont_from(ii)
6732         nn=ncont_recv(ii)
6733 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6734 c     &   " of CONT_TO_COMM group"
6735         call flush(iout)
6736         if (nn.gt.0) then
6737           ireq=ireq+1
6738           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6739      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6740 c          write (iout,*) "ireq,req",ireq,req(ireq)
6741         endif
6742       enddo
6743 C Send the contacts to processors that need them
6744       do ii=1,ntask_cont_to
6745         iproc=itask_cont_to(ii)
6746         nn=ncont_sent(ii)
6747 c        write (iout,*) nn," contacts to processor",iproc,
6748 c     &   " of CONT_TO_COMM group"
6749         if (nn.gt.0) then
6750           ireq=ireq+1
6751           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6752      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6753 c          write (iout,*) "ireq,req",ireq,req(ireq)
6754 c          do i=1,nn
6755 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6756 c          enddo
6757         endif
6758       enddo
6759 c      write (iout,*) "number of requests (contacts)",ireq
6760 c      write (iout,*) "req",(req(i),i=1,4)
6761 c      call flush(iout)
6762       if (ireq.gt.0)
6763      & call MPI_Waitall(ireq,req,status_array,ierr)
6764       do iii=1,ntask_cont_from
6765         iproc=itask_cont_from(iii)
6766         nn=ncont_recv(iii)
6767         if (lprn) then
6768         write (iout,*) "Received",nn," contacts from processor",iproc,
6769      &   " of CONT_FROM_COMM group"
6770         call flush(iout)
6771         do i=1,nn
6772           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6773         enddo
6774         call flush(iout)
6775         endif
6776         do i=1,nn
6777           ii=zapas_recv(1,i,iii)
6778 c Flag the received contacts to prevent double-counting
6779           jj=-zapas_recv(2,i,iii)
6780 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6781 c          call flush(iout)
6782           nnn=num_cont_hb(ii)+1
6783           num_cont_hb(ii)=nnn
6784           jcont_hb(nnn,ii)=jj
6785           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6786           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6787           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6788           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6789           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6790           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6791           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6792           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6793           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6794           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6795           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6796           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6797           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6798           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6799           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6800           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6801           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6802           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6803           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6804           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6805           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6806           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6807           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6808           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6809         enddo
6810       enddo
6811       call flush(iout)
6812       if (lprn) then
6813         write (iout,'(a)') 'Contact function values after receive:'
6814         do i=nnt,nct-2
6815           write (iout,'(2i3,50(1x,i3,f5.2))')
6816      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6817      &    j=1,num_cont_hb(i))
6818         enddo
6819         call flush(iout)
6820       endif
6821    30 continue
6822 #endif
6823       if (lprn) then
6824         write (iout,'(a)') 'Contact function values:'
6825         do i=nnt,nct-2
6826           write (iout,'(2i3,50(1x,i3,f5.2))')
6827      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6828      &    j=1,num_cont_hb(i))
6829         enddo
6830       endif
6831       ecorr=0.0D0
6832 C Remove the loop below after debugging !!!
6833       do i=nnt,nct
6834         do j=1,3
6835           gradcorr(j,i)=0.0D0
6836           gradxorr(j,i)=0.0D0
6837         enddo
6838       enddo
6839 C Calculate the local-electrostatic correlation terms
6840       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6841         i1=i+1
6842         num_conti=num_cont_hb(i)
6843         num_conti1=num_cont_hb(i+1)
6844         do jj=1,num_conti
6845           j=jcont_hb(jj,i)
6846           jp=iabs(j)
6847           do kk=1,num_conti1
6848             j1=jcont_hb(kk,i1)
6849             jp1=iabs(j1)
6850 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6851 c     &         ' jj=',jj,' kk=',kk
6852             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6853      &          .or. j.lt.0 .and. j1.gt.0) .and.
6854      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6855 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6856 C The system gains extra energy.
6857               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6858               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6859      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6860               n_corr=n_corr+1
6861             else if (j1.eq.j) then
6862 C Contacts I-J and I-(J+1) occur simultaneously.
6863 C The system loses extra energy.
6864 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6865             endif
6866           enddo ! kk
6867           do kk=1,num_conti
6868             j1=jcont_hb(kk,i)
6869 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6870 c    &         ' jj=',jj,' kk=',kk
6871             if (j1.eq.j+1) then
6872 C Contacts I-J and (I+1)-J occur simultaneously.
6873 C The system loses extra energy.
6874 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6875             endif ! j1==j+1
6876           enddo ! kk
6877         enddo ! jj
6878       enddo ! i
6879       return
6880       end
6881 c------------------------------------------------------------------------------
6882       subroutine add_hb_contact(ii,jj,itask)
6883       implicit real*8 (a-h,o-z)
6884       include "DIMENSIONS"
6885       include "COMMON.IOUNITS"
6886       integer max_cont
6887       integer max_dim
6888       parameter (max_cont=maxconts)
6889       parameter (max_dim=26)
6890       include "COMMON.CONTACTS"
6891       double precision zapas(max_dim,maxconts,max_fg_procs),
6892      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6893       common /przechowalnia/ zapas
6894       integer i,j,ii,jj,iproc,itask(4),nn
6895 c      write (iout,*) "itask",itask
6896       do i=1,2
6897         iproc=itask(i)
6898         if (iproc.gt.0) then
6899           do j=1,num_cont_hb(ii)
6900             jjc=jcont_hb(j,ii)
6901 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6902             if (jjc.eq.jj) then
6903               ncont_sent(iproc)=ncont_sent(iproc)+1
6904               nn=ncont_sent(iproc)
6905               zapas(1,nn,iproc)=ii
6906               zapas(2,nn,iproc)=jjc
6907               zapas(3,nn,iproc)=facont_hb(j,ii)
6908               zapas(4,nn,iproc)=ees0p(j,ii)
6909               zapas(5,nn,iproc)=ees0m(j,ii)
6910               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6911               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6912               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6913               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6914               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6915               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6916               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6917               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6918               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6919               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6920               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6921               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6922               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6923               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6924               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6925               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6926               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6927               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6928               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6929               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6930               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6931               exit
6932             endif
6933           enddo
6934         endif
6935       enddo
6936       return
6937       end
6938 c------------------------------------------------------------------------------
6939       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6940      &  n_corr1)
6941 C This subroutine calculates multi-body contributions to hydrogen-bonding
6942       implicit real*8 (a-h,o-z)
6943       include 'DIMENSIONS'
6944       include 'COMMON.IOUNITS'
6945 #ifdef MPI
6946       include "mpif.h"
6947       parameter (max_cont=maxconts)
6948       parameter (max_dim=70)
6949       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6950       double precision zapas(max_dim,maxconts,max_fg_procs),
6951      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6952       common /przechowalnia/ zapas
6953       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6954      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6955 #endif
6956       include 'COMMON.SETUP'
6957       include 'COMMON.FFIELD'
6958       include 'COMMON.DERIV'
6959       include 'COMMON.LOCAL'
6960       include 'COMMON.INTERACT'
6961       include 'COMMON.CONTACTS'
6962       include 'COMMON.CHAIN'
6963       include 'COMMON.CONTROL'
6964       double precision gx(3),gx1(3)
6965       integer num_cont_hb_old(maxres)
6966       logical lprn,ldone
6967       double precision eello4,eello5,eelo6,eello_turn6
6968       external eello4,eello5,eello6,eello_turn6
6969 C Set lprn=.true. for debugging
6970       lprn=.false.
6971       eturn6=0.0d0
6972 #ifdef MPI
6973       do i=1,nres
6974         num_cont_hb_old(i)=num_cont_hb(i)
6975       enddo
6976       n_corr=0
6977       n_corr1=0
6978       if (nfgtasks.le.1) goto 30
6979       if (lprn) then
6980         write (iout,'(a)') 'Contact function values before RECEIVE:'
6981         do i=nnt,nct-2
6982           write (iout,'(2i3,50(1x,i2,f5.2))')
6983      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6984      &    j=1,num_cont_hb(i))
6985         enddo
6986       endif
6987       call flush(iout)
6988       do i=1,ntask_cont_from
6989         ncont_recv(i)=0
6990       enddo
6991       do i=1,ntask_cont_to
6992         ncont_sent(i)=0
6993       enddo
6994 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6995 c     & ntask_cont_to
6996 C Make the list of contacts to send to send to other procesors
6997       do i=iturn3_start,iturn3_end
6998 c        write (iout,*) "make contact list turn3",i," num_cont",
6999 c     &    num_cont_hb(i)
7000         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7001       enddo
7002       do i=iturn4_start,iturn4_end
7003 c        write (iout,*) "make contact list turn4",i," num_cont",
7004 c     &   num_cont_hb(i)
7005         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7006       enddo
7007       do ii=1,nat_sent
7008         i=iat_sent(ii)
7009 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7010 c     &    num_cont_hb(i)
7011         do j=1,num_cont_hb(i)
7012         do k=1,4
7013           jjc=jcont_hb(j,i)
7014           iproc=iint_sent_local(k,jjc,ii)
7015 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7016           if (iproc.ne.0) then
7017             ncont_sent(iproc)=ncont_sent(iproc)+1
7018             nn=ncont_sent(iproc)
7019             zapas(1,nn,iproc)=i
7020             zapas(2,nn,iproc)=jjc
7021             zapas(3,nn,iproc)=d_cont(j,i)
7022             ind=3
7023             do kk=1,3
7024               ind=ind+1
7025               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7026             enddo
7027             do kk=1,2
7028               do ll=1,2
7029                 ind=ind+1
7030                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7031               enddo
7032             enddo
7033             do jj=1,5
7034               do kk=1,3
7035                 do ll=1,2
7036                   do mm=1,2
7037                     ind=ind+1
7038                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7039                   enddo
7040                 enddo
7041               enddo
7042             enddo
7043           endif
7044         enddo
7045         enddo
7046       enddo
7047       if (lprn) then
7048       write (iout,*)
7049      &  "Numbers of contacts to be sent to other processors",
7050      &  (ncont_sent(i),i=1,ntask_cont_to)
7051       write (iout,*) "Contacts sent"
7052       do ii=1,ntask_cont_to
7053         nn=ncont_sent(ii)
7054         iproc=itask_cont_to(ii)
7055         write (iout,*) nn," contacts to processor",iproc,
7056      &   " of CONT_TO_COMM group"
7057         do i=1,nn
7058           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7059         enddo
7060       enddo
7061       call flush(iout)
7062       endif
7063       CorrelType=477
7064       CorrelID=fg_rank+1
7065       CorrelType1=478
7066       CorrelID1=nfgtasks+fg_rank+1
7067       ireq=0
7068 C Receive the numbers of needed contacts from other processors
7069       do ii=1,ntask_cont_from
7070         iproc=itask_cont_from(ii)
7071         ireq=ireq+1
7072         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7073      &    FG_COMM,req(ireq),IERR)
7074       enddo
7075 c      write (iout,*) "IRECV ended"
7076 c      call flush(iout)
7077 C Send the number of contacts needed by other processors
7078       do ii=1,ntask_cont_to
7079         iproc=itask_cont_to(ii)
7080         ireq=ireq+1
7081         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7082      &    FG_COMM,req(ireq),IERR)
7083       enddo
7084 c      write (iout,*) "ISEND ended"
7085 c      write (iout,*) "number of requests (nn)",ireq
7086       call flush(iout)
7087       if (ireq.gt.0)
7088      &  call MPI_Waitall(ireq,req,status_array,ierr)
7089 c      write (iout,*)
7090 c     &  "Numbers of contacts to be received from other processors",
7091 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7092 c      call flush(iout)
7093 C Receive contacts
7094       ireq=0
7095       do ii=1,ntask_cont_from
7096         iproc=itask_cont_from(ii)
7097         nn=ncont_recv(ii)
7098 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7099 c     &   " of CONT_TO_COMM group"
7100         call flush(iout)
7101         if (nn.gt.0) then
7102           ireq=ireq+1
7103           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7104      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7105 c          write (iout,*) "ireq,req",ireq,req(ireq)
7106         endif
7107       enddo
7108 C Send the contacts to processors that need them
7109       do ii=1,ntask_cont_to
7110         iproc=itask_cont_to(ii)
7111         nn=ncont_sent(ii)
7112 c        write (iout,*) nn," contacts to processor",iproc,
7113 c     &   " of CONT_TO_COMM group"
7114         if (nn.gt.0) then
7115           ireq=ireq+1
7116           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7117      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7118 c          write (iout,*) "ireq,req",ireq,req(ireq)
7119 c          do i=1,nn
7120 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7121 c          enddo
7122         endif
7123       enddo
7124 c      write (iout,*) "number of requests (contacts)",ireq
7125 c      write (iout,*) "req",(req(i),i=1,4)
7126 c      call flush(iout)
7127       if (ireq.gt.0)
7128      & call MPI_Waitall(ireq,req,status_array,ierr)
7129       do iii=1,ntask_cont_from
7130         iproc=itask_cont_from(iii)
7131         nn=ncont_recv(iii)
7132         if (lprn) then
7133         write (iout,*) "Received",nn," contacts from processor",iproc,
7134      &   " of CONT_FROM_COMM group"
7135         call flush(iout)
7136         do i=1,nn
7137           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7138         enddo
7139         call flush(iout)
7140         endif
7141         do i=1,nn
7142           ii=zapas_recv(1,i,iii)
7143 c Flag the received contacts to prevent double-counting
7144           jj=-zapas_recv(2,i,iii)
7145 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7146 c          call flush(iout)
7147           nnn=num_cont_hb(ii)+1
7148           num_cont_hb(ii)=nnn
7149           jcont_hb(nnn,ii)=jj
7150           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7151           ind=3
7152           do kk=1,3
7153             ind=ind+1
7154             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7155           enddo
7156           do kk=1,2
7157             do ll=1,2
7158               ind=ind+1
7159               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7160             enddo
7161           enddo
7162           do jj=1,5
7163             do kk=1,3
7164               do ll=1,2
7165                 do mm=1,2
7166                   ind=ind+1
7167                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7168                 enddo
7169               enddo
7170             enddo
7171           enddo
7172         enddo
7173       enddo
7174       call flush(iout)
7175       if (lprn) then
7176         write (iout,'(a)') 'Contact function values after receive:'
7177         do i=nnt,nct-2
7178           write (iout,'(2i3,50(1x,i3,5f6.3))')
7179      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7180      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7181         enddo
7182         call flush(iout)
7183       endif
7184    30 continue
7185 #endif
7186       if (lprn) then
7187         write (iout,'(a)') 'Contact function values:'
7188         do i=nnt,nct-2
7189           write (iout,'(2i3,50(1x,i2,5f6.3))')
7190      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7191      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7192         enddo
7193       endif
7194       ecorr=0.0D0
7195       ecorr5=0.0d0
7196       ecorr6=0.0d0
7197 C Remove the loop below after debugging !!!
7198       do i=nnt,nct
7199         do j=1,3
7200           gradcorr(j,i)=0.0D0
7201           gradxorr(j,i)=0.0D0
7202         enddo
7203       enddo
7204 C Calculate the dipole-dipole interaction energies
7205       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7206       do i=iatel_s,iatel_e+1
7207         num_conti=num_cont_hb(i)
7208         do jj=1,num_conti
7209           j=jcont_hb(jj,i)
7210 #ifdef MOMENT
7211           call dipole(i,j,jj)
7212 #endif
7213         enddo
7214       enddo
7215       endif
7216 C Calculate the local-electrostatic correlation terms
7217 c                write (iout,*) "gradcorr5 in eello5 before loop"
7218 c                do iii=1,nres
7219 c                  write (iout,'(i5,3f10.5)')
7220 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7221 c                enddo
7222       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7223 c        write (iout,*) "corr loop i",i
7224         i1=i+1
7225         num_conti=num_cont_hb(i)
7226         num_conti1=num_cont_hb(i+1)
7227         do jj=1,num_conti
7228           j=jcont_hb(jj,i)
7229           jp=iabs(j)
7230           do kk=1,num_conti1
7231             j1=jcont_hb(kk,i1)
7232             jp1=iabs(j1)
7233 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7234 c     &         ' jj=',jj,' kk=',kk
7235 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7236             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7237      &          .or. j.lt.0 .and. j1.gt.0) .and.
7238      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7239 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7240 C The system gains extra energy.
7241               n_corr=n_corr+1
7242               sqd1=dsqrt(d_cont(jj,i))
7243               sqd2=dsqrt(d_cont(kk,i1))
7244               sred_geom = sqd1*sqd2
7245               IF (sred_geom.lt.cutoff_corr) THEN
7246                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7247      &            ekont,fprimcont)
7248 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7249 cd     &         ' jj=',jj,' kk=',kk
7250                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7251                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7252                 do l=1,3
7253                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7254                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7255                 enddo
7256                 n_corr1=n_corr1+1
7257 cd               write (iout,*) 'sred_geom=',sred_geom,
7258 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7259 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7260 cd               write (iout,*) "g_contij",g_contij
7261 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7262 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7263                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7264                 if (wcorr4.gt.0.0d0)
7265      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7266                   if (energy_dec.and.wcorr4.gt.0.0d0)
7267      1                 write (iout,'(a6,4i5,0pf7.3)')
7268      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7269 c                write (iout,*) "gradcorr5 before eello5"
7270 c                do iii=1,nres
7271 c                  write (iout,'(i5,3f10.5)')
7272 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7273 c                enddo
7274                 if (wcorr5.gt.0.0d0)
7275      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7276 c                write (iout,*) "gradcorr5 after eello5"
7277 c                do iii=1,nres
7278 c                  write (iout,'(i5,3f10.5)')
7279 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7280 c                enddo
7281                   if (energy_dec.and.wcorr5.gt.0.0d0)
7282      1                 write (iout,'(a6,4i5,0pf7.3)')
7283      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7284 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7285 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7286                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7287      &               .or. wturn6.eq.0.0d0))then
7288 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7289                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7290                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7291      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7292 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7293 cd     &            'ecorr6=',ecorr6
7294 cd                write (iout,'(4e15.5)') sred_geom,
7295 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7296 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7297 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7298                 else if (wturn6.gt.0.0d0
7299      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7300 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7301                   eturn6=eturn6+eello_turn6(i,jj,kk)
7302                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7303      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7304 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7305                 endif
7306               ENDIF
7307 1111          continue
7308             endif
7309           enddo ! kk
7310         enddo ! jj
7311       enddo ! i
7312       do i=1,nres
7313         num_cont_hb(i)=num_cont_hb_old(i)
7314       enddo
7315 c                write (iout,*) "gradcorr5 in eello5"
7316 c                do iii=1,nres
7317 c                  write (iout,'(i5,3f10.5)')
7318 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7319 c                enddo
7320       return
7321       end
7322 c------------------------------------------------------------------------------
7323       subroutine add_hb_contact_eello(ii,jj,itask)
7324       implicit real*8 (a-h,o-z)
7325       include "DIMENSIONS"
7326       include "COMMON.IOUNITS"
7327       integer max_cont
7328       integer max_dim
7329       parameter (max_cont=maxconts)
7330       parameter (max_dim=70)
7331       include "COMMON.CONTACTS"
7332       double precision zapas(max_dim,maxconts,max_fg_procs),
7333      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7334       common /przechowalnia/ zapas
7335       integer i,j,ii,jj,iproc,itask(4),nn
7336 c      write (iout,*) "itask",itask
7337       do i=1,2
7338         iproc=itask(i)
7339         if (iproc.gt.0) then
7340           do j=1,num_cont_hb(ii)
7341             jjc=jcont_hb(j,ii)
7342 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7343             if (jjc.eq.jj) then
7344               ncont_sent(iproc)=ncont_sent(iproc)+1
7345               nn=ncont_sent(iproc)
7346               zapas(1,nn,iproc)=ii
7347               zapas(2,nn,iproc)=jjc
7348               zapas(3,nn,iproc)=d_cont(j,ii)
7349               ind=3
7350               do kk=1,3
7351                 ind=ind+1
7352                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7353               enddo
7354               do kk=1,2
7355                 do ll=1,2
7356                   ind=ind+1
7357                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7358                 enddo
7359               enddo
7360               do jj=1,5
7361                 do kk=1,3
7362                   do ll=1,2
7363                     do mm=1,2
7364                       ind=ind+1
7365                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7366                     enddo
7367                   enddo
7368                 enddo
7369               enddo
7370               exit
7371             endif
7372           enddo
7373         endif
7374       enddo
7375       return
7376       end
7377 c------------------------------------------------------------------------------
7378       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7379       implicit real*8 (a-h,o-z)
7380       include 'DIMENSIONS'
7381       include 'COMMON.IOUNITS'
7382       include 'COMMON.DERIV'
7383       include 'COMMON.INTERACT'
7384       include 'COMMON.CONTACTS'
7385       double precision gx(3),gx1(3)
7386       logical lprn
7387       lprn=.false.
7388       eij=facont_hb(jj,i)
7389       ekl=facont_hb(kk,k)
7390       ees0pij=ees0p(jj,i)
7391       ees0pkl=ees0p(kk,k)
7392       ees0mij=ees0m(jj,i)
7393       ees0mkl=ees0m(kk,k)
7394       ekont=eij*ekl
7395       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7396 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7397 C Following 4 lines for diagnostics.
7398 cd    ees0pkl=0.0D0
7399 cd    ees0pij=1.0D0
7400 cd    ees0mkl=0.0D0
7401 cd    ees0mij=1.0D0
7402 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7403 c     & 'Contacts ',i,j,
7404 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7405 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7406 c     & 'gradcorr_long'
7407 C Calculate the multi-body contribution to energy.
7408 c      ecorr=ecorr+ekont*ees
7409 C Calculate multi-body contributions to the gradient.
7410       coeffpees0pij=coeffp*ees0pij
7411       coeffmees0mij=coeffm*ees0mij
7412       coeffpees0pkl=coeffp*ees0pkl
7413       coeffmees0mkl=coeffm*ees0mkl
7414       do ll=1,3
7415 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7416         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7417      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7418      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7419         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7420      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7421      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7422 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7423         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7424      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7425      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7426         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7427      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7428      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7429         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7430      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7431      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7432         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7433         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7434         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7435      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7436      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7437         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7438         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7439 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7440       enddo
7441 c      write (iout,*)
7442 cgrad      do m=i+1,j-1
7443 cgrad        do ll=1,3
7444 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7445 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7446 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7447 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7448 cgrad        enddo
7449 cgrad      enddo
7450 cgrad      do m=k+1,l-1
7451 cgrad        do ll=1,3
7452 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7453 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7454 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7455 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7456 cgrad        enddo
7457 cgrad      enddo
7458 c      write (iout,*) "ehbcorr",ekont*ees
7459       ehbcorr=ekont*ees
7460       return
7461       end
7462 #ifdef MOMENT
7463 C---------------------------------------------------------------------------
7464       subroutine dipole(i,j,jj)
7465       implicit real*8 (a-h,o-z)
7466       include 'DIMENSIONS'
7467       include 'COMMON.IOUNITS'
7468       include 'COMMON.CHAIN'
7469       include 'COMMON.FFIELD'
7470       include 'COMMON.DERIV'
7471       include 'COMMON.INTERACT'
7472       include 'COMMON.CONTACTS'
7473       include 'COMMON.TORSION'
7474       include 'COMMON.VAR'
7475       include 'COMMON.GEO'
7476       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7477      &  auxmat(2,2)
7478       iti1 = itortyp(itype(i+1))
7479       if (j.lt.nres-1) then
7480         itj1 = itortyp(itype(j+1))
7481       else
7482         itj1=ntortyp
7483       endif
7484       do iii=1,2
7485         dipi(iii,1)=Ub2(iii,i)
7486         dipderi(iii)=Ub2der(iii,i)
7487         dipi(iii,2)=b1(iii,iti1)
7488         dipj(iii,1)=Ub2(iii,j)
7489         dipderj(iii)=Ub2der(iii,j)
7490         dipj(iii,2)=b1(iii,itj1)
7491       enddo
7492       kkk=0
7493       do iii=1,2
7494         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7495         do jjj=1,2
7496           kkk=kkk+1
7497           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7498         enddo
7499       enddo
7500       do kkk=1,5
7501         do lll=1,3
7502           mmm=0
7503           do iii=1,2
7504             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7505      &        auxvec(1))
7506             do jjj=1,2
7507               mmm=mmm+1
7508               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7509             enddo
7510           enddo
7511         enddo
7512       enddo
7513       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7514       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7515       do iii=1,2
7516         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7517       enddo
7518       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7519       do iii=1,2
7520         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7521       enddo
7522       return
7523       end
7524 #endif
7525 C---------------------------------------------------------------------------
7526       subroutine calc_eello(i,j,k,l,jj,kk)
7527 C
7528 C This subroutine computes matrices and vectors needed to calculate
7529 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7530 C
7531       implicit real*8 (a-h,o-z)
7532       include 'DIMENSIONS'
7533       include 'COMMON.IOUNITS'
7534       include 'COMMON.CHAIN'
7535       include 'COMMON.DERIV'
7536       include 'COMMON.INTERACT'
7537       include 'COMMON.CONTACTS'
7538       include 'COMMON.TORSION'
7539       include 'COMMON.VAR'
7540       include 'COMMON.GEO'
7541       include 'COMMON.FFIELD'
7542       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7543      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7544       logical lprn
7545       common /kutas/ lprn
7546 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7547 cd     & ' jj=',jj,' kk=',kk
7548 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7549 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7550 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7551       do iii=1,2
7552         do jjj=1,2
7553           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7554           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7555         enddo
7556       enddo
7557       call transpose2(aa1(1,1),aa1t(1,1))
7558       call transpose2(aa2(1,1),aa2t(1,1))
7559       do kkk=1,5
7560         do lll=1,3
7561           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7562      &      aa1tder(1,1,lll,kkk))
7563           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7564      &      aa2tder(1,1,lll,kkk))
7565         enddo
7566       enddo
7567       if (l.eq.j+1) then
7568 C parallel orientation of the two CA-CA-CA frames.
7569         if (i.gt.1) then
7570           iti=itortyp(itype(i))
7571         else
7572           iti=ntortyp
7573         endif
7574         itk1=itortyp(itype(k+1))
7575         itj=itortyp(itype(j))
7576         if (l.lt.nres-1) then
7577           itl1=itortyp(itype(l+1))
7578         else
7579           itl1=ntortyp
7580         endif
7581 C A1 kernel(j+1) A2T
7582 cd        do iii=1,2
7583 cd          write (iout,'(3f10.5,5x,3f10.5)')
7584 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7585 cd        enddo
7586         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7587      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7588      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7589 C Following matrices are needed only for 6-th order cumulants
7590         IF (wcorr6.gt.0.0d0) THEN
7591         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7592      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7593      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7594         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7595      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7596      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7597      &   ADtEAderx(1,1,1,1,1,1))
7598         lprn=.false.
7599         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7600      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7601      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7602      &   ADtEA1derx(1,1,1,1,1,1))
7603         ENDIF
7604 C End 6-th order cumulants
7605 cd        lprn=.false.
7606 cd        if (lprn) then
7607 cd        write (2,*) 'In calc_eello6'
7608 cd        do iii=1,2
7609 cd          write (2,*) 'iii=',iii
7610 cd          do kkk=1,5
7611 cd            write (2,*) 'kkk=',kkk
7612 cd            do jjj=1,2
7613 cd              write (2,'(3(2f10.5),5x)')
7614 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7615 cd            enddo
7616 cd          enddo
7617 cd        enddo
7618 cd        endif
7619         call transpose2(EUgder(1,1,k),auxmat(1,1))
7620         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7621         call transpose2(EUg(1,1,k),auxmat(1,1))
7622         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7623         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7624         do iii=1,2
7625           do kkk=1,5
7626             do lll=1,3
7627               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7628      &          EAEAderx(1,1,lll,kkk,iii,1))
7629             enddo
7630           enddo
7631         enddo
7632 C A1T kernel(i+1) A2
7633         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7634      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7635      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7636 C Following matrices are needed only for 6-th order cumulants
7637         IF (wcorr6.gt.0.0d0) THEN
7638         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7639      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7640      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7641         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7642      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7643      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7644      &   ADtEAderx(1,1,1,1,1,2))
7645         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7646      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7647      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7648      &   ADtEA1derx(1,1,1,1,1,2))
7649         ENDIF
7650 C End 6-th order cumulants
7651         call transpose2(EUgder(1,1,l),auxmat(1,1))
7652         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7653         call transpose2(EUg(1,1,l),auxmat(1,1))
7654         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7655         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7656         do iii=1,2
7657           do kkk=1,5
7658             do lll=1,3
7659               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7660      &          EAEAderx(1,1,lll,kkk,iii,2))
7661             enddo
7662           enddo
7663         enddo
7664 C AEAb1 and AEAb2
7665 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7666 C They are needed only when the fifth- or the sixth-order cumulants are
7667 C indluded.
7668         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7669         call transpose2(AEA(1,1,1),auxmat(1,1))
7670         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7671         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7672         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7673         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7674         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7675         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7676         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7677         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7678         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7679         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7680         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7681         call transpose2(AEA(1,1,2),auxmat(1,1))
7682         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7683         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7684         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7685         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7686         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7687         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7688         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7689         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7690         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7691         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7692         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7693 C Calculate the Cartesian derivatives of the vectors.
7694         do iii=1,2
7695           do kkk=1,5
7696             do lll=1,3
7697               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7698               call matvec2(auxmat(1,1),b1(1,iti),
7699      &          AEAb1derx(1,lll,kkk,iii,1,1))
7700               call matvec2(auxmat(1,1),Ub2(1,i),
7701      &          AEAb2derx(1,lll,kkk,iii,1,1))
7702               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7703      &          AEAb1derx(1,lll,kkk,iii,2,1))
7704               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7705      &          AEAb2derx(1,lll,kkk,iii,2,1))
7706               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7707               call matvec2(auxmat(1,1),b1(1,itj),
7708      &          AEAb1derx(1,lll,kkk,iii,1,2))
7709               call matvec2(auxmat(1,1),Ub2(1,j),
7710      &          AEAb2derx(1,lll,kkk,iii,1,2))
7711               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7712      &          AEAb1derx(1,lll,kkk,iii,2,2))
7713               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7714      &          AEAb2derx(1,lll,kkk,iii,2,2))
7715             enddo
7716           enddo
7717         enddo
7718         ENDIF
7719 C End vectors
7720       else
7721 C Antiparallel orientation of the two CA-CA-CA frames.
7722         if (i.gt.1) then
7723           iti=itortyp(itype(i))
7724         else
7725           iti=ntortyp
7726         endif
7727         itk1=itortyp(itype(k+1))
7728         itl=itortyp(itype(l))
7729         itj=itortyp(itype(j))
7730         if (j.lt.nres-1) then
7731           itj1=itortyp(itype(j+1))
7732         else
7733           itj1=ntortyp
7734         endif
7735 C A2 kernel(j-1)T A1T
7736         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7737      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7738      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7739 C Following matrices are needed only for 6-th order cumulants
7740         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7741      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7742         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7743      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7744      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7745         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7746      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7747      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7748      &   ADtEAderx(1,1,1,1,1,1))
7749         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7750      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7751      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7752      &   ADtEA1derx(1,1,1,1,1,1))
7753         ENDIF
7754 C End 6-th order cumulants
7755         call transpose2(EUgder(1,1,k),auxmat(1,1))
7756         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7757         call transpose2(EUg(1,1,k),auxmat(1,1))
7758         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7759         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7760         do iii=1,2
7761           do kkk=1,5
7762             do lll=1,3
7763               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7764      &          EAEAderx(1,1,lll,kkk,iii,1))
7765             enddo
7766           enddo
7767         enddo
7768 C A2T kernel(i+1)T A1
7769         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7770      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7771      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7772 C Following matrices are needed only for 6-th order cumulants
7773         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7774      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7775         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7776      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7777      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7778         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7779      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7780      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7781      &   ADtEAderx(1,1,1,1,1,2))
7782         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7783      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7784      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7785      &   ADtEA1derx(1,1,1,1,1,2))
7786         ENDIF
7787 C End 6-th order cumulants
7788         call transpose2(EUgder(1,1,j),auxmat(1,1))
7789         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7790         call transpose2(EUg(1,1,j),auxmat(1,1))
7791         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7792         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7793         do iii=1,2
7794           do kkk=1,5
7795             do lll=1,3
7796               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7797      &          EAEAderx(1,1,lll,kkk,iii,2))
7798             enddo
7799           enddo
7800         enddo
7801 C AEAb1 and AEAb2
7802 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7803 C They are needed only when the fifth- or the sixth-order cumulants are
7804 C indluded.
7805         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7806      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7807         call transpose2(AEA(1,1,1),auxmat(1,1))
7808         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7809         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7810         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7811         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7812         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7813         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7814         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7815         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7816         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7817         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7818         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7819         call transpose2(AEA(1,1,2),auxmat(1,1))
7820         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7821         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7822         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7823         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7824         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7825         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7826         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7827         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7828         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7829         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7830         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7831 C Calculate the Cartesian derivatives of the vectors.
7832         do iii=1,2
7833           do kkk=1,5
7834             do lll=1,3
7835               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7836               call matvec2(auxmat(1,1),b1(1,iti),
7837      &          AEAb1derx(1,lll,kkk,iii,1,1))
7838               call matvec2(auxmat(1,1),Ub2(1,i),
7839      &          AEAb2derx(1,lll,kkk,iii,1,1))
7840               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7841      &          AEAb1derx(1,lll,kkk,iii,2,1))
7842               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7843      &          AEAb2derx(1,lll,kkk,iii,2,1))
7844               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7845               call matvec2(auxmat(1,1),b1(1,itl),
7846      &          AEAb1derx(1,lll,kkk,iii,1,2))
7847               call matvec2(auxmat(1,1),Ub2(1,l),
7848      &          AEAb2derx(1,lll,kkk,iii,1,2))
7849               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7850      &          AEAb1derx(1,lll,kkk,iii,2,2))
7851               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7852      &          AEAb2derx(1,lll,kkk,iii,2,2))
7853             enddo
7854           enddo
7855         enddo
7856         ENDIF
7857 C End vectors
7858       endif
7859       return
7860       end
7861 C---------------------------------------------------------------------------
7862       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7863      &  KK,KKderg,AKA,AKAderg,AKAderx)
7864       implicit none
7865       integer nderg
7866       logical transp
7867       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7868      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7869      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7870       integer iii,kkk,lll
7871       integer jjj,mmm
7872       logical lprn
7873       common /kutas/ lprn
7874       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7875       do iii=1,nderg
7876         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7877      &    AKAderg(1,1,iii))
7878       enddo
7879 cd      if (lprn) write (2,*) 'In kernel'
7880       do kkk=1,5
7881 cd        if (lprn) write (2,*) 'kkk=',kkk
7882         do lll=1,3
7883           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7884      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7885 cd          if (lprn) then
7886 cd            write (2,*) 'lll=',lll
7887 cd            write (2,*) 'iii=1'
7888 cd            do jjj=1,2
7889 cd              write (2,'(3(2f10.5),5x)')
7890 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7891 cd            enddo
7892 cd          endif
7893           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7894      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7895 cd          if (lprn) then
7896 cd            write (2,*) 'lll=',lll
7897 cd            write (2,*) 'iii=2'
7898 cd            do jjj=1,2
7899 cd              write (2,'(3(2f10.5),5x)')
7900 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7901 cd            enddo
7902 cd          endif
7903         enddo
7904       enddo
7905       return
7906       end
7907 C---------------------------------------------------------------------------
7908       double precision function eello4(i,j,k,l,jj,kk)
7909       implicit real*8 (a-h,o-z)
7910       include 'DIMENSIONS'
7911       include 'COMMON.IOUNITS'
7912       include 'COMMON.CHAIN'
7913       include 'COMMON.DERIV'
7914       include 'COMMON.INTERACT'
7915       include 'COMMON.CONTACTS'
7916       include 'COMMON.TORSION'
7917       include 'COMMON.VAR'
7918       include 'COMMON.GEO'
7919       double precision pizda(2,2),ggg1(3),ggg2(3)
7920 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7921 cd        eello4=0.0d0
7922 cd        return
7923 cd      endif
7924 cd      print *,'eello4:',i,j,k,l,jj,kk
7925 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7926 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7927 cold      eij=facont_hb(jj,i)
7928 cold      ekl=facont_hb(kk,k)
7929 cold      ekont=eij*ekl
7930       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7931 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7932       gcorr_loc(k-1)=gcorr_loc(k-1)
7933      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7934       if (l.eq.j+1) then
7935         gcorr_loc(l-1)=gcorr_loc(l-1)
7936      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7937       else
7938         gcorr_loc(j-1)=gcorr_loc(j-1)
7939      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7940       endif
7941       do iii=1,2
7942         do kkk=1,5
7943           do lll=1,3
7944             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7945      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7946 cd            derx(lll,kkk,iii)=0.0d0
7947           enddo
7948         enddo
7949       enddo
7950 cd      gcorr_loc(l-1)=0.0d0
7951 cd      gcorr_loc(j-1)=0.0d0
7952 cd      gcorr_loc(k-1)=0.0d0
7953 cd      eel4=1.0d0
7954 cd      write (iout,*)'Contacts have occurred for peptide groups',
7955 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7956 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7957       if (j.lt.nres-1) then
7958         j1=j+1
7959         j2=j-1
7960       else
7961         j1=j-1
7962         j2=j-2
7963       endif
7964       if (l.lt.nres-1) then
7965         l1=l+1
7966         l2=l-1
7967       else
7968         l1=l-1
7969         l2=l-2
7970       endif
7971       do ll=1,3
7972 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7973 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7974         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7975         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7976 cgrad        ghalf=0.5d0*ggg1(ll)
7977         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7978         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7979         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7980         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7981         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7982         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7983 cgrad        ghalf=0.5d0*ggg2(ll)
7984         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7985         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7986         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7987         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7988         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7989         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7990       enddo
7991 cgrad      do m=i+1,j-1
7992 cgrad        do ll=1,3
7993 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7994 cgrad        enddo
7995 cgrad      enddo
7996 cgrad      do m=k+1,l-1
7997 cgrad        do ll=1,3
7998 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7999 cgrad        enddo
8000 cgrad      enddo
8001 cgrad      do m=i+2,j2
8002 cgrad        do ll=1,3
8003 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8004 cgrad        enddo
8005 cgrad      enddo
8006 cgrad      do m=k+2,l2
8007 cgrad        do ll=1,3
8008 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8009 cgrad        enddo
8010 cgrad      enddo
8011 cd      do iii=1,nres-3
8012 cd        write (2,*) iii,gcorr_loc(iii)
8013 cd      enddo
8014       eello4=ekont*eel4
8015 cd      write (2,*) 'ekont',ekont
8016 cd      write (iout,*) 'eello4',ekont*eel4
8017       return
8018       end
8019 C---------------------------------------------------------------------------
8020       double precision function eello5(i,j,k,l,jj,kk)
8021       implicit real*8 (a-h,o-z)
8022       include 'DIMENSIONS'
8023       include 'COMMON.IOUNITS'
8024       include 'COMMON.CHAIN'
8025       include 'COMMON.DERIV'
8026       include 'COMMON.INTERACT'
8027       include 'COMMON.CONTACTS'
8028       include 'COMMON.TORSION'
8029       include 'COMMON.VAR'
8030       include 'COMMON.GEO'
8031       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8032       double precision ggg1(3),ggg2(3)
8033 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8034 C                                                                              C
8035 C                            Parallel chains                                   C
8036 C                                                                              C
8037 C          o             o                   o             o                   C
8038 C         /l\           / \             \   / \           / \   /              C
8039 C        /   \         /   \             \ /   \         /   \ /               C
8040 C       j| o |l1       | o |              o| o |         | o |o                C
8041 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8042 C      \i/   \         /   \ /             /   \         /   \                 C
8043 C       o    k1             o                                                  C
8044 C         (I)          (II)                (III)          (IV)                 C
8045 C                                                                              C
8046 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8047 C                                                                              C
8048 C                            Antiparallel chains                               C
8049 C                                                                              C
8050 C          o             o                   o             o                   C
8051 C         /j\           / \             \   / \           / \   /              C
8052 C        /   \         /   \             \ /   \         /   \ /               C
8053 C      j1| o |l        | o |              o| o |         | o |o                C
8054 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8055 C      \i/   \         /   \ /             /   \         /   \                 C
8056 C       o     k1            o                                                  C
8057 C         (I)          (II)                (III)          (IV)                 C
8058 C                                                                              C
8059 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8060 C                                                                              C
8061 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8062 C                                                                              C
8063 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8064 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8065 cd        eello5=0.0d0
8066 cd        return
8067 cd      endif
8068 cd      write (iout,*)
8069 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8070 cd     &   ' and',k,l
8071       itk=itortyp(itype(k))
8072       itl=itortyp(itype(l))
8073       itj=itortyp(itype(j))
8074       eello5_1=0.0d0
8075       eello5_2=0.0d0
8076       eello5_3=0.0d0
8077       eello5_4=0.0d0
8078 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8079 cd     &   eel5_3_num,eel5_4_num)
8080       do iii=1,2
8081         do kkk=1,5
8082           do lll=1,3
8083             derx(lll,kkk,iii)=0.0d0
8084           enddo
8085         enddo
8086       enddo
8087 cd      eij=facont_hb(jj,i)
8088 cd      ekl=facont_hb(kk,k)
8089 cd      ekont=eij*ekl
8090 cd      write (iout,*)'Contacts have occurred for peptide groups',
8091 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8092 cd      goto 1111
8093 C Contribution from the graph I.
8094 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8095 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8096       call transpose2(EUg(1,1,k),auxmat(1,1))
8097       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8098       vv(1)=pizda(1,1)-pizda(2,2)
8099       vv(2)=pizda(1,2)+pizda(2,1)
8100       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8101      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8102 C Explicit gradient in virtual-dihedral angles.
8103       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8104      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8105      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8106       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8107       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8108       vv(1)=pizda(1,1)-pizda(2,2)
8109       vv(2)=pizda(1,2)+pizda(2,1)
8110       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8111      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8112      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8113       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8114       vv(1)=pizda(1,1)-pizda(2,2)
8115       vv(2)=pizda(1,2)+pizda(2,1)
8116       if (l.eq.j+1) then
8117         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8118      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8119      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8120       else
8121         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8122      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8123      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8124       endif
8125 C Cartesian gradient
8126       do iii=1,2
8127         do kkk=1,5
8128           do lll=1,3
8129             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8130      &        pizda(1,1))
8131             vv(1)=pizda(1,1)-pizda(2,2)
8132             vv(2)=pizda(1,2)+pizda(2,1)
8133             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8134      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8135      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8136           enddo
8137         enddo
8138       enddo
8139 c      goto 1112
8140 c1111  continue
8141 C Contribution from graph II
8142       call transpose2(EE(1,1,itk),auxmat(1,1))
8143       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8144       vv(1)=pizda(1,1)+pizda(2,2)
8145       vv(2)=pizda(2,1)-pizda(1,2)
8146       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8147      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8148 C Explicit gradient in virtual-dihedral angles.
8149       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8150      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8151       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8152       vv(1)=pizda(1,1)+pizda(2,2)
8153       vv(2)=pizda(2,1)-pizda(1,2)
8154       if (l.eq.j+1) then
8155         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8156      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8157      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8158       else
8159         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8160      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8161      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8162       endif
8163 C Cartesian gradient
8164       do iii=1,2
8165         do kkk=1,5
8166           do lll=1,3
8167             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8168      &        pizda(1,1))
8169             vv(1)=pizda(1,1)+pizda(2,2)
8170             vv(2)=pizda(2,1)-pizda(1,2)
8171             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8172      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8173      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8174           enddo
8175         enddo
8176       enddo
8177 cd      goto 1112
8178 cd1111  continue
8179       if (l.eq.j+1) then
8180 cd        goto 1110
8181 C Parallel orientation
8182 C Contribution from graph III
8183         call transpose2(EUg(1,1,l),auxmat(1,1))
8184         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8185         vv(1)=pizda(1,1)-pizda(2,2)
8186         vv(2)=pizda(1,2)+pizda(2,1)
8187         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8188      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8189 C Explicit gradient in virtual-dihedral angles.
8190         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8191      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8192      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8193         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8194         vv(1)=pizda(1,1)-pizda(2,2)
8195         vv(2)=pizda(1,2)+pizda(2,1)
8196         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8197      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8198      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8199         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8200         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8201         vv(1)=pizda(1,1)-pizda(2,2)
8202         vv(2)=pizda(1,2)+pizda(2,1)
8203         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8204      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8205      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8206 C Cartesian gradient
8207         do iii=1,2
8208           do kkk=1,5
8209             do lll=1,3
8210               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8211      &          pizda(1,1))
8212               vv(1)=pizda(1,1)-pizda(2,2)
8213               vv(2)=pizda(1,2)+pizda(2,1)
8214               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8215      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8216      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8217             enddo
8218           enddo
8219         enddo
8220 cd        goto 1112
8221 C Contribution from graph IV
8222 cd1110    continue
8223         call transpose2(EE(1,1,itl),auxmat(1,1))
8224         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8225         vv(1)=pizda(1,1)+pizda(2,2)
8226         vv(2)=pizda(2,1)-pizda(1,2)
8227         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8228      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8229 C Explicit gradient in virtual-dihedral angles.
8230         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8231      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8232         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8233         vv(1)=pizda(1,1)+pizda(2,2)
8234         vv(2)=pizda(2,1)-pizda(1,2)
8235         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8236      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8237      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8238 C Cartesian gradient
8239         do iii=1,2
8240           do kkk=1,5
8241             do lll=1,3
8242               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8243      &          pizda(1,1))
8244               vv(1)=pizda(1,1)+pizda(2,2)
8245               vv(2)=pizda(2,1)-pizda(1,2)
8246               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8247      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8248      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8249             enddo
8250           enddo
8251         enddo
8252       else
8253 C Antiparallel orientation
8254 C Contribution from graph III
8255 c        goto 1110
8256         call transpose2(EUg(1,1,j),auxmat(1,1))
8257         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8258         vv(1)=pizda(1,1)-pizda(2,2)
8259         vv(2)=pizda(1,2)+pizda(2,1)
8260         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8261      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8262 C Explicit gradient in virtual-dihedral angles.
8263         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8264      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8265      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8266         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8267         vv(1)=pizda(1,1)-pizda(2,2)
8268         vv(2)=pizda(1,2)+pizda(2,1)
8269         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8270      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8271      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8272         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8273         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8274         vv(1)=pizda(1,1)-pizda(2,2)
8275         vv(2)=pizda(1,2)+pizda(2,1)
8276         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8277      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8278      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8279 C Cartesian gradient
8280         do iii=1,2
8281           do kkk=1,5
8282             do lll=1,3
8283               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8284      &          pizda(1,1))
8285               vv(1)=pizda(1,1)-pizda(2,2)
8286               vv(2)=pizda(1,2)+pizda(2,1)
8287               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8288      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8289      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8290             enddo
8291           enddo
8292         enddo
8293 cd        goto 1112
8294 C Contribution from graph IV
8295 1110    continue
8296         call transpose2(EE(1,1,itj),auxmat(1,1))
8297         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8298         vv(1)=pizda(1,1)+pizda(2,2)
8299         vv(2)=pizda(2,1)-pizda(1,2)
8300         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8301      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8302 C Explicit gradient in virtual-dihedral angles.
8303         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8304      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8305         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8306         vv(1)=pizda(1,1)+pizda(2,2)
8307         vv(2)=pizda(2,1)-pizda(1,2)
8308         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8309      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8310      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8311 C Cartesian gradient
8312         do iii=1,2
8313           do kkk=1,5
8314             do lll=1,3
8315               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8316      &          pizda(1,1))
8317               vv(1)=pizda(1,1)+pizda(2,2)
8318               vv(2)=pizda(2,1)-pizda(1,2)
8319               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8320      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8321      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8322             enddo
8323           enddo
8324         enddo
8325       endif
8326 1112  continue
8327       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8328 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8329 cd        write (2,*) 'ijkl',i,j,k,l
8330 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8331 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8332 cd      endif
8333 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8334 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8335 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8336 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8337       if (j.lt.nres-1) then
8338         j1=j+1
8339         j2=j-1
8340       else
8341         j1=j-1
8342         j2=j-2
8343       endif
8344       if (l.lt.nres-1) then
8345         l1=l+1
8346         l2=l-1
8347       else
8348         l1=l-1
8349         l2=l-2
8350       endif
8351 cd      eij=1.0d0
8352 cd      ekl=1.0d0
8353 cd      ekont=1.0d0
8354 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8355 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8356 C        summed up outside the subrouine as for the other subroutines
8357 C        handling long-range interactions. The old code is commented out
8358 C        with "cgrad" to keep track of changes.
8359       do ll=1,3
8360 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8361 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8362         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8363         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8364 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8365 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8366 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8367 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8368 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8369 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8370 c     &   gradcorr5ij,
8371 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8372 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8373 cgrad        ghalf=0.5d0*ggg1(ll)
8374 cd        ghalf=0.0d0
8375         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8376         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8377         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8378         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8379         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8380         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8381 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8382 cgrad        ghalf=0.5d0*ggg2(ll)
8383 cd        ghalf=0.0d0
8384         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8385         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8386         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8387         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8388         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8389         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8390       enddo
8391 cd      goto 1112
8392 cgrad      do m=i+1,j-1
8393 cgrad        do ll=1,3
8394 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8395 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8396 cgrad        enddo
8397 cgrad      enddo
8398 cgrad      do m=k+1,l-1
8399 cgrad        do ll=1,3
8400 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8401 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8402 cgrad        enddo
8403 cgrad      enddo
8404 c1112  continue
8405 cgrad      do m=i+2,j2
8406 cgrad        do ll=1,3
8407 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8408 cgrad        enddo
8409 cgrad      enddo
8410 cgrad      do m=k+2,l2
8411 cgrad        do ll=1,3
8412 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8413 cgrad        enddo
8414 cgrad      enddo
8415 cd      do iii=1,nres-3
8416 cd        write (2,*) iii,g_corr5_loc(iii)
8417 cd      enddo
8418       eello5=ekont*eel5
8419 cd      write (2,*) 'ekont',ekont
8420 cd      write (iout,*) 'eello5',ekont*eel5
8421       return
8422       end
8423 c--------------------------------------------------------------------------
8424       double precision function eello6(i,j,k,l,jj,kk)
8425       implicit real*8 (a-h,o-z)
8426       include 'DIMENSIONS'
8427       include 'COMMON.IOUNITS'
8428       include 'COMMON.CHAIN'
8429       include 'COMMON.DERIV'
8430       include 'COMMON.INTERACT'
8431       include 'COMMON.CONTACTS'
8432       include 'COMMON.TORSION'
8433       include 'COMMON.VAR'
8434       include 'COMMON.GEO'
8435       include 'COMMON.FFIELD'
8436       double precision ggg1(3),ggg2(3)
8437 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8438 cd        eello6=0.0d0
8439 cd        return
8440 cd      endif
8441 cd      write (iout,*)
8442 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8443 cd     &   ' and',k,l
8444       eello6_1=0.0d0
8445       eello6_2=0.0d0
8446       eello6_3=0.0d0
8447       eello6_4=0.0d0
8448       eello6_5=0.0d0
8449       eello6_6=0.0d0
8450 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8451 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8452       do iii=1,2
8453         do kkk=1,5
8454           do lll=1,3
8455             derx(lll,kkk,iii)=0.0d0
8456           enddo
8457         enddo
8458       enddo
8459 cd      eij=facont_hb(jj,i)
8460 cd      ekl=facont_hb(kk,k)
8461 cd      ekont=eij*ekl
8462 cd      eij=1.0d0
8463 cd      ekl=1.0d0
8464 cd      ekont=1.0d0
8465       if (l.eq.j+1) then
8466         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8467         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8468         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8469         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8470         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8471         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8472       else
8473         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8474         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8475         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8476         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8477         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8478           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8479         else
8480           eello6_5=0.0d0
8481         endif
8482         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8483       endif
8484 C If turn contributions are considered, they will be handled separately.
8485       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8486 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8487 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8488 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8489 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8490 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8491 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8492 cd      goto 1112
8493       if (j.lt.nres-1) then
8494         j1=j+1
8495         j2=j-1
8496       else
8497         j1=j-1
8498         j2=j-2
8499       endif
8500       if (l.lt.nres-1) then
8501         l1=l+1
8502         l2=l-1
8503       else
8504         l1=l-1
8505         l2=l-2
8506       endif
8507       do ll=1,3
8508 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8509 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8510 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8511 cgrad        ghalf=0.5d0*ggg1(ll)
8512 cd        ghalf=0.0d0
8513         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8514         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8515         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8516         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8517         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8518         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8519         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8520         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8521 cgrad        ghalf=0.5d0*ggg2(ll)
8522 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8523 cd        ghalf=0.0d0
8524         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8525         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8526         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8527         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8528         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8529         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8530       enddo
8531 cd      goto 1112
8532 cgrad      do m=i+1,j-1
8533 cgrad        do ll=1,3
8534 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8535 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8536 cgrad        enddo
8537 cgrad      enddo
8538 cgrad      do m=k+1,l-1
8539 cgrad        do ll=1,3
8540 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8541 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8542 cgrad        enddo
8543 cgrad      enddo
8544 cgrad1112  continue
8545 cgrad      do m=i+2,j2
8546 cgrad        do ll=1,3
8547 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8548 cgrad        enddo
8549 cgrad      enddo
8550 cgrad      do m=k+2,l2
8551 cgrad        do ll=1,3
8552 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8553 cgrad        enddo
8554 cgrad      enddo
8555 cd      do iii=1,nres-3
8556 cd        write (2,*) iii,g_corr6_loc(iii)
8557 cd      enddo
8558       eello6=ekont*eel6
8559 cd      write (2,*) 'ekont',ekont
8560 cd      write (iout,*) 'eello6',ekont*eel6
8561       return
8562       end
8563 c--------------------------------------------------------------------------
8564       double precision function eello6_graph1(i,j,k,l,imat,swap)
8565       implicit real*8 (a-h,o-z)
8566       include 'DIMENSIONS'
8567       include 'COMMON.IOUNITS'
8568       include 'COMMON.CHAIN'
8569       include 'COMMON.DERIV'
8570       include 'COMMON.INTERACT'
8571       include 'COMMON.CONTACTS'
8572       include 'COMMON.TORSION'
8573       include 'COMMON.VAR'
8574       include 'COMMON.GEO'
8575       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8576       logical swap
8577       logical lprn
8578       common /kutas/ lprn
8579 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8580 C                                                                              C
8581 C      Parallel       Antiparallel                                             C
8582 C                                                                              C
8583 C          o             o                                                     C
8584 C         /l\           /j\                                                    C
8585 C        /   \         /   \                                                   C
8586 C       /| o |         | o |\                                                  C
8587 C     \ j|/k\|  /   \  |/k\|l /                                                C
8588 C      \ /   \ /     \ /   \ /                                                 C
8589 C       o     o       o     o                                                  C
8590 C       i             i                                                        C
8591 C                                                                              C
8592 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8593       itk=itortyp(itype(k))
8594       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8595       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8596       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8597       call transpose2(EUgC(1,1,k),auxmat(1,1))
8598       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8599       vv1(1)=pizda1(1,1)-pizda1(2,2)
8600       vv1(2)=pizda1(1,2)+pizda1(2,1)
8601       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8602       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8603       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8604       s5=scalar2(vv(1),Dtobr2(1,i))
8605 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8606       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8607       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8608      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8609      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8610      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8611      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8612      & +scalar2(vv(1),Dtobr2der(1,i)))
8613       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8614       vv1(1)=pizda1(1,1)-pizda1(2,2)
8615       vv1(2)=pizda1(1,2)+pizda1(2,1)
8616       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8617       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8618       if (l.eq.j+1) then
8619         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8620      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8621      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8622      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8623      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8624       else
8625         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8626      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8627      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8628      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8629      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8630       endif
8631       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8632       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8633       vv1(1)=pizda1(1,1)-pizda1(2,2)
8634       vv1(2)=pizda1(1,2)+pizda1(2,1)
8635       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8636      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8637      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8638      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8639       do iii=1,2
8640         if (swap) then
8641           ind=3-iii
8642         else
8643           ind=iii
8644         endif
8645         do kkk=1,5
8646           do lll=1,3
8647             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8648             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8649             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8650             call transpose2(EUgC(1,1,k),auxmat(1,1))
8651             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8652      &        pizda1(1,1))
8653             vv1(1)=pizda1(1,1)-pizda1(2,2)
8654             vv1(2)=pizda1(1,2)+pizda1(2,1)
8655             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8656             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8657      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8658             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8659      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8660             s5=scalar2(vv(1),Dtobr2(1,i))
8661             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8662           enddo
8663         enddo
8664       enddo
8665       return
8666       end
8667 c----------------------------------------------------------------------------
8668       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8669       implicit real*8 (a-h,o-z)
8670       include 'DIMENSIONS'
8671       include 'COMMON.IOUNITS'
8672       include 'COMMON.CHAIN'
8673       include 'COMMON.DERIV'
8674       include 'COMMON.INTERACT'
8675       include 'COMMON.CONTACTS'
8676       include 'COMMON.TORSION'
8677       include 'COMMON.VAR'
8678       include 'COMMON.GEO'
8679       logical swap
8680       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8681      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8682       logical lprn
8683       common /kutas/ lprn
8684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8685 C                                                                              C
8686 C      Parallel       Antiparallel                                             C
8687 C                                                                              C
8688 C          o             o                                                     C
8689 C     \   /l\           /j\   /                                                C
8690 C      \ /   \         /   \ /                                                 C
8691 C       o| o |         | o |o                                                  C
8692 C     \ j|/k\|      \  |/k\|l                                                  C
8693 C      \ /   \       \ /   \                                                   C
8694 C       o             o                                                        C
8695 C       i             i                                                        C
8696 C                                                                              C
8697 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8698 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8699 C AL 7/4/01 s1 would occur in the sixth-order moment,
8700 C           but not in a cluster cumulant
8701 #ifdef MOMENT
8702       s1=dip(1,jj,i)*dip(1,kk,k)
8703 #endif
8704       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8705       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8706       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8707       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8708       call transpose2(EUg(1,1,k),auxmat(1,1))
8709       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8710       vv(1)=pizda(1,1)-pizda(2,2)
8711       vv(2)=pizda(1,2)+pizda(2,1)
8712       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8713 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8714 #ifdef MOMENT
8715       eello6_graph2=-(s1+s2+s3+s4)
8716 #else
8717       eello6_graph2=-(s2+s3+s4)
8718 #endif
8719 c      eello6_graph2=-s3
8720 C Derivatives in gamma(i-1)
8721       if (i.gt.1) then
8722 #ifdef MOMENT
8723         s1=dipderg(1,jj,i)*dip(1,kk,k)
8724 #endif
8725         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8726         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8727         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8728         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8729 #ifdef MOMENT
8730         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8731 #else
8732         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8733 #endif
8734 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8735       endif
8736 C Derivatives in gamma(k-1)
8737 #ifdef MOMENT
8738       s1=dip(1,jj,i)*dipderg(1,kk,k)
8739 #endif
8740       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8741       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8742       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8743       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8744       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8745       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8746       vv(1)=pizda(1,1)-pizda(2,2)
8747       vv(2)=pizda(1,2)+pizda(2,1)
8748       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8749 #ifdef MOMENT
8750       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8751 #else
8752       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8753 #endif
8754 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8755 C Derivatives in gamma(j-1) or gamma(l-1)
8756       if (j.gt.1) then
8757 #ifdef MOMENT
8758         s1=dipderg(3,jj,i)*dip(1,kk,k)
8759 #endif
8760         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8761         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8762         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8763         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8764         vv(1)=pizda(1,1)-pizda(2,2)
8765         vv(2)=pizda(1,2)+pizda(2,1)
8766         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8767 #ifdef MOMENT
8768         if (swap) then
8769           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8770         else
8771           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8772         endif
8773 #endif
8774         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8775 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8776       endif
8777 C Derivatives in gamma(l-1) or gamma(j-1)
8778       if (l.gt.1) then
8779 #ifdef MOMENT
8780         s1=dip(1,jj,i)*dipderg(3,kk,k)
8781 #endif
8782         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8783         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8784         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8785         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8786         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8787         vv(1)=pizda(1,1)-pizda(2,2)
8788         vv(2)=pizda(1,2)+pizda(2,1)
8789         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8790 #ifdef MOMENT
8791         if (swap) then
8792           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8793         else
8794           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8795         endif
8796 #endif
8797         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8798 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8799       endif
8800 C Cartesian derivatives.
8801       if (lprn) then
8802         write (2,*) 'In eello6_graph2'
8803         do iii=1,2
8804           write (2,*) 'iii=',iii
8805           do kkk=1,5
8806             write (2,*) 'kkk=',kkk
8807             do jjj=1,2
8808               write (2,'(3(2f10.5),5x)')
8809      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8810             enddo
8811           enddo
8812         enddo
8813       endif
8814       do iii=1,2
8815         do kkk=1,5
8816           do lll=1,3
8817 #ifdef MOMENT
8818             if (iii.eq.1) then
8819               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8820             else
8821               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8822             endif
8823 #endif
8824             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8825      &        auxvec(1))
8826             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8827             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8828      &        auxvec(1))
8829             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8830             call transpose2(EUg(1,1,k),auxmat(1,1))
8831             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8832      &        pizda(1,1))
8833             vv(1)=pizda(1,1)-pizda(2,2)
8834             vv(2)=pizda(1,2)+pizda(2,1)
8835             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8836 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8837 #ifdef MOMENT
8838             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8839 #else
8840             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8841 #endif
8842             if (swap) then
8843               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8844             else
8845               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8846             endif
8847           enddo
8848         enddo
8849       enddo
8850       return
8851       end
8852 c----------------------------------------------------------------------------
8853       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8854       implicit real*8 (a-h,o-z)
8855       include 'DIMENSIONS'
8856       include 'COMMON.IOUNITS'
8857       include 'COMMON.CHAIN'
8858       include 'COMMON.DERIV'
8859       include 'COMMON.INTERACT'
8860       include 'COMMON.CONTACTS'
8861       include 'COMMON.TORSION'
8862       include 'COMMON.VAR'
8863       include 'COMMON.GEO'
8864       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8865       logical swap
8866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8867 C                                                                              C
8868 C      Parallel       Antiparallel                                             C
8869 C                                                                              C
8870 C          o             o                                                     C
8871 C         /l\   /   \   /j\                                                    C
8872 C        /   \ /     \ /   \                                                   C
8873 C       /| o |o       o| o |\                                                  C
8874 C       j|/k\|  /      |/k\|l /                                                C
8875 C        /   \ /       /   \ /                                                 C
8876 C       /     o       /     o                                                  C
8877 C       i             i                                                        C
8878 C                                                                              C
8879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8880 C
8881 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8882 C           energy moment and not to the cluster cumulant.
8883       iti=itortyp(itype(i))
8884       if (j.lt.nres-1) then
8885         itj1=itortyp(itype(j+1))
8886       else
8887         itj1=ntortyp
8888       endif
8889       itk=itortyp(itype(k))
8890       itk1=itortyp(itype(k+1))
8891       if (l.lt.nres-1) then
8892         itl1=itortyp(itype(l+1))
8893       else
8894         itl1=ntortyp
8895       endif
8896 #ifdef MOMENT
8897       s1=dip(4,jj,i)*dip(4,kk,k)
8898 #endif
8899       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8900       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8901       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8902       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8903       call transpose2(EE(1,1,itk),auxmat(1,1))
8904       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8905       vv(1)=pizda(1,1)+pizda(2,2)
8906       vv(2)=pizda(2,1)-pizda(1,2)
8907       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8908 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8909 cd     & "sum",-(s2+s3+s4)
8910 #ifdef MOMENT
8911       eello6_graph3=-(s1+s2+s3+s4)
8912 #else
8913       eello6_graph3=-(s2+s3+s4)
8914 #endif
8915 c      eello6_graph3=-s4
8916 C Derivatives in gamma(k-1)
8917       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8918       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8919       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8920       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8921 C Derivatives in gamma(l-1)
8922       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8923       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8924       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8925       vv(1)=pizda(1,1)+pizda(2,2)
8926       vv(2)=pizda(2,1)-pizda(1,2)
8927       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8928       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8929 C Cartesian derivatives.
8930       do iii=1,2
8931         do kkk=1,5
8932           do lll=1,3
8933 #ifdef MOMENT
8934             if (iii.eq.1) then
8935               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8936             else
8937               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8938             endif
8939 #endif
8940             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8941      &        auxvec(1))
8942             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8943             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8944      &        auxvec(1))
8945             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8946             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8947      &        pizda(1,1))
8948             vv(1)=pizda(1,1)+pizda(2,2)
8949             vv(2)=pizda(2,1)-pizda(1,2)
8950             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8951 #ifdef MOMENT
8952             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8953 #else
8954             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8955 #endif
8956             if (swap) then
8957               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8958             else
8959               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8960             endif
8961 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8962           enddo
8963         enddo
8964       enddo
8965       return
8966       end
8967 c----------------------------------------------------------------------------
8968       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8969       implicit real*8 (a-h,o-z)
8970       include 'DIMENSIONS'
8971       include 'COMMON.IOUNITS'
8972       include 'COMMON.CHAIN'
8973       include 'COMMON.DERIV'
8974       include 'COMMON.INTERACT'
8975       include 'COMMON.CONTACTS'
8976       include 'COMMON.TORSION'
8977       include 'COMMON.VAR'
8978       include 'COMMON.GEO'
8979       include 'COMMON.FFIELD'
8980       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8981      & auxvec1(2),auxmat1(2,2)
8982       logical swap
8983 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8984 C                                                                              C
8985 C      Parallel       Antiparallel                                             C
8986 C                                                                              C
8987 C          o             o                                                     C
8988 C         /l\   /   \   /j\                                                    C
8989 C        /   \ /     \ /   \                                                   C
8990 C       /| o |o       o| o |\                                                  C
8991 C     \ j|/k\|      \  |/k\|l                                                  C
8992 C      \ /   \       \ /   \                                                   C
8993 C       o     \       o     \                                                  C
8994 C       i             i                                                        C
8995 C                                                                              C
8996 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8997 C
8998 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8999 C           energy moment and not to the cluster cumulant.
9000 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9001       iti=itortyp(itype(i))
9002       itj=itortyp(itype(j))
9003       if (j.lt.nres-1) then
9004         itj1=itortyp(itype(j+1))
9005       else
9006         itj1=ntortyp
9007       endif
9008       itk=itortyp(itype(k))
9009       if (k.lt.nres-1) then
9010         itk1=itortyp(itype(k+1))
9011       else
9012         itk1=ntortyp
9013       endif
9014       itl=itortyp(itype(l))
9015       if (l.lt.nres-1) then
9016         itl1=itortyp(itype(l+1))
9017       else
9018         itl1=ntortyp
9019       endif
9020 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9021 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9022 cd     & ' itl',itl,' itl1',itl1
9023 #ifdef MOMENT
9024       if (imat.eq.1) then
9025         s1=dip(3,jj,i)*dip(3,kk,k)
9026       else
9027         s1=dip(2,jj,j)*dip(2,kk,l)
9028       endif
9029 #endif
9030       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9031       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9032       if (j.eq.l+1) then
9033         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9034         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9035       else
9036         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9037         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9038       endif
9039       call transpose2(EUg(1,1,k),auxmat(1,1))
9040       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9041       vv(1)=pizda(1,1)-pizda(2,2)
9042       vv(2)=pizda(2,1)+pizda(1,2)
9043       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9044 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9045 #ifdef MOMENT
9046       eello6_graph4=-(s1+s2+s3+s4)
9047 #else
9048       eello6_graph4=-(s2+s3+s4)
9049 #endif
9050 C Derivatives in gamma(i-1)
9051       if (i.gt.1) then
9052 #ifdef MOMENT
9053         if (imat.eq.1) then
9054           s1=dipderg(2,jj,i)*dip(3,kk,k)
9055         else
9056           s1=dipderg(4,jj,j)*dip(2,kk,l)
9057         endif
9058 #endif
9059         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9060         if (j.eq.l+1) then
9061           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9062           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9063         else
9064           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9065           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9066         endif
9067         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9068         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9069 cd          write (2,*) 'turn6 derivatives'
9070 #ifdef MOMENT
9071           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9072 #else
9073           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9074 #endif
9075         else
9076 #ifdef MOMENT
9077           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9078 #else
9079           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9080 #endif
9081         endif
9082       endif
9083 C Derivatives in gamma(k-1)
9084 #ifdef MOMENT
9085       if (imat.eq.1) then
9086         s1=dip(3,jj,i)*dipderg(2,kk,k)
9087       else
9088         s1=dip(2,jj,j)*dipderg(4,kk,l)
9089       endif
9090 #endif
9091       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9092       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9093       if (j.eq.l+1) then
9094         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9095         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9096       else
9097         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9098         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9099       endif
9100       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9101       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9102       vv(1)=pizda(1,1)-pizda(2,2)
9103       vv(2)=pizda(2,1)+pizda(1,2)
9104       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9105       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9106 #ifdef MOMENT
9107         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9108 #else
9109         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9110 #endif
9111       else
9112 #ifdef MOMENT
9113         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9114 #else
9115         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9116 #endif
9117       endif
9118 C Derivatives in gamma(j-1) or gamma(l-1)
9119       if (l.eq.j+1 .and. l.gt.1) then
9120         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9121         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9122         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9123         vv(1)=pizda(1,1)-pizda(2,2)
9124         vv(2)=pizda(2,1)+pizda(1,2)
9125         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9126         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9127       else if (j.gt.1) then
9128         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9129         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9130         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9131         vv(1)=pizda(1,1)-pizda(2,2)
9132         vv(2)=pizda(2,1)+pizda(1,2)
9133         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9134         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9135           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9136         else
9137           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9138         endif
9139       endif
9140 C Cartesian derivatives.
9141       do iii=1,2
9142         do kkk=1,5
9143           do lll=1,3
9144 #ifdef MOMENT
9145             if (iii.eq.1) then
9146               if (imat.eq.1) then
9147                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9148               else
9149                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9150               endif
9151             else
9152               if (imat.eq.1) then
9153                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9154               else
9155                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9156               endif
9157             endif
9158 #endif
9159             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9160      &        auxvec(1))
9161             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9162             if (j.eq.l+1) then
9163               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9164      &          b1(1,itj1),auxvec(1))
9165               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9166             else
9167               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9168      &          b1(1,itl1),auxvec(1))
9169               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9170             endif
9171             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9172      &        pizda(1,1))
9173             vv(1)=pizda(1,1)-pizda(2,2)
9174             vv(2)=pizda(2,1)+pizda(1,2)
9175             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9176             if (swap) then
9177               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9178 #ifdef MOMENT
9179                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9180      &             -(s1+s2+s4)
9181 #else
9182                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9183      &             -(s2+s4)
9184 #endif
9185                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9186               else
9187 #ifdef MOMENT
9188                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9189 #else
9190                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9191 #endif
9192                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9193               endif
9194             else
9195 #ifdef MOMENT
9196               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9197 #else
9198               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9199 #endif
9200               if (l.eq.j+1) then
9201                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9202               else
9203                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9204               endif
9205             endif
9206           enddo
9207         enddo
9208       enddo
9209       return
9210       end
9211 c----------------------------------------------------------------------------
9212       double precision function eello_turn6(i,jj,kk)
9213       implicit real*8 (a-h,o-z)
9214       include 'DIMENSIONS'
9215       include 'COMMON.IOUNITS'
9216       include 'COMMON.CHAIN'
9217       include 'COMMON.DERIV'
9218       include 'COMMON.INTERACT'
9219       include 'COMMON.CONTACTS'
9220       include 'COMMON.TORSION'
9221       include 'COMMON.VAR'
9222       include 'COMMON.GEO'
9223       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9224      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9225      &  ggg1(3),ggg2(3)
9226       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9227      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9228 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9229 C           the respective energy moment and not to the cluster cumulant.
9230       s1=0.0d0
9231       s8=0.0d0
9232       s13=0.0d0
9233 c
9234       eello_turn6=0.0d0
9235       j=i+4
9236       k=i+1
9237       l=i+3
9238       iti=itortyp(itype(i))
9239       itk=itortyp(itype(k))
9240       itk1=itortyp(itype(k+1))
9241       itl=itortyp(itype(l))
9242       itj=itortyp(itype(j))
9243 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9244 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9245 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9246 cd        eello6=0.0d0
9247 cd        return
9248 cd      endif
9249 cd      write (iout,*)
9250 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9251 cd     &   ' and',k,l
9252 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9253       do iii=1,2
9254         do kkk=1,5
9255           do lll=1,3
9256             derx_turn(lll,kkk,iii)=0.0d0
9257           enddo
9258         enddo
9259       enddo
9260 cd      eij=1.0d0
9261 cd      ekl=1.0d0
9262 cd      ekont=1.0d0
9263       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9264 cd      eello6_5=0.0d0
9265 cd      write (2,*) 'eello6_5',eello6_5
9266 #ifdef MOMENT
9267       call transpose2(AEA(1,1,1),auxmat(1,1))
9268       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9269       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9270       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9271 #endif
9272       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9273       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9274       s2 = scalar2(b1(1,itk),vtemp1(1))
9275 #ifdef MOMENT
9276       call transpose2(AEA(1,1,2),atemp(1,1))
9277       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9278       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9279       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9280 #endif
9281       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9282       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9283       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9284 #ifdef MOMENT
9285       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9286       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9287       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9288       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9289       ss13 = scalar2(b1(1,itk),vtemp4(1))
9290       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9291 #endif
9292 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9293 c      s1=0.0d0
9294 c      s2=0.0d0
9295 c      s8=0.0d0
9296 c      s12=0.0d0
9297 c      s13=0.0d0
9298       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9299 C Derivatives in gamma(i+2)
9300       s1d =0.0d0
9301       s8d =0.0d0
9302 #ifdef MOMENT
9303       call transpose2(AEA(1,1,1),auxmatd(1,1))
9304       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9305       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9306       call transpose2(AEAderg(1,1,2),atempd(1,1))
9307       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9308       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9309 #endif
9310       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9311       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9312       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9313 c      s1d=0.0d0
9314 c      s2d=0.0d0
9315 c      s8d=0.0d0
9316 c      s12d=0.0d0
9317 c      s13d=0.0d0
9318       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9319 C Derivatives in gamma(i+3)
9320 #ifdef MOMENT
9321       call transpose2(AEA(1,1,1),auxmatd(1,1))
9322       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9323       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9324       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9325 #endif
9326       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9327       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9328       s2d = scalar2(b1(1,itk),vtemp1d(1))
9329 #ifdef MOMENT
9330       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9331       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9332 #endif
9333       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9334 #ifdef MOMENT
9335       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9336       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9337       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9338 #endif
9339 c      s1d=0.0d0
9340 c      s2d=0.0d0
9341 c      s8d=0.0d0
9342 c      s12d=0.0d0
9343 c      s13d=0.0d0
9344 #ifdef MOMENT
9345       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9346      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9347 #else
9348       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9349      &               -0.5d0*ekont*(s2d+s12d)
9350 #endif
9351 C Derivatives in gamma(i+4)
9352       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9353       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9354       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9355 #ifdef MOMENT
9356       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9357       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9358       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9359 #endif
9360 c      s1d=0.0d0
9361 c      s2d=0.0d0
9362 c      s8d=0.0d0
9363 C      s12d=0.0d0
9364 c      s13d=0.0d0
9365 #ifdef MOMENT
9366       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9367 #else
9368       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9369 #endif
9370 C Derivatives in gamma(i+5)
9371 #ifdef MOMENT
9372       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9373       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9374       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9375 #endif
9376       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9377       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9378       s2d = scalar2(b1(1,itk),vtemp1d(1))
9379 #ifdef MOMENT
9380       call transpose2(AEA(1,1,2),atempd(1,1))
9381       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9382       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9383 #endif
9384       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9385       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9386 #ifdef MOMENT
9387       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9388       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9389       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9390 #endif
9391 c      s1d=0.0d0
9392 c      s2d=0.0d0
9393 c      s8d=0.0d0
9394 c      s12d=0.0d0
9395 c      s13d=0.0d0
9396 #ifdef MOMENT
9397       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9398      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9399 #else
9400       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9401      &               -0.5d0*ekont*(s2d+s12d)
9402 #endif
9403 C Cartesian derivatives
9404       do iii=1,2
9405         do kkk=1,5
9406           do lll=1,3
9407 #ifdef MOMENT
9408             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9409             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9410             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9411 #endif
9412             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9413             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9414      &          vtemp1d(1))
9415             s2d = scalar2(b1(1,itk),vtemp1d(1))
9416 #ifdef MOMENT
9417             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9418             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9419             s8d = -(atempd(1,1)+atempd(2,2))*
9420      &           scalar2(cc(1,1,itl),vtemp2(1))
9421 #endif
9422             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9423      &           auxmatd(1,1))
9424             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9425             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9426 c      s1d=0.0d0
9427 c      s2d=0.0d0
9428 c      s8d=0.0d0
9429 c      s12d=0.0d0
9430 c      s13d=0.0d0
9431 #ifdef MOMENT
9432             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9433      &        - 0.5d0*(s1d+s2d)
9434 #else
9435             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9436      &        - 0.5d0*s2d
9437 #endif
9438 #ifdef MOMENT
9439             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9440      &        - 0.5d0*(s8d+s12d)
9441 #else
9442             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9443      &        - 0.5d0*s12d
9444 #endif
9445           enddo
9446         enddo
9447       enddo
9448 #ifdef MOMENT
9449       do kkk=1,5
9450         do lll=1,3
9451           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9452      &      achuj_tempd(1,1))
9453           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9454           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9455           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9456           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9457           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9458      &      vtemp4d(1))
9459           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9460           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9461           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9462         enddo
9463       enddo
9464 #endif
9465 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9466 cd     &  16*eel_turn6_num
9467 cd      goto 1112
9468       if (j.lt.nres-1) then
9469         j1=j+1
9470         j2=j-1
9471       else
9472         j1=j-1
9473         j2=j-2
9474       endif
9475       if (l.lt.nres-1) then
9476         l1=l+1
9477         l2=l-1
9478       else
9479         l1=l-1
9480         l2=l-2
9481       endif
9482       do ll=1,3
9483 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9484 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9485 cgrad        ghalf=0.5d0*ggg1(ll)
9486 cd        ghalf=0.0d0
9487         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9488         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9489         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9490      &    +ekont*derx_turn(ll,2,1)
9491         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9492         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9493      &    +ekont*derx_turn(ll,4,1)
9494         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9495         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9496         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9497 cgrad        ghalf=0.5d0*ggg2(ll)
9498 cd        ghalf=0.0d0
9499         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9500      &    +ekont*derx_turn(ll,2,2)
9501         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9502         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9503      &    +ekont*derx_turn(ll,4,2)
9504         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9505         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9506         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9507       enddo
9508 cd      goto 1112
9509 cgrad      do m=i+1,j-1
9510 cgrad        do ll=1,3
9511 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9512 cgrad        enddo
9513 cgrad      enddo
9514 cgrad      do m=k+1,l-1
9515 cgrad        do ll=1,3
9516 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9517 cgrad        enddo
9518 cgrad      enddo
9519 cgrad1112  continue
9520 cgrad      do m=i+2,j2
9521 cgrad        do ll=1,3
9522 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9523 cgrad        enddo
9524 cgrad      enddo
9525 cgrad      do m=k+2,l2
9526 cgrad        do ll=1,3
9527 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9528 cgrad        enddo
9529 cgrad      enddo
9530 cd      do iii=1,nres-3
9531 cd        write (2,*) iii,g_corr6_loc(iii)
9532 cd      enddo
9533       eello_turn6=ekont*eel_turn6
9534 cd      write (2,*) 'ekont',ekont
9535 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9536       return
9537       end
9538
9539 C-----------------------------------------------------------------------------
9540       double precision function scalar(u,v)
9541 !DIR$ INLINEALWAYS scalar
9542 #ifndef OSF
9543 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9544 #endif
9545       implicit none
9546       double precision u(3),v(3)
9547 cd      double precision sc
9548 cd      integer i
9549 cd      sc=0.0d0
9550 cd      do i=1,3
9551 cd        sc=sc+u(i)*v(i)
9552 cd      enddo
9553 cd      scalar=sc
9554
9555       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9556       return
9557       end
9558 crc-------------------------------------------------
9559       SUBROUTINE MATVEC2(A1,V1,V2)
9560 !DIR$ INLINEALWAYS MATVEC2
9561 #ifndef OSF
9562 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9563 #endif
9564       implicit real*8 (a-h,o-z)
9565       include 'DIMENSIONS'
9566       DIMENSION A1(2,2),V1(2),V2(2)
9567 c      DO 1 I=1,2
9568 c        VI=0.0
9569 c        DO 3 K=1,2
9570 c    3     VI=VI+A1(I,K)*V1(K)
9571 c        Vaux(I)=VI
9572 c    1 CONTINUE
9573
9574       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9575       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9576
9577       v2(1)=vaux1
9578       v2(2)=vaux2
9579       END
9580 C---------------------------------------
9581       SUBROUTINE MATMAT2(A1,A2,A3)
9582 #ifndef OSF
9583 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9584 #endif
9585       implicit real*8 (a-h,o-z)
9586       include 'DIMENSIONS'
9587       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9588 c      DIMENSION AI3(2,2)
9589 c        DO  J=1,2
9590 c          A3IJ=0.0
9591 c          DO K=1,2
9592 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9593 c          enddo
9594 c          A3(I,J)=A3IJ
9595 c       enddo
9596 c      enddo
9597
9598       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9599       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9600       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9601       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9602
9603       A3(1,1)=AI3_11
9604       A3(2,1)=AI3_21
9605       A3(1,2)=AI3_12
9606       A3(2,2)=AI3_22
9607       END
9608
9609 c-------------------------------------------------------------------------
9610       double precision function scalar2(u,v)
9611 !DIR$ INLINEALWAYS scalar2
9612       implicit none
9613       double precision u(2),v(2)
9614       double precision sc
9615       integer i
9616       scalar2=u(1)*v(1)+u(2)*v(2)
9617       return
9618       end
9619
9620 C-----------------------------------------------------------------------------
9621
9622       subroutine transpose2(a,at)
9623 !DIR$ INLINEALWAYS transpose2
9624 #ifndef OSF
9625 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9626 #endif
9627       implicit none
9628       double precision a(2,2),at(2,2)
9629       at(1,1)=a(1,1)
9630       at(1,2)=a(2,1)
9631       at(2,1)=a(1,2)
9632       at(2,2)=a(2,2)
9633       return
9634       end
9635 c--------------------------------------------------------------------------
9636       subroutine transpose(n,a,at)
9637       implicit none
9638       integer n,i,j
9639       double precision a(n,n),at(n,n)
9640       do i=1,n
9641         do j=1,n
9642           at(j,i)=a(i,j)
9643         enddo
9644       enddo
9645       return
9646       end
9647 C---------------------------------------------------------------------------
9648       subroutine prodmat3(a1,a2,kk,transp,prod)
9649 !DIR$ INLINEALWAYS prodmat3
9650 #ifndef OSF
9651 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9652 #endif
9653       implicit none
9654       integer i,j
9655       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9656       logical transp
9657 crc      double precision auxmat(2,2),prod_(2,2)
9658
9659       if (transp) then
9660 crc        call transpose2(kk(1,1),auxmat(1,1))
9661 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9662 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9663
9664            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9665      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9666            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9667      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9668            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9669      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9670            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9671      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9672
9673       else
9674 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9675 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9676
9677            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9678      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9679            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9680      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9681            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9682      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9683            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9684      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9685
9686       endif
9687 c      call transpose2(a2(1,1),a2t(1,1))
9688
9689 crc      print *,transp
9690 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9691 crc      print *,((prod(i,j),i=1,2),j=1,2)
9692
9693       return
9694       end
9695 CCC----------------------------------------------
9696       subroutine Eliptransfer(eliptran)
9697       implicit real*8 (a-h,o-z)
9698       include 'DIMENSIONS'
9699       include 'COMMON.GEO'
9700       include 'COMMON.VAR'
9701       include 'COMMON.LOCAL'
9702       include 'COMMON.CHAIN'
9703       include 'COMMON.DERIV'
9704       include 'COMMON.NAMES'
9705       include 'COMMON.INTERACT'
9706       include 'COMMON.IOUNITS'
9707       include 'COMMON.CALC'
9708       include 'COMMON.CONTROL'
9709       include 'COMMON.SPLITELE'
9710       include 'COMMON.SBRIDGE'
9711 C      print *,"wchodze"
9712 C structure of box:
9713 C      water
9714 C--bordliptop-- buffore starts
9715 C--bufliptop--- here true lipid starts
9716 C      lipid
9717 C--buflipbot--- lipid ends buffore starts
9718 C--bordlipbot--buffore ends
9719       eliptran=0.0
9720       do i=ilip_start,ilip_end
9721         if (itype(i).eq.ntyp1) cycle
9722
9723         positi=(mod((c(3,i)+c(3,i+1)),boxzsize))
9724         if (positi.le.0) positi=positi+boxzsize
9725 C        print *,i
9726 C first for peptide groups
9727 c for each residue check if it is in lipid or lipid water border area
9728        if ((positi.gt.bordlipbot)
9729      &.and.(positi.lt.bordliptop)) then
9730 C the energy transfer exist
9731         if (positi.lt.buflipbot) then
9732 C what fraction I am in
9733          fracinbuf=1.0d0-
9734      &        ((positi-bordlipbot)/lipbufthick)
9735 C lipbufthick is thickenes of lipid buffore
9736          sslip=sscalelip(fracinbuf)
9737          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9738          eliptran=eliptran+sslip*pepliptran
9739          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0
9740          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0
9741 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9742
9743 C         print *,"doing sccale for lower part"
9744         elseif (positi.gt.bufliptop) then
9745          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9746          sslip=sscalelip(fracinbuf)
9747          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9748          eliptran=eliptran+sslip*pepliptran
9749          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9750          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9751 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9752           print *, "doing sscalefor top part"
9753         else
9754          eliptran=eliptran+pepliptran
9755          print *,"I am in true lipid"
9756         endif
9757 C       else
9758 C       eliptran=elpitran+0.0 ! I am in water
9759        endif
9760        enddo
9761 C       print *, "nic nie bylo w lipidzie?"
9762 C now multiply all by the peptide group transfer factor
9763 C       eliptran=eliptran*pepliptran
9764 C now the same for side chains
9765        do i=ilip_start,ilip_end
9766         if (itype(i).eq.ntyp1) cycle
9767         positi=(mod(c(3,i+nres),boxzsize))
9768         if (positi.le.0) positi=positi+boxzsize
9769 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9770 c for each residue check if it is in lipid or lipid water border area
9771 C       respos=mod(c(3,i+nres),boxzsize)
9772        if ((positi.gt.bordlipbot)
9773      & .and.(positi.lt.bordliptop)) then
9774 C the energy transfer exist
9775         if (positi.lt.buflipbot) then
9776          fracinbuf=1.0d0-
9777      &     ((positi-bordlipbot)/lipbufthick)
9778 C lipbufthick is thickenes of lipid buffore
9779          sslip=sscalelip(fracinbuf)
9780          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9781          eliptran=eliptran+sslip*liptranene(itype(i))
9782          gliptranx(3,i)=gliptranx(3,i)
9783      &+ssgradlip*liptranene(itype(i))/2.0d0
9784          gliptranc(3,i-1)=
9785      &+ssgradlip*liptranene(itype(i))
9786          print *,"doing sccale for lower part"
9787         elseif (positi.gt.bufliptop) then
9788          fracinbuf=1.0d0-
9789      &((bordliptop-positi)/lipbufthick)
9790          sslip=sscalelip(fracinbuf)
9791          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9792          eliptran=eliptran+sslip*liptranene(itype(i))
9793          gliptranx(3,i)=gliptranx(3,i)
9794      &+ssgradlip*liptranene(itype(i))/2.0d0
9795          gliptranc(3,i-1)=
9796      &+ssgradlip*liptranene(itype(i))
9797           print *, "doing sscalefor top part",sslip,fracinbuf
9798         else
9799          eliptran=eliptran+liptranene(itype(i))
9800          print *,"I am in true lipid"
9801         endif
9802         endif ! if in lipid or buffor
9803 C       else
9804 C       eliptran=elpitran+0.0 ! I am in water
9805        enddo
9806        return
9807        end