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           weights_(25)=wsaxs
  59 C FG Master broadcasts the WEIGHTS_ array
  60           call MPI_Bcast(weights_(1),n_ene,
  61      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  62         else
  63 C FG slaves receive the WEIGHTS array
  64           call MPI_Bcast(weights(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66           wsc=weights(1)
  67           wscp=weights(2)
  68           welec=weights(3)
  69           wcorr=weights(4)
  70           wcorr5=weights(5)
  71           wcorr6=weights(6)
  72           wel_loc=weights(7)
  73           wturn3=weights(8)
  74           wturn4=weights(9)
  75           wturn6=weights(10)
  76           wang=weights(11)
  77           wscloc=weights(12)
  78           wtor=weights(13)
  79           wtor_d=weights(14)
  80           wstrain=weights(15)
  81           wvdwpp=weights(16)
  82           wbond=weights(17)
  83           scal14=weights(18)
  84           wsccor=weights(21)
  85           wsaxs=weights(25)
  86         endif
  87         time_Bcast=time_Bcast+MPI_Wtime()-time00
  88         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  89 c        call chainbuild_cart
  90       endif
  91 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  92 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  93 #else
  94 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  95 c        call int_from_cart1(.false.)
  96 c      endif
  97 #endif
  98 #ifdef TIMING
  99       time00=MPI_Wtime()
 100 #endif
 101 C
 102 C Compute the side-chain and electrostatic interaction energy
 103 C
 104 C      print *,ipot
 105       goto (101,102,103,104,105,106) ipot
 106 C Lennard-Jones potential.
 107   101 call elj(evdw)
 108 cd    print '(a)','Exit ELJ'
 109       goto 107
 110 C Lennard-Jones-Kihara potential (shifted).
 111   102 call eljk(evdw)
 112       goto 107
 113 C Berne-Pechukas potential (dilated LJ, angular dependence).
 114   103 call ebp(evdw)
 115       goto 107
 116 C Gay-Berne potential (shifted LJ, angular dependence).
 117   104 call egb(evdw)
 118 C      print *,"bylem w egb"
 119       goto 107
 120 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 121   105 call egbv(evdw)
 122       goto 107
 123 C Soft-sphere potential
 124   106 call e_softsphere(evdw)
 125 C
 126 C Calculate electrostatic (H-bonding) energy of the main chain.
 127 C
 128   107 continue
 129 cmc
 130 cmc Sep-06: egb takes care of dynamic ss bonds too
 131 cmc
 132 c      if (dyn_ss) call dyn_set_nss
 133
 134 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136       time01=MPI_Wtime()
 137 #endif
 138       call vec_and_deriv
 139 #ifdef TIMING
 140       time_vec=time_vec+MPI_Wtime()-time01
 141 #endif
 142 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 143       if (ipot.lt.6) then
 144 #ifdef SPLITELE
 145          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #else
 150          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 151      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 152      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 153      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 154 #endif
 155             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 156          else
 157             ees=0.0d0
 158             evdw1=0.0d0
 159             eel_loc=0.0d0
 160             eello_turn3=0.0d0
 161             eello_turn4=0.0d0
 162          endif
 163       else
 164         write (iout,*) "Soft-spheer ELEC potential"
 165         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 166      &   eello_turn4)
 167       endif
 168 c      print *,"Processor",myrank," computed UELEC"
 169 C
 170 C Calculate excluded-volume interaction energy between peptide groups
 171 C and side chains.
 172 C
 173       if (ipot.lt.6) then
 174        if(wscp.gt.0d0) then
 175         call escp(evdw2,evdw2_14)
 176        else
 177         evdw2=0
 178         evdw2_14=0
 179        endif
 180       else
 181 c        write (iout,*) "Soft-sphere SCP potential"
 182         call escp_soft_sphere(evdw2,evdw2_14)
 183       endif
 184 c
 185 c Calculate the bond-stretching energy
 186 c
 187       call ebond(estr)
 188 C
 189 C Calculate the disulfide-bridge and other energy and the contributions
 190 C from other distance constraints.
 191 cd    print *,'Calling EHPB'
 192       call edis(ehpb)
 193 cd    print *,'EHPB exitted succesfully.'
 194 C
 195 C Calculate the virtual-bond-angle energy.
 196 C
 197       if (wang.gt.0d0) then
 198         call ebend(ebe)
 199       else
 200         ebe=0
 201       endif
 202 c      print *,"Processor",myrank," computed UB"
 203 C
 204 C Calculate the SC local energy.
 205 C
 206 C      print *,"TU DOCHODZE?"
 207       call esc(escloc)
 208 c      print *,"Processor",myrank," computed USC"
 209 C
 210 C Calculate the virtual-bond torsional energy.
 211 C
 212 cd    print *,'nterm=',nterm
 213       if (wtor.gt.0) then
 214        call etor(etors,edihcnstr)
 215       else
 216        etors=0
 217        edihcnstr=0
 218       endif
 219
 220       if (constr_homology.ge.1) then
 221         call e_modeller(ehomology_constr)
 222 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 223 c     &  'Processor',fg_rank,' CG group',kolor,
 224 c     &  ' absolute rank',MyRank
 225       else
 226         ehomology_constr=0.0d0
 227       endif
 228
 229
 230 c      write(iout,*) ehomology_constr
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 C      print *,"PRZED MULIt"
 250 c      print *,"Processor",myrank," computed Usccorr"
 251 C
 252 C 12/1/95 Multi-body terms
 253 C
 254       n_corr=0
 255       n_corr1=0
 256       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 257      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 258          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 259 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 260 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 261       else
 262          ecorr=0.0d0
 263          ecorr5=0.0d0
 264          ecorr6=0.0d0
 265          eturn6=0.0d0
 266       endif
 267       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 268          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 269 cd         write (iout,*) "multibody_hb ecorr",ecorr
 270       endif
 271 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 272       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 273         call e_saxs(Esaxs_constr)
 274 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 275       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 276         call e_saxsC(Esaxs_constr)
 277 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 278       else
 279         Esaxs_constr = 0.0d0
 280       endif
 281 c      print *,"Processor",myrank," computed Ucorr"
 282 C
 283 C If performing constraint dynamics, call the constraint energy
 284 C  after the equilibration time
 285       if(usampl.and.totT.gt.eq_time) then
 286          call EconstrQ
 287          call Econstr_back
 288       else
 289          Uconst=0.0d0
 290          Uconst_back=0.0d0
 291       endif
 292 C 01/27/2015 added by adasko
 293 C the energy component below is energy transfer into lipid environment
 294 C based on partition function
 295 C      print *,"przed lipidami"
 296       if (wliptran.gt.0) then
 297         call Eliptransfer(eliptran)
 298       endif
 299 C      print *,"za lipidami"
 300       if (AFMlog.gt.0) then
 301         call AFMforce(Eafmforce)
 302       else if (selfguide.gt.0) then
 303         call AFMvel(Eafmforce)
 304       endif
 305 #ifdef TIMING
 306       time_enecalc=time_enecalc+MPI_Wtime()-time00
 307 #endif
 308 c      print *,"Processor",myrank," computed Uconstr"
 309 #ifdef TIMING
 310       time00=MPI_Wtime()
 311 #endif
 312 c
 313 C Sum the energies
 314 C
 315       energia(1)=evdw
 316 #ifdef SCP14
 317       energia(2)=evdw2-evdw2_14
 318       energia(18)=evdw2_14
 319 #else
 320       energia(2)=evdw2
 321       energia(18)=0.0d0
 322 #endif
 323 #ifdef SPLITELE
 324       energia(3)=ees
 325       energia(16)=evdw1
 326 #else
 327       energia(3)=ees+evdw1
 328       energia(16)=0.0d0
 329 #endif
 330       energia(4)=ecorr
 331       energia(5)=ecorr5
 332       energia(6)=ecorr6
 333       energia(7)=eel_loc
 334       energia(8)=eello_turn3
 335       energia(9)=eello_turn4
 336       energia(10)=eturn6
 337       energia(11)=ebe
 338       energia(12)=escloc
 339       energia(13)=etors
 340       energia(14)=etors_d
 341       energia(15)=ehpb
 342       energia(19)=edihcnstr
 343       energia(17)=estr
 344       energia(20)=Uconst+Uconst_back
 345       energia(21)=esccor
 346       energia(22)=eliptran
 347       energia(23)=Eafmforce
 348       energia(24)=ehomology_constr
 349       energia(25)=Esaxs_constr
 350 c    Here are the energies showed per procesor if the are more processors
 351 c    per molecule then we sum it up in sum_energy subroutine
 352 c      print *," Processor",myrank," calls SUM_ENERGY"
 353       call sum_energy(energia,.true.)
 354       if (dyn_ss) call dyn_set_nss
 355 c      print *," Processor",myrank," left SUM_ENERGY"
 356 #ifdef TIMING
 357       time_sumene=time_sumene+MPI_Wtime()-time00
 358 #endif
 359       return
 360       end
 361 c-------------------------------------------------------------------------------
 362       subroutine sum_energy(energia,reduce)
 363       implicit real*8 (a-h,o-z)
 364       include 'DIMENSIONS'
 365 #ifndef ISNAN
 366       external proc_proc
 367 #ifdef WINPGI
 368 cMS$ATTRIBUTES C ::  proc_proc
 369 #endif
 370 #endif
 371 #ifdef MPI
 372       include "mpif.h"
 373 #endif
 374       include 'COMMON.SETUP'
 375       include 'COMMON.IOUNITS'
 376       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 377       include 'COMMON.FFIELD'
 378       include 'COMMON.DERIV'
 379       include 'COMMON.INTERACT'
 380       include 'COMMON.SBRIDGE'
 381       include 'COMMON.CHAIN'
 382       include 'COMMON.VAR'
 383       include 'COMMON.CONTROL'
 384       include 'COMMON.TIME1'
 385       logical reduce
 386 #ifdef MPI
 387       if (nfgtasks.gt.1 .and. reduce) then
 388 #ifdef DEBUG
 389         write (iout,*) "energies before REDUCE"
 390         call enerprint(energia)
 391         call flush(iout)
 392 #endif
 393         do i=0,n_ene
 394           enebuff(i)=energia(i)
 395         enddo
 396         time00=MPI_Wtime()
 397         call MPI_Barrier(FG_COMM,IERR)
 398         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 399         time00=MPI_Wtime()
 400         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 401      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 402 #ifdef DEBUG
 403         write (iout,*) "energies after REDUCE"
 404         call enerprint(energia)
 405         call flush(iout)
 406 #endif
 407         time_Reduce=time_Reduce+MPI_Wtime()-time00
 408       endif
 409       if (fg_rank.eq.0) then
 410 #endif
 411       evdw=energia(1)
 412 #ifdef SCP14
 413       evdw2=energia(2)+energia(18)
 414       evdw2_14=energia(18)
 415 #else
 416       evdw2=energia(2)
 417 #endif
 418 #ifdef SPLITELE
 419       ees=energia(3)
 420       evdw1=energia(16)
 421 #else
 422       ees=energia(3)
 423       evdw1=0.0d0
 424 #endif
 425       ecorr=energia(4)
 426       ecorr5=energia(5)
 427       ecorr6=energia(6)
 428       eel_loc=energia(7)
 429       eello_turn3=energia(8)
 430       eello_turn4=energia(9)
 431       eturn6=energia(10)
 432       ebe=energia(11)
 433       escloc=energia(12)
 434       etors=energia(13)
 435       etors_d=energia(14)
 436       ehpb=energia(15)
 437       edihcnstr=energia(19)
 438       estr=energia(17)
 439       Uconst=energia(20)
 440       esccor=energia(21)
 441       eliptran=energia(22)
 442       Eafmforce=energia(23)
 443       ehomology_constr=energia(24)
 444       esaxs_constr=energia(25)
 445 c      write (iout,*) "sum_energy esaxs_constr",esaxs_constr,
 446 c     &  " wsaxs",wsaxs
 447 #ifdef SPLITELE
 448       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 449      & +wang*ebe+wtor*etors+wscloc*escloc
 450      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 451      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 452      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 453      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 454      & +wsaxs*esaxs_constr+wliptran*eliptran+Eafmforce
 455 #else
 456       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 457      & +wang*ebe+wtor*etors+wscloc*escloc
 458      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 459      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 460      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 461      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 462      & +wsaxs*esaxs_constr+wliptran*eliptran
 463      & +Eafmforce
 464 #endif
 465       energia(0)=etot
 466 c detecting NaNQ
 467 #ifdef ISNAN
 468 #ifdef AIX
 469       if (isnan(etot).ne.0) energia(0)=1.0d+99
 470 #else
 471       if (isnan(etot)) energia(0)=1.0d+99
 472 #endif
 473 #else
 474       i=0
 475 #ifdef WINPGI
 476       idumm=proc_proc(etot,i)
 477 #else
 478       call proc_proc(etot,i)
 479 #endif
 480       if(i.eq.1)energia(0)=1.0d+99
 481 #endif
 482 #ifdef MPI
 483       endif
 484 #endif
 485       return
 486       end
 487 c-------------------------------------------------------------------------------
 488       subroutine sum_gradient
 489       implicit real*8 (a-h,o-z)
 490       include 'DIMENSIONS'
 491 #ifndef ISNAN
 492       external proc_proc
 493 #ifdef WINPGI
 494 cMS$ATTRIBUTES C ::  proc_proc
 495 #endif
 496 #endif
 497 #ifdef MPI
 498       include 'mpif.h'
 499 #endif
 500       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 501      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 502      & ,gloc_scbuf(3,-1:maxres)
 503       include 'COMMON.SETUP'
 504       include 'COMMON.IOUNITS'
 505       include 'COMMON.FFIELD'
 506       include 'COMMON.DERIV'
 507       include 'COMMON.INTERACT'
 508       include 'COMMON.SBRIDGE'
 509       include 'COMMON.CHAIN'
 510       include 'COMMON.VAR'
 511       include 'COMMON.CONTROL'
 512       include 'COMMON.TIME1'
 513       include 'COMMON.MAXGRAD'
 514       include 'COMMON.SCCOR'
 515       include 'COMMON.MD'
 516 #ifdef TIMING
 517       time01=MPI_Wtime()
 518 #endif
 519 #ifdef DEBUG
 520       write (iout,*) "sum_gradient gvdwc, gvdwx"
 521       do i=0,nres
 522         write (iout,'(i3,3e15.5,5x,3e15.5)')
 523      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 524       enddo
 525       call flush(iout)
 526 #endif
 527 #ifdef DEBUG
 528       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 529       do i=0,nres
 530         write (iout,'(i3,3e15.5,5x,3e15.5)')
 531      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 532       enddo
 533       call flush(iout)
 534 #endif
 535 #ifdef MPI
 536 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 537         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 538      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 539 #endif
 540 C
 541 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 542 C            in virtual-bond-vector coordinates
 543 C
 544 #ifdef DEBUG
 545 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 546 c      do i=1,nres-1
 547 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 548 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 549 c      enddo
 550 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 551 c      do i=1,nres-1
 552 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 553 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 554 c      enddo
 555       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 556       do i=1,nres
 557         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 558      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 559      &   g_corr5_loc(i)
 560       enddo
 561       call flush(iout)
 562 #endif
 563 #ifdef SPLITELE
 564       do i=0,nct
 565         do j=1,3
 566           gradbufc(j,i)=wsc*gvdwc(j,i)+
 567      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 568      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 569      &                wel_loc*gel_loc_long(j,i)+
 570      &                wcorr*gradcorr_long(j,i)+
 571      &                wcorr5*gradcorr5_long(j,i)+
 572      &                wcorr6*gradcorr6_long(j,i)+
 573      &                wturn6*gcorr6_turn_long(j,i)+
 574      &                wstrain*ghpbc(j,i)+
 575      &                wsaxs*gsaxsc(j,i)
 576      &                +wliptran*gliptranc(j,i)
 577      &                +gradafm(j,i)
 578
 579         enddo
 580       enddo
 581 #else
 582       do i=0,nct
 583         do j=1,3
 584           gradbufc(j,i)=wsc*gvdwc(j,i)+
 585      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 586      &                welec*gelc_long(j,i)+
 587      &                wbond*gradb(j,i)+
 588      &                wel_loc*gel_loc_long(j,i)+
 589      &                wcorr*gradcorr_long(j,i)+
 590      &                wcorr5*gradcorr5_long(j,i)+
 591      &                wcorr6*gradcorr6_long(j,i)+
 592      &                wturn6*gcorr6_turn_long(j,i)+
 593      &                wstrain*ghpbc(j,i)+
 594      &                wsaxs*gsaxsc(j,i)
 595      &                +wliptran*gliptranc(j,i)
 596      &                +gradafm(j,i)
 597
 598         enddo
 599       enddo
 600 #endif
 601 #ifdef MPI
 602       if (nfgtasks.gt.1) then
 603       time00=MPI_Wtime()
 604 #ifdef DEBUG
 605       write (iout,*) "gradbufc before allreduce"
 606       do i=1,nres
 607         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 608       enddo
 609       call flush(iout)
 610 #endif
 611       do i=0,nres
 612         do j=1,3
 613           gradbufc_sum(j,i)=gradbufc(j,i)
 614         enddo
 615       enddo
 616 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 617 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 618 c      time_reduce=time_reduce+MPI_Wtime()-time00
 619 #ifdef DEBUG
 620 c      write (iout,*) "gradbufc_sum after allreduce"
 621 c      do i=1,nres
 622 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 623 c      enddo
 624 c      call flush(iout)
 625 #endif
 626 #ifdef TIMING
 627 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 628 #endif
 629       do i=nnt,nres
 630         do k=1,3
 631           gradbufc(k,i)=0.0d0
 632         enddo
 633       enddo
 634 #ifdef DEBUG
 635       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 636       write (iout,*) (i," jgrad_start",jgrad_start(i),
 637      &                  " jgrad_end  ",jgrad_end(i),
 638      &                  i=igrad_start,igrad_end)
 639 #endif
 640 c
 641 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 642 c do not parallelize this part.
 643 c
 644 c      do i=igrad_start,igrad_end
 645 c        do j=jgrad_start(i),jgrad_end(i)
 646 c          do k=1,3
 647 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 648 c          enddo
 649 c        enddo
 650 c      enddo
 651       do j=1,3
 652         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 653       enddo
 654       do i=nres-2,0,-1
 655 c      do i=nres-2,nnt,-1
 656         do j=1,3
 657           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 658         enddo
 659       enddo
 660 #ifdef DEBUG
 661       write (iout,*) "gradbufc after summing"
 662       do i=1,nres
 663         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 664       enddo
 665       call flush(iout)
 666 #endif
 667       else
 668 #endif
 669 #ifdef DEBUG
 670       write (iout,*) "gradbufc"
 671       do i=0,nres
 672         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 673       enddo
 674       call flush(iout)
 675 #endif
 676       do i=-1,nres
 677         do j=1,3
 678           gradbufc_sum(j,i)=gradbufc(j,i)
 679           gradbufc(j,i)=0.0d0
 680         enddo
 681       enddo
 682       do j=1,3
 683         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 684       enddo
 685       do i=nres-2,0,-1
 686 c      do i=nres-2,nnt,-1
 687         do j=1,3
 688           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 689         enddo
 690       enddo
 691 c      do i=nnt,nres-1
 692 c        do k=1,3
 693 c          gradbufc(k,i)=0.0d0
 694 c        enddo
 695 c        do j=i+1,nres
 696 c          do k=1,3
 697 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 698 c          enddo
 699 c        enddo
 700 c      enddo
 701 #ifdef DEBUG
 702       write (iout,*) "gradbufc after summing"
 703       do i=0,nres
 704         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 705       enddo
 706       call flush(iout)
 707 #endif
 708 #ifdef MPI
 709       endif
 710 #endif
 711       do k=1,3
 712         gradbufc(k,nres)=0.0d0
 713       enddo
 714       do i=-1,nct
 715         do j=1,3
 716 #ifdef SPLITELE
 717           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 718      &                wel_loc*gel_loc(j,i)+
 719      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 720      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 721      &                wel_loc*gel_loc_long(j,i)+
 722      &                wcorr*gradcorr_long(j,i)+
 723      &                wcorr5*gradcorr5_long(j,i)+
 724      &                wcorr6*gradcorr6_long(j,i)+
 725      &                wturn6*gcorr6_turn_long(j,i))+
 726      &                wbond*gradb(j,i)+
 727      &                wcorr*gradcorr(j,i)+
 728      &                wturn3*gcorr3_turn(j,i)+
 729      &                wturn4*gcorr4_turn(j,i)+
 730      &                wcorr5*gradcorr5(j,i)+
 731      &                wcorr6*gradcorr6(j,i)+
 732      &                wturn6*gcorr6_turn(j,i)+
 733      &                wsccor*gsccorc(j,i)
 734      &               +wscloc*gscloc(j,i)
 735      &               +wliptran*gliptranc(j,i)
 736      &                +gradafm(j,i)
 737 #else
 738           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 739      &                wel_loc*gel_loc(j,i)+
 740      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 741      &                welec*gelc_long(j,i) +
 742      &                wel_loc*gel_loc_long(j,i)+
 743      &                wcorr*gcorr_long(j,i)+
 744      &                wcorr5*gradcorr5_long(j,i)+
 745      &                wcorr6*gradcorr6_long(j,i)+
 746      &                wturn6*gcorr6_turn_long(j,i))+
 747      &                wbond*gradb(j,i)+
 748      &                wcorr*gradcorr(j,i)+
 749      &                wturn3*gcorr3_turn(j,i)+
 750      &                wturn4*gcorr4_turn(j,i)+
 751      &                wcorr5*gradcorr5(j,i)+
 752      &                wcorr6*gradcorr6(j,i)+
 753      &                wturn6*gcorr6_turn(j,i)+
 754      &                wsccor*gsccorc(j,i)
 755      &               +wscloc*gscloc(j,i)
 756      &               +wliptran*gliptranc(j,i)
 757      &                +gradafm(j,i)
 758
 759 #endif
 760           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 761      &                  wbond*gradbx(j,i)+
 762      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 763      &                 +wsaxs*gsaxsx(j,i)
 764      &                 +wsccor*gsccorx(j,i)
 765      &                 +wscloc*gsclocx(j,i)
 766      &                 +wliptran*gliptranx(j,i)
 767         enddo
 768       enddo
 769       if (constr_homology.gt.0) then
 770         do i=1,nct
 771           do j=1,3
 772             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 773             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 774           enddo
 775         enddo
 776       endif
 777 #ifdef DEBUG
 778       write (iout,*) "gloc before adding corr"
 779       do i=1,4*nres
 780         write (iout,*) i,gloc(i,icg)
 781       enddo
 782 #endif
 783       do i=1,nres-3
 784         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 785      &   +wcorr5*g_corr5_loc(i)
 786      &   +wcorr6*g_corr6_loc(i)
 787      &   +wturn4*gel_loc_turn4(i)
 788      &   +wturn3*gel_loc_turn3(i)
 789      &   +wturn6*gel_loc_turn6(i)
 790      &   +wel_loc*gel_loc_loc(i)
 791       enddo
 792 #ifdef DEBUG
 793       write (iout,*) "gloc after adding corr"
 794       do i=1,4*nres
 795         write (iout,*) i,gloc(i,icg)
 796       enddo
 797 #endif
 798 #ifdef MPI
 799       if (nfgtasks.gt.1) then
 800         do j=1,3
 801           do i=1,nres
 802             gradbufc(j,i)=gradc(j,i,icg)
 803             gradbufx(j,i)=gradx(j,i,icg)
 804           enddo
 805         enddo
 806         do i=1,4*nres
 807           glocbuf(i)=gloc(i,icg)
 808         enddo
 809 c#define DEBUG
 810 #ifdef DEBUG
 811       write (iout,*) "gloc_sc before reduce"
 812       do i=1,nres
 813        do j=1,1
 814         write (iout,*) i,j,gloc_sc(j,i,icg)
 815        enddo
 816       enddo
 817 #endif
 818 c#undef DEBUG
 819         do i=1,nres
 820          do j=1,3
 821           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 822          enddo
 823         enddo
 824         time00=MPI_Wtime()
 825         call MPI_Barrier(FG_COMM,IERR)
 826         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 827         time00=MPI_Wtime()
 828         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 829      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 830         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 831      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 832         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 833      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 834         time_reduce=time_reduce+MPI_Wtime()-time00
 835         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 836      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 837         time_reduce=time_reduce+MPI_Wtime()-time00
 838 c#define DEBUG
 839 #ifdef DEBUG
 840       write (iout,*) "gloc_sc after reduce"
 841       do i=1,nres
 842        do j=1,1
 843         write (iout,*) i,j,gloc_sc(j,i,icg)
 844        enddo
 845       enddo
 846 #endif
 847 c#undef DEBUG
 848 #ifdef DEBUG
 849       write (iout,*) "gloc after reduce"
 850       do i=1,4*nres
 851         write (iout,*) i,gloc(i,icg)
 852       enddo
 853 #endif
 854       endif
 855 #endif
 856       if (gnorm_check) then
 857 c
 858 c Compute the maximum elements of the gradient
 859 c
 860       gvdwc_max=0.0d0
 861       gvdwc_scp_max=0.0d0
 862       gelc_max=0.0d0
 863       gvdwpp_max=0.0d0
 864       gradb_max=0.0d0
 865       ghpbc_max=0.0d0
 866       gradcorr_max=0.0d0
 867       gel_loc_max=0.0d0
 868       gcorr3_turn_max=0.0d0
 869       gcorr4_turn_max=0.0d0
 870       gradcorr5_max=0.0d0
 871       gradcorr6_max=0.0d0
 872       gcorr6_turn_max=0.0d0
 873       gsccorc_max=0.0d0
 874       gscloc_max=0.0d0
 875       gvdwx_max=0.0d0
 876       gradx_scp_max=0.0d0
 877       ghpbx_max=0.0d0
 878       gradxorr_max=0.0d0
 879       gsccorx_max=0.0d0
 880       gsclocx_max=0.0d0
 881       do i=1,nct
 882         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 883         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 884         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 885         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 886      &   gvdwc_scp_max=gvdwc_scp_norm
 887         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 888         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 889         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 890         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 891         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 892         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 893         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 894         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 895         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 896         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 897         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 898         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 899         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 900      &    gcorr3_turn(1,i)))
 901         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 902      &    gcorr3_turn_max=gcorr3_turn_norm
 903         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 904      &    gcorr4_turn(1,i)))
 905         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 906      &    gcorr4_turn_max=gcorr4_turn_norm
 907         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 908         if (gradcorr5_norm.gt.gradcorr5_max)
 909      &    gradcorr5_max=gradcorr5_norm
 910         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 911         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 912         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 913      &    gcorr6_turn(1,i)))
 914         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 915      &    gcorr6_turn_max=gcorr6_turn_norm
 916         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 917         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 918         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 919         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 920         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 921         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 922         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 923         if (gradx_scp_norm.gt.gradx_scp_max)
 924      &    gradx_scp_max=gradx_scp_norm
 925         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 926         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 927         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 928         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 929         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 930         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 931         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 932         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 933       enddo
 934       if (gradout) then
 935 #ifdef AIX
 936         open(istat,file=statname,position="append")
 937 #else
 938         open(istat,file=statname,access="append")
 939 #endif
 940         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 941      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 942      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 943      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 944      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 945      &     gsccorx_max,gsclocx_max
 946         close(istat)
 947         if (gvdwc_max.gt.1.0d4) then
 948           write (iout,*) "gvdwc gvdwx gradb gradbx"
 949           do i=nnt,nct
 950             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 951      &        gradb(j,i),gradbx(j,i),j=1,3)
 952           enddo
 953           call pdbout(0.0d0,'cipiszcze',iout)
 954           call flush(iout)
 955         endif
 956       endif
 957       endif
 958 #ifdef DEBUG
 959       write (iout,*) "gradc gradx gloc"
 960       do i=1,nres
 961         write (iout,'(i5,3e15.5,5x,3e15.5,5x,e15.5)')
 962      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 963       enddo
 964 #endif
 965 #ifdef TIMING
 966       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 967 #endif
 968       return
 969       end
 970 c-------------------------------------------------------------------------------
 971       subroutine rescale_weights(t_bath)
 972       implicit real*8 (a-h,o-z)
 973       include 'DIMENSIONS'
 974       include 'COMMON.IOUNITS'
 975       include 'COMMON.FFIELD'
 976       include 'COMMON.SBRIDGE'
 977       double precision kfac /2.4d0/
 978       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 979 c      facT=temp0/t_bath
 980 c      facT=2*temp0/(t_bath+temp0)
 981       if (rescale_mode.eq.0) then
 982         facT=1.0d0
 983         facT2=1.0d0
 984         facT3=1.0d0
 985         facT4=1.0d0
 986         facT5=1.0d0
 987       else if (rescale_mode.eq.1) then
 988         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 989         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 990         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 991         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 992         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 993       else if (rescale_mode.eq.2) then
 994         x=t_bath/temp0
 995         x2=x*x
 996         x3=x2*x
 997         x4=x3*x
 998         x5=x4*x
 999         facT=licznik/dlog(dexp(x)+dexp(-x))
1000         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1001         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1002         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1003         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1004       else
1005         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1006         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1007 #ifdef MPI
1008        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1009 #endif
1010        stop 555
1011       endif
1012       welec=weights(3)*fact
1013       wcorr=weights(4)*fact3
1014       wcorr5=weights(5)*fact4
1015       wcorr6=weights(6)*fact5
1016       wel_loc=weights(7)*fact2
1017       wturn3=weights(8)*fact2
1018       wturn4=weights(9)*fact3
1019       wturn6=weights(10)*fact5
1020       wtor=weights(13)*fact
1021       wtor_d=weights(14)*fact2
1022       wsccor=weights(21)*fact
1023
1024       return
1025       end
1026 C------------------------------------------------------------------------
1027       subroutine enerprint(energia)
1028       implicit real*8 (a-h,o-z)
1029       include 'DIMENSIONS'
1030       include 'COMMON.IOUNITS'
1031       include 'COMMON.FFIELD'
1032       include 'COMMON.SBRIDGE'
1033       include 'COMMON.MD'
1034       double precision energia(0:n_ene)
1035       etot=energia(0)
1036       evdw=energia(1)
1037       evdw2=energia(2)
1038 #ifdef SCP14
1039       evdw2=energia(2)+energia(18)
1040 #else
1041       evdw2=energia(2)
1042 #endif
1043       ees=energia(3)
1044 #ifdef SPLITELE
1045       evdw1=energia(16)
1046 #endif
1047       ecorr=energia(4)
1048       ecorr5=energia(5)
1049       ecorr6=energia(6)
1050       eel_loc=energia(7)
1051       eello_turn3=energia(8)
1052       eello_turn4=energia(9)
1053       eello_turn6=energia(10)
1054       ebe=energia(11)
1055       escloc=energia(12)
1056       etors=energia(13)
1057       etors_d=energia(14)
1058       ehpb=energia(15)
1059       edihcnstr=energia(19)
1060       estr=energia(17)
1061       Uconst=energia(20)
1062       esccor=energia(21)
1063       ehomology_constr=energia(24)
1064       esaxs_constr=energia(25)
1065       eliptran=energia(22)
1066       Eafmforce=energia(23)
1067 #ifdef SPLITELE
1068       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1069      &  estr,wbond,ebe,wang,
1070      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1071      &  ecorr,wcorr,
1072      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1073      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1074      &  edihcnstr,ehomology_constr,esaxs_constr*wsaxs, ebr*nss,
1075      &  Uconst,eliptran,wliptran,Eafmforce,etot
1076    10 format (/'Virtual-chain energies:'//
1077      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1078      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1079      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1080      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1081      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1082      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1083      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1084      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1085      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1086      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1087      & ' (SS bridges & dist. cnstr.)'/
1088      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1089      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1090      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1091      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1092      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1093      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1094      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1095      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1096      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1097      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1098      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
1099      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1100      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1101      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1102      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1103      & 'ETOT=  ',1pE16.6,' (total)')
1104
1105 #else
1106       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1107      &  estr,wbond,ebe,wang,
1108      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1109      &  ecorr,wcorr,
1110      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1111      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1112      &  ehomology_constr,esaxs_constr*wsaxs,ebr*nss,Uconst,
1113      &  eliptran,wliptran,Eafmforc,
1114      &  etot
1115    10 format (/'Virtual-chain energies:'//
1116      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1117      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1118      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1119      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1120      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1121      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1122      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1123      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1124      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1125      & ' (SS bridges & dist. cnstr.)'/
1126      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1127      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1128      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1129      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1130      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1131      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1132      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1133      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1134      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1135      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1136      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
1137      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1138      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1139      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1140      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1141      & 'ETOT=  ',1pE16.6,' (total)')
1142 #endif
1143       return
1144       end
1145 C-----------------------------------------------------------------------
1146       subroutine elj(evdw)
1147 C
1148 C This subroutine calculates the interaction energy of nonbonded side chains
1149 C assuming the LJ potential of interaction.
1150 C
1151       implicit real*8 (a-h,o-z)
1152       include 'DIMENSIONS'
1153       parameter (accur=1.0d-10)
1154       include 'COMMON.GEO'
1155       include 'COMMON.VAR'
1156       include 'COMMON.LOCAL'
1157       include 'COMMON.CHAIN'
1158       include 'COMMON.DERIV'
1159       include 'COMMON.INTERACT'
1160       include 'COMMON.TORSION'
1161       include 'COMMON.SBRIDGE'
1162       include 'COMMON.NAMES'
1163       include 'COMMON.IOUNITS'
1164       include 'COMMON.CONTACTS'
1165       dimension gg(3)
1166 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1167       evdw=0.0D0
1168       do i=iatsc_s,iatsc_e
1169         itypi=iabs(itype(i))
1170         if (itypi.eq.ntyp1) cycle
1171         itypi1=iabs(itype(i+1))
1172         xi=c(1,nres+i)
1173         yi=c(2,nres+i)
1174         zi=c(3,nres+i)
1175 C Change 12/1/95
1176         num_conti=0
1177 C
1178 C Calculate SC interaction energy.
1179 C
1180         do iint=1,nint_gr(i)
1181 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1182 cd   &                  'iend=',iend(i,iint)
1183           do j=istart(i,iint),iend(i,iint)
1184             itypj=iabs(itype(j))
1185             if (itypj.eq.ntyp1) cycle
1186             xj=c(1,nres+j)-xi
1187             yj=c(2,nres+j)-yi
1188             zj=c(3,nres+j)-zi
1189 C Change 12/1/95 to calculate four-body interactions
1190             rij=xj*xj+yj*yj+zj*zj
1191             rrij=1.0D0/rij
1192 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1193             eps0ij=eps(itypi,itypj)
1194             fac=rrij**expon2
1195 C have you changed here?
1196             e1=fac*fac*aa
1197             e2=fac*bb
1198             evdwij=e1+e2
1199 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1200 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1201 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1202 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1203 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1204 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1205             evdw=evdw+evdwij
1206 C
1207 C Calculate the components of the gradient in DC and X
1208 C
1209             fac=-rrij*(e1+evdwij)
1210             gg(1)=xj*fac
1211             gg(2)=yj*fac
1212             gg(3)=zj*fac
1213             do k=1,3
1214               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1215               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1216               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1217               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1218             enddo
1219 cgrad            do k=i,j-1
1220 cgrad              do l=1,3
1221 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1222 cgrad              enddo
1223 cgrad            enddo
1224 C
1225 C 12/1/95, revised on 5/20/97
1226 C
1227 C Calculate the contact function. The ith column of the array JCONT will
1228 C contain the numbers of atoms that make contacts with the atom I (of numbers
1229 C greater than I). The arrays FACONT and GACONT will contain the values of
1230 C the contact function and its derivative.
1231 C
1232 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1233 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1234 C Uncomment next line, if the correlation interactions are contact function only
1235             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1236               rij=dsqrt(rij)
1237               sigij=sigma(itypi,itypj)
1238               r0ij=rs0(itypi,itypj)
1239 C
1240 C Check whether the SC's are not too far to make a contact.
1241 C
1242               rcut=1.5d0*r0ij
1243               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1244 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1245 C
1246               if (fcont.gt.0.0D0) then
1247 C If the SC-SC distance if close to sigma, apply spline.
1248 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1249 cAdam &             fcont1,fprimcont1)
1250 cAdam           fcont1=1.0d0-fcont1
1251 cAdam           if (fcont1.gt.0.0d0) then
1252 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1253 cAdam             fcont=fcont*fcont1
1254 cAdam           endif
1255 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1256 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1257 cga             do k=1,3
1258 cga               gg(k)=gg(k)*eps0ij
1259 cga             enddo
1260 cga             eps0ij=-evdwij*eps0ij
1261 C Uncomment for AL's type of SC correlation interactions.
1262 cadam           eps0ij=-evdwij
1263                 num_conti=num_conti+1
1264                 jcont(num_conti,i)=j
1265                 facont(num_conti,i)=fcont*eps0ij
1266                 fprimcont=eps0ij*fprimcont/rij
1267                 fcont=expon*fcont
1268 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1269 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1270 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1271 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1272                 gacont(1,num_conti,i)=-fprimcont*xj
1273                 gacont(2,num_conti,i)=-fprimcont*yj
1274                 gacont(3,num_conti,i)=-fprimcont*zj
1275 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1276 cd              write (iout,'(2i3,3f10.5)')
1277 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1278               endif
1279             endif
1280           enddo      ! j
1281         enddo        ! iint
1282 C Change 12/1/95
1283         num_cont(i)=num_conti
1284       enddo          ! i
1285       do i=1,nct
1286         do j=1,3
1287           gvdwc(j,i)=expon*gvdwc(j,i)
1288           gvdwx(j,i)=expon*gvdwx(j,i)
1289         enddo
1290       enddo
1291 C******************************************************************************
1292 C
1293 C                              N O T E !!!
1294 C
1295 C To save time, the factor of EXPON has been extracted from ALL components
1296 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1297 C use!
1298 C
1299 C******************************************************************************
1300       return
1301       end
1302 C-----------------------------------------------------------------------------
1303       subroutine eljk(evdw)
1304 C
1305 C This subroutine calculates the interaction energy of nonbonded side chains
1306 C assuming the LJK potential of interaction.
1307 C
1308       implicit real*8 (a-h,o-z)
1309       include 'DIMENSIONS'
1310       include 'COMMON.GEO'
1311       include 'COMMON.VAR'
1312       include 'COMMON.LOCAL'
1313       include 'COMMON.CHAIN'
1314       include 'COMMON.DERIV'
1315       include 'COMMON.INTERACT'
1316       include 'COMMON.IOUNITS'
1317       include 'COMMON.NAMES'
1318       dimension gg(3)
1319       logical scheck
1320 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1321       evdw=0.0D0
1322       do i=iatsc_s,iatsc_e
1323         itypi=iabs(itype(i))
1324         if (itypi.eq.ntyp1) cycle
1325         itypi1=iabs(itype(i+1))
1326         xi=c(1,nres+i)
1327         yi=c(2,nres+i)
1328         zi=c(3,nres+i)
1329 C
1330 C Calculate SC interaction energy.
1331 C
1332         do iint=1,nint_gr(i)
1333           do j=istart(i,iint),iend(i,iint)
1334             itypj=iabs(itype(j))
1335             if (itypj.eq.ntyp1) cycle
1336             xj=c(1,nres+j)-xi
1337             yj=c(2,nres+j)-yi
1338             zj=c(3,nres+j)-zi
1339             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1340             fac_augm=rrij**expon
1341             e_augm=augm(itypi,itypj)*fac_augm
1342             r_inv_ij=dsqrt(rrij)
1343             rij=1.0D0/r_inv_ij
1344             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1345             fac=r_shift_inv**expon
1346 C have you changed here?
1347             e1=fac*fac*aa
1348             e2=fac*bb
1349             evdwij=e_augm+e1+e2
1350 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1351 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1352 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1353 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1354 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1355 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1356 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1357             evdw=evdw+evdwij
1358 C
1359 C Calculate the components of the gradient in DC and X
1360 C
1361             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1362             gg(1)=xj*fac
1363             gg(2)=yj*fac
1364             gg(3)=zj*fac
1365             do k=1,3
1366               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1367               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1368               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1369               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1370             enddo
1371 cgrad            do k=i,j-1
1372 cgrad              do l=1,3
1373 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1374 cgrad              enddo
1375 cgrad            enddo
1376           enddo      ! j
1377         enddo        ! iint
1378       enddo          ! i
1379       do i=1,nct
1380         do j=1,3
1381           gvdwc(j,i)=expon*gvdwc(j,i)
1382           gvdwx(j,i)=expon*gvdwx(j,i)
1383         enddo
1384       enddo
1385       return
1386       end
1387 C-----------------------------------------------------------------------------
1388       subroutine ebp(evdw)
1389 C
1390 C This subroutine calculates the interaction energy of nonbonded side chains
1391 C assuming the Berne-Pechukas potential of interaction.
1392 C
1393       implicit real*8 (a-h,o-z)
1394       include 'DIMENSIONS'
1395       include 'COMMON.GEO'
1396       include 'COMMON.VAR'
1397       include 'COMMON.LOCAL'
1398       include 'COMMON.CHAIN'
1399       include 'COMMON.DERIV'
1400       include 'COMMON.NAMES'
1401       include 'COMMON.INTERACT'
1402       include 'COMMON.IOUNITS'
1403       include 'COMMON.CALC'
1404       common /srutu/ icall
1405 c     double precision rrsave(maxdim)
1406       logical lprn
1407       evdw=0.0D0
1408 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1409       evdw=0.0D0
1410 c     if (icall.eq.0) then
1411 c       lprn=.true.
1412 c     else
1413         lprn=.false.
1414 c     endif
1415       ind=0
1416       do i=iatsc_s,iatsc_e
1417         itypi=iabs(itype(i))
1418         if (itypi.eq.ntyp1) cycle
1419         itypi1=iabs(itype(i+1))
1420         xi=c(1,nres+i)
1421         yi=c(2,nres+i)
1422         zi=c(3,nres+i)
1423         dxi=dc_norm(1,nres+i)
1424         dyi=dc_norm(2,nres+i)
1425         dzi=dc_norm(3,nres+i)
1426 c        dsci_inv=dsc_inv(itypi)
1427         dsci_inv=vbld_inv(i+nres)
1428 C
1429 C Calculate SC interaction energy.
1430 C
1431         do iint=1,nint_gr(i)
1432           do j=istart(i,iint),iend(i,iint)
1433             ind=ind+1
1434             itypj=iabs(itype(j))
1435             if (itypj.eq.ntyp1) cycle
1436 c            dscj_inv=dsc_inv(itypj)
1437             dscj_inv=vbld_inv(j+nres)
1438             chi1=chi(itypi,itypj)
1439             chi2=chi(itypj,itypi)
1440             chi12=chi1*chi2
1441             chip1=chip(itypi)
1442             chip2=chip(itypj)
1443             chip12=chip1*chip2
1444             alf1=alp(itypi)
1445             alf2=alp(itypj)
1446             alf12=0.5D0*(alf1+alf2)
1447 C For diagnostics only!!!
1448 c           chi1=0.0D0
1449 c           chi2=0.0D0
1450 c           chi12=0.0D0
1451 c           chip1=0.0D0
1452 c           chip2=0.0D0
1453 c           chip12=0.0D0
1454 c           alf1=0.0D0
1455 c           alf2=0.0D0
1456 c           alf12=0.0D0
1457             xj=c(1,nres+j)-xi
1458             yj=c(2,nres+j)-yi
1459             zj=c(3,nres+j)-zi
1460             dxj=dc_norm(1,nres+j)
1461             dyj=dc_norm(2,nres+j)
1462             dzj=dc_norm(3,nres+j)
1463             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1464 cd          if (icall.eq.0) then
1465 cd            rrsave(ind)=rrij
1466 cd          else
1467 cd            rrij=rrsave(ind)
1468 cd          endif
1469             rij=dsqrt(rrij)
1470 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1471             call sc_angular
1472 C Calculate whole angle-dependent part of epsilon and contributions
1473 C to its derivatives
1474 C have you changed here?
1475             fac=(rrij*sigsq)**expon2
1476             e1=fac*fac*aa
1477             e2=fac*bb
1478             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1479             eps2der=evdwij*eps3rt
1480             eps3der=evdwij*eps2rt
1481             evdwij=evdwij*eps2rt*eps3rt
1482             evdw=evdw+evdwij
1483             if (lprn) then
1484             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1485             epsi=bb**2/aa
1486 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1487 cd     &        restyp(itypi),i,restyp(itypj),j,
1488 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1489 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1490 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1491 cd     &        evdwij
1492             endif
1493 C Calculate gradient components.
1494             e1=e1*eps1*eps2rt**2*eps3rt**2
1495             fac=-expon*(e1+evdwij)
1496             sigder=fac/sigsq
1497             fac=rrij*fac
1498 C Calculate radial part of the gradient
1499             gg(1)=xj*fac
1500             gg(2)=yj*fac
1501             gg(3)=zj*fac
1502 C Calculate the angular part of the gradient and sum add the contributions
1503 C to the appropriate components of the Cartesian gradient.
1504             call sc_grad
1505           enddo      ! j
1506         enddo        ! iint
1507       enddo          ! i
1508 c     stop
1509       return
1510       end
1511 C-----------------------------------------------------------------------------
1512       subroutine egb(evdw)
1513 C
1514 C This subroutine calculates the interaction energy of nonbonded side chains
1515 C assuming the Gay-Berne potential of interaction.
1516 C
1517       implicit real*8 (a-h,o-z)
1518       include 'DIMENSIONS'
1519       include 'COMMON.GEO'
1520       include 'COMMON.VAR'
1521       include 'COMMON.LOCAL'
1522       include 'COMMON.CHAIN'
1523       include 'COMMON.DERIV'
1524       include 'COMMON.NAMES'
1525       include 'COMMON.INTERACT'
1526       include 'COMMON.IOUNITS'
1527       include 'COMMON.CALC'
1528       include 'COMMON.CONTROL'
1529       include 'COMMON.SPLITELE'
1530       include 'COMMON.SBRIDGE'
1531       logical lprn
1532       integer xshift,yshift,zshift
1533       evdw=0.0D0
1534 ccccc      energy_dec=.false.
1535 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1536       evdw=0.0D0
1537       lprn=.false.
1538 c     if (icall.eq.0) lprn=.false.
1539       ind=0
1540 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1541 C we have the original box)
1542 C      do xshift=-1,1
1543 C      do yshift=-1,1
1544 C      do zshift=-1,1
1545       do i=iatsc_s,iatsc_e
1546         itypi=iabs(itype(i))
1547         if (itypi.eq.ntyp1) cycle
1548         itypi1=iabs(itype(i+1))
1549         xi=c(1,nres+i)
1550         yi=c(2,nres+i)
1551         zi=c(3,nres+i)
1552 C Return atom into box, boxxsize is size of box in x dimension
1553 c  134   continue
1554 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1555 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1556 C Condition for being inside the proper box
1557 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1558 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1559 c        go to 134
1560 c        endif
1561 c  135   continue
1562 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1563 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1564 C Condition for being inside the proper box
1565 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1566 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1567 c        go to 135
1568 c        endif
1569 c  136   continue
1570 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1571 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1572 C Condition for being inside the proper box
1573 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1574 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1575 c        go to 136
1576 c        endif
1577           xi=mod(xi,boxxsize)
1578           if (xi.lt.0) xi=xi+boxxsize
1579           yi=mod(yi,boxysize)
1580           if (yi.lt.0) yi=yi+boxysize
1581           zi=mod(zi,boxzsize)
1582           if (zi.lt.0) zi=zi+boxzsize
1583 C define scaling factor for lipids
1584
1585 C        if (positi.le.0) positi=positi+boxzsize
1586 C        print *,i
1587 C first for peptide groups
1588 c for each residue check if it is in lipid or lipid water border area
1589        if ((zi.gt.bordlipbot)
1590      &.and.(zi.lt.bordliptop)) then
1591 C the energy transfer exist
1592         if (zi.lt.buflipbot) then
1593 C what fraction I am in
1594          fracinbuf=1.0d0-
1595      &        ((zi-bordlipbot)/lipbufthick)
1596 C lipbufthick is thickenes of lipid buffore
1597          sslipi=sscalelip(fracinbuf)
1598          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1599         elseif (zi.gt.bufliptop) then
1600          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1601          sslipi=sscalelip(fracinbuf)
1602          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1603         else
1604          sslipi=1.0d0
1605          ssgradlipi=0.0
1606         endif
1607        else
1608          sslipi=0.0d0
1609          ssgradlipi=0.0
1610        endif
1611
1612 C          xi=xi+xshift*boxxsize
1613 C          yi=yi+yshift*boxysize
1614 C          zi=zi+zshift*boxzsize
1615
1616         dxi=dc_norm(1,nres+i)
1617         dyi=dc_norm(2,nres+i)
1618         dzi=dc_norm(3,nres+i)
1619 c        dsci_inv=dsc_inv(itypi)
1620         dsci_inv=vbld_inv(i+nres)
1621 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1622 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1623 C
1624 C Calculate SC interaction energy.
1625 C
1626         do iint=1,nint_gr(i)
1627           do j=istart(i,iint),iend(i,iint)
1628             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1629               call dyn_ssbond_ene(i,j,evdwij)
1630               evdw=evdw+evdwij
1631               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1632      &                        'evdw',i,j,evdwij,' ss'
1633             ELSE
1634             ind=ind+1
1635             itypj=iabs(itype(j))
1636             if (itypj.eq.ntyp1) cycle
1637 c            dscj_inv=dsc_inv(itypj)
1638             dscj_inv=vbld_inv(j+nres)
1639 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1640 c     &       1.0d0/vbld(j+nres)
1641 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1642             sig0ij=sigma(itypi,itypj)
1643             chi1=chi(itypi,itypj)
1644             chi2=chi(itypj,itypi)
1645             chi12=chi1*chi2
1646             chip1=chip(itypi)
1647             chip2=chip(itypj)
1648             chip12=chip1*chip2
1649             alf1=alp(itypi)
1650             alf2=alp(itypj)
1651             alf12=0.5D0*(alf1+alf2)
1652 C For diagnostics only!!!
1653 c           chi1=0.0D0
1654 c           chi2=0.0D0
1655 c           chi12=0.0D0
1656 c           chip1=0.0D0
1657 c           chip2=0.0D0
1658 c           chip12=0.0D0
1659 c           alf1=0.0D0
1660 c           alf2=0.0D0
1661 c           alf12=0.0D0
1662             xj=c(1,nres+j)
1663             yj=c(2,nres+j)
1664             zj=c(3,nres+j)
1665 C Return atom J into box the original box
1666 c  137   continue
1667 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1668 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1669 C Condition for being inside the proper box
1670 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1671 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1672 c        go to 137
1673 c        endif
1674 c  138   continue
1675 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1676 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1677 C Condition for being inside the proper box
1678 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1679 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1680 c        go to 138
1681 c        endif
1682 c  139   continue
1683 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1684 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1685 C Condition for being inside the proper box
1686 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1687 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1688 c        go to 139
1689 c        endif
1690           xj=mod(xj,boxxsize)
1691           if (xj.lt.0) xj=xj+boxxsize
1692           yj=mod(yj,boxysize)
1693           if (yj.lt.0) yj=yj+boxysize
1694           zj=mod(zj,boxzsize)
1695           if (zj.lt.0) zj=zj+boxzsize
1696        if ((zj.gt.bordlipbot)
1697      &.and.(zj.lt.bordliptop)) then
1698 C the energy transfer exist
1699         if (zj.lt.buflipbot) then
1700 C what fraction I am in
1701          fracinbuf=1.0d0-
1702      &        ((zj-bordlipbot)/lipbufthick)
1703 C lipbufthick is thickenes of lipid buffore
1704          sslipj=sscalelip(fracinbuf)
1705          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1706         elseif (zj.gt.bufliptop) then
1707          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1708          sslipj=sscalelip(fracinbuf)
1709          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1710         else
1711          sslipj=1.0d0
1712          ssgradlipj=0.0
1713         endif
1714        else
1715          sslipj=0.0d0
1716          ssgradlipj=0.0
1717        endif
1718       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1719      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1720       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1721      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1722 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1723 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1724 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1725 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1726       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1727       xj_safe=xj
1728       yj_safe=yj
1729       zj_safe=zj
1730       subchap=0
1731       do xshift=-1,1
1732       do yshift=-1,1
1733       do zshift=-1,1
1734           xj=xj_safe+xshift*boxxsize
1735           yj=yj_safe+yshift*boxysize
1736           zj=zj_safe+zshift*boxzsize
1737           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1738           if(dist_temp.lt.dist_init) then
1739             dist_init=dist_temp
1740             xj_temp=xj
1741             yj_temp=yj
1742             zj_temp=zj
1743             subchap=1
1744           endif
1745        enddo
1746        enddo
1747        enddo
1748        if (subchap.eq.1) then
1749           xj=xj_temp-xi
1750           yj=yj_temp-yi
1751           zj=zj_temp-zi
1752        else
1753           xj=xj_safe-xi
1754           yj=yj_safe-yi
1755           zj=zj_safe-zi
1756        endif
1757             dxj=dc_norm(1,nres+j)
1758             dyj=dc_norm(2,nres+j)
1759             dzj=dc_norm(3,nres+j)
1760 C            xj=xj-xi
1761 C            yj=yj-yi
1762 C            zj=zj-zi
1763 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1764 c            write (iout,*) "j",j," dc_norm",
1765 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1766             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1767             rij=dsqrt(rrij)
1768             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1769             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1770
1771 c            write (iout,'(a7,4f8.3)')
1772 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1773             if (sss.gt.0.0d0) then
1774 C Calculate angle-dependent terms of energy and contributions to their
1775 C derivatives.
1776             call sc_angular
1777             sigsq=1.0D0/sigsq
1778             sig=sig0ij*dsqrt(sigsq)
1779             rij_shift=1.0D0/rij-sig+sig0ij
1780 c for diagnostics; uncomment
1781 c            rij_shift=1.2*sig0ij
1782 C I hate to put IF's in the loops, but here don't have another choice!!!!
1783             if (rij_shift.le.0.0D0) then
1784               evdw=1.0D20
1785 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1786 cd     &        restyp(itypi),i,restyp(itypj),j,
1787 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1788               return
1789             endif
1790             sigder=-sig*sigsq
1791 c---------------------------------------------------------------
1792             rij_shift=1.0D0/rij_shift
1793             fac=rij_shift**expon
1794 C here to start with
1795 C            if (c(i,3).gt.
1796             faclip=fac
1797             e1=fac*fac*aa
1798             e2=fac*bb
1799             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1800             eps2der=evdwij*eps3rt
1801             eps3der=evdwij*eps2rt
1802 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1803 C     &((sslipi+sslipj)/2.0d0+
1804 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1805 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1806 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1807             evdwij=evdwij*eps2rt*eps3rt
1808             evdw=evdw+evdwij*sss
1809             if (lprn) then
1810             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1811             epsi=bb**2/aa
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,chi1,chi2,chip1,chip2,
1815      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1816      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1817      &        evdwij
1818             endif
1819
1820             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1821      &                        'evdw',i,j,evdwij
1822
1823 C Calculate gradient components.
1824             e1=e1*eps1*eps2rt**2*eps3rt**2
1825             fac=-expon*(e1+evdwij)*rij_shift
1826             sigder=fac*sigder
1827             fac=rij*fac
1828 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1829 c     &      evdwij,fac,sigma(itypi,itypj),expon
1830             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1831 c            fac=0.0d0
1832 C Calculate the radial part of the gradient
1833             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1834      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1835      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1836      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1837             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1838             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1839 C            gg_lipi(3)=0.0d0
1840 C            gg_lipj(3)=0.0d0
1841             gg(1)=xj*fac
1842             gg(2)=yj*fac
1843             gg(3)=zj*fac
1844 C Calculate angular part of the gradient.
1845             call sc_grad
1846             endif
1847             ENDIF    ! dyn_ss
1848           enddo      ! j
1849         enddo        ! iint
1850       enddo          ! i
1851 C      enddo          ! zshift
1852 C      enddo          ! yshift
1853 C      enddo          ! xshift
1854 c      write (iout,*) "Number of loop steps in EGB:",ind
1855 cccc      energy_dec=.false.
1856       return
1857       end
1858 C-----------------------------------------------------------------------------
1859       subroutine egbv(evdw)
1860 C
1861 C This subroutine calculates the interaction energy of nonbonded side chains
1862 C assuming the Gay-Berne-Vorobjev potential of interaction.
1863 C
1864       implicit real*8 (a-h,o-z)
1865       include 'DIMENSIONS'
1866       include 'COMMON.GEO'
1867       include 'COMMON.VAR'
1868       include 'COMMON.LOCAL'
1869       include 'COMMON.CHAIN'
1870       include 'COMMON.DERIV'
1871       include 'COMMON.NAMES'
1872       include 'COMMON.INTERACT'
1873       include 'COMMON.IOUNITS'
1874       include 'COMMON.CALC'
1875       common /srutu/ icall
1876       logical lprn
1877       evdw=0.0D0
1878 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1879       evdw=0.0D0
1880       lprn=.false.
1881 c     if (icall.eq.0) lprn=.true.
1882       ind=0
1883       do i=iatsc_s,iatsc_e
1884         itypi=iabs(itype(i))
1885         if (itypi.eq.ntyp1) cycle
1886         itypi1=iabs(itype(i+1))
1887         xi=c(1,nres+i)
1888         yi=c(2,nres+i)
1889         zi=c(3,nres+i)
1890           xi=mod(xi,boxxsize)
1891           if (xi.lt.0) xi=xi+boxxsize
1892           yi=mod(yi,boxysize)
1893           if (yi.lt.0) yi=yi+boxysize
1894           zi=mod(zi,boxzsize)
1895           if (zi.lt.0) zi=zi+boxzsize
1896 C define scaling factor for lipids
1897
1898 C        if (positi.le.0) positi=positi+boxzsize
1899 C        print *,i
1900 C first for peptide groups
1901 c for each residue check if it is in lipid or lipid water border area
1902        if ((zi.gt.bordlipbot)
1903      &.and.(zi.lt.bordliptop)) then
1904 C the energy transfer exist
1905         if (zi.lt.buflipbot) then
1906 C what fraction I am in
1907          fracinbuf=1.0d0-
1908      &        ((zi-bordlipbot)/lipbufthick)
1909 C lipbufthick is thickenes of lipid buffore
1910          sslipi=sscalelip(fracinbuf)
1911          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1912         elseif (zi.gt.bufliptop) then
1913          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1914          sslipi=sscalelip(fracinbuf)
1915          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1916         else
1917          sslipi=1.0d0
1918          ssgradlipi=0.0
1919         endif
1920        else
1921          sslipi=0.0d0
1922          ssgradlipi=0.0
1923        endif
1924
1925         dxi=dc_norm(1,nres+i)
1926         dyi=dc_norm(2,nres+i)
1927         dzi=dc_norm(3,nres+i)
1928 c        dsci_inv=dsc_inv(itypi)
1929         dsci_inv=vbld_inv(i+nres)
1930 C
1931 C Calculate SC interaction energy.
1932 C
1933         do iint=1,nint_gr(i)
1934           do j=istart(i,iint),iend(i,iint)
1935             ind=ind+1
1936             itypj=iabs(itype(j))
1937             if (itypj.eq.ntyp1) cycle
1938 c            dscj_inv=dsc_inv(itypj)
1939             dscj_inv=vbld_inv(j+nres)
1940             sig0ij=sigma(itypi,itypj)
1941             r0ij=r0(itypi,itypj)
1942             chi1=chi(itypi,itypj)
1943             chi2=chi(itypj,itypi)
1944             chi12=chi1*chi2
1945             chip1=chip(itypi)
1946             chip2=chip(itypj)
1947             chip12=chip1*chip2
1948             alf1=alp(itypi)
1949             alf2=alp(itypj)
1950             alf12=0.5D0*(alf1+alf2)
1951 C For diagnostics only!!!
1952 c           chi1=0.0D0
1953 c           chi2=0.0D0
1954 c           chi12=0.0D0
1955 c           chip1=0.0D0
1956 c           chip2=0.0D0
1957 c           chip12=0.0D0
1958 c           alf1=0.0D0
1959 c           alf2=0.0D0
1960 c           alf12=0.0D0
1961 C            xj=c(1,nres+j)-xi
1962 C            yj=c(2,nres+j)-yi
1963 C            zj=c(3,nres+j)-zi
1964           xj=mod(xj,boxxsize)
1965           if (xj.lt.0) xj=xj+boxxsize
1966           yj=mod(yj,boxysize)
1967           if (yj.lt.0) yj=yj+boxysize
1968           zj=mod(zj,boxzsize)
1969           if (zj.lt.0) zj=zj+boxzsize
1970        if ((zj.gt.bordlipbot)
1971      &.and.(zj.lt.bordliptop)) then
1972 C the energy transfer exist
1973         if (zj.lt.buflipbot) then
1974 C what fraction I am in
1975          fracinbuf=1.0d0-
1976      &        ((zj-bordlipbot)/lipbufthick)
1977 C lipbufthick is thickenes of lipid buffore
1978          sslipj=sscalelip(fracinbuf)
1979          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1980         elseif (zj.gt.bufliptop) then
1981          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1982          sslipj=sscalelip(fracinbuf)
1983          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1984         else
1985          sslipj=1.0d0
1986          ssgradlipj=0.0
1987         endif
1988        else
1989          sslipj=0.0d0
1990          ssgradlipj=0.0
1991        endif
1992       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1993      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1994       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1995      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1996 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1997 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1998       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1999       xj_safe=xj
2000       yj_safe=yj
2001       zj_safe=zj
2002       subchap=0
2003       do xshift=-1,1
2004       do yshift=-1,1
2005       do zshift=-1,1
2006           xj=xj_safe+xshift*boxxsize
2007           yj=yj_safe+yshift*boxysize
2008           zj=zj_safe+zshift*boxzsize
2009           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2010           if(dist_temp.lt.dist_init) then
2011             dist_init=dist_temp
2012             xj_temp=xj
2013             yj_temp=yj
2014             zj_temp=zj
2015             subchap=1
2016           endif
2017        enddo
2018        enddo
2019        enddo
2020        if (subchap.eq.1) then
2021           xj=xj_temp-xi
2022           yj=yj_temp-yi
2023           zj=zj_temp-zi
2024        else
2025           xj=xj_safe-xi
2026           yj=yj_safe-yi
2027           zj=zj_safe-zi
2028        endif
2029             dxj=dc_norm(1,nres+j)
2030             dyj=dc_norm(2,nres+j)
2031             dzj=dc_norm(3,nres+j)
2032             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2033             rij=dsqrt(rrij)
2034 C Calculate angle-dependent terms of energy and contributions to their
2035 C derivatives.
2036             call sc_angular
2037             sigsq=1.0D0/sigsq
2038             sig=sig0ij*dsqrt(sigsq)
2039             rij_shift=1.0D0/rij-sig+r0ij
2040 C I hate to put IF's in the loops, but here don't have another choice!!!!
2041             if (rij_shift.le.0.0D0) then
2042               evdw=1.0D20
2043               return
2044             endif
2045             sigder=-sig*sigsq
2046 c---------------------------------------------------------------
2047             rij_shift=1.0D0/rij_shift
2048             fac=rij_shift**expon
2049             e1=fac*fac*aa
2050             e2=fac*bb
2051             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2052             eps2der=evdwij*eps3rt
2053             eps3der=evdwij*eps2rt
2054             fac_augm=rrij**expon
2055             e_augm=augm(itypi,itypj)*fac_augm
2056             evdwij=evdwij*eps2rt*eps3rt
2057             evdw=evdw+evdwij+e_augm
2058             if (lprn) then
2059             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2060             epsi=bb**2/aa
2061             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2062      &        restyp(itypi),i,restyp(itypj),j,
2063      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2064      &        chi1,chi2,chip1,chip2,
2065      &        eps1,eps2rt**2,eps3rt**2,
2066      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2067      &        evdwij+e_augm
2068             endif
2069 C Calculate gradient components.
2070             e1=e1*eps1*eps2rt**2*eps3rt**2
2071             fac=-expon*(e1+evdwij)*rij_shift
2072             sigder=fac*sigder
2073             fac=rij*fac-2*expon*rrij*e_augm
2074             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2075 C Calculate the radial part of the gradient
2076             gg(1)=xj*fac
2077             gg(2)=yj*fac
2078             gg(3)=zj*fac
2079 C Calculate angular part of the gradient.
2080             call sc_grad
2081           enddo      ! j
2082         enddo        ! iint
2083       enddo          ! i
2084       end
2085 C-----------------------------------------------------------------------------
2086       subroutine sc_angular
2087 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2088 C om12. Called by ebp, egb, and egbv.
2089       implicit none
2090       include 'COMMON.CALC'
2091       include 'COMMON.IOUNITS'
2092       erij(1)=xj*rij
2093       erij(2)=yj*rij
2094       erij(3)=zj*rij
2095       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2096       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2097       om12=dxi*dxj+dyi*dyj+dzi*dzj
2098       chiom12=chi12*om12
2099 C Calculate eps1(om12) and its derivative in om12
2100       faceps1=1.0D0-om12*chiom12
2101       faceps1_inv=1.0D0/faceps1
2102       eps1=dsqrt(faceps1_inv)
2103 C Following variable is eps1*deps1/dom12
2104       eps1_om12=faceps1_inv*chiom12
2105 c diagnostics only
2106 c      faceps1_inv=om12
2107 c      eps1=om12
2108 c      eps1_om12=1.0d0
2109 c      write (iout,*) "om12",om12," eps1",eps1
2110 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2111 C and om12.
2112       om1om2=om1*om2
2113       chiom1=chi1*om1
2114       chiom2=chi2*om2
2115       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2116       sigsq=1.0D0-facsig*faceps1_inv
2117       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2118       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2119       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2120 c diagnostics only
2121 c      sigsq=1.0d0
2122 c      sigsq_om1=0.0d0
2123 c      sigsq_om2=0.0d0
2124 c      sigsq_om12=0.0d0
2125 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2126 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2127 c     &    " eps1",eps1
2128 C Calculate eps2 and its derivatives in om1, om2, and om12.
2129       chipom1=chip1*om1
2130       chipom2=chip2*om2
2131       chipom12=chip12*om12
2132       facp=1.0D0-om12*chipom12
2133       facp_inv=1.0D0/facp
2134       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2135 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2136 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2137 C Following variable is the square root of eps2
2138       eps2rt=1.0D0-facp1*facp_inv
2139 C Following three variables are the derivatives of the square root of eps
2140 C in om1, om2, and om12.
2141       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2142       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2143       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2144 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2145       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2146 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2147 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2148 c     &  " eps2rt_om12",eps2rt_om12
2149 C Calculate whole angle-dependent part of epsilon and contributions
2150 C to its derivatives
2151       return
2152       end
2153 C----------------------------------------------------------------------------
2154       subroutine sc_grad
2155       implicit real*8 (a-h,o-z)
2156       include 'DIMENSIONS'
2157       include 'COMMON.CHAIN'
2158       include 'COMMON.DERIV'
2159       include 'COMMON.CALC'
2160       include 'COMMON.IOUNITS'
2161       double precision dcosom1(3),dcosom2(3)
2162 cc      print *,'sss=',sss
2163       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2164       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2165       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2166      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2167 c diagnostics only
2168 c      eom1=0.0d0
2169 c      eom2=0.0d0
2170 c      eom12=evdwij*eps1_om12
2171 c end diagnostics
2172 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2173 c     &  " sigder",sigder
2174 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2175 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2176       do k=1,3
2177         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2178         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2179       enddo
2180       do k=1,3
2181         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2182       enddo
2183 c      write (iout,*) "gg",(gg(k),k=1,3)
2184       do k=1,3
2185         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2186      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2187      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2188         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2189      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2190      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2191 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2192 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2193 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2194 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2195       enddo
2196 C
2197 C Calculate the components of the gradient in DC and X
2198 C
2199 cgrad      do k=i,j-1
2200 cgrad        do l=1,3
2201 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2202 cgrad        enddo
2203 cgrad      enddo
2204       do l=1,3
2205         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2206         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2207       enddo
2208       return
2209       end
2210 C-----------------------------------------------------------------------
2211       subroutine e_softsphere(evdw)
2212 C
2213 C This subroutine calculates the interaction energy of nonbonded side chains
2214 C assuming the LJ potential of interaction.
2215 C
2216       implicit real*8 (a-h,o-z)
2217       include 'DIMENSIONS'
2218       parameter (accur=1.0d-10)
2219       include 'COMMON.GEO'
2220       include 'COMMON.VAR'
2221       include 'COMMON.LOCAL'
2222       include 'COMMON.CHAIN'
2223       include 'COMMON.DERIV'
2224       include 'COMMON.INTERACT'
2225       include 'COMMON.TORSION'
2226       include 'COMMON.SBRIDGE'
2227       include 'COMMON.NAMES'
2228       include 'COMMON.IOUNITS'
2229       include 'COMMON.CONTACTS'
2230       dimension gg(3)
2231 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2232       evdw=0.0D0
2233       do i=iatsc_s,iatsc_e
2234         itypi=iabs(itype(i))
2235         if (itypi.eq.ntyp1) cycle
2236         itypi1=iabs(itype(i+1))
2237         xi=c(1,nres+i)
2238         yi=c(2,nres+i)
2239         zi=c(3,nres+i)
2240 C
2241 C Calculate SC interaction energy.
2242 C
2243         do iint=1,nint_gr(i)
2244 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2245 cd   &                  'iend=',iend(i,iint)
2246           do j=istart(i,iint),iend(i,iint)
2247             itypj=iabs(itype(j))
2248             if (itypj.eq.ntyp1) cycle
2249             xj=c(1,nres+j)-xi
2250             yj=c(2,nres+j)-yi
2251             zj=c(3,nres+j)-zi
2252             rij=xj*xj+yj*yj+zj*zj
2253 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2254             r0ij=r0(itypi,itypj)
2255             r0ijsq=r0ij*r0ij
2256 c            print *,i,j,r0ij,dsqrt(rij)
2257             if (rij.lt.r0ijsq) then
2258               evdwij=0.25d0*(rij-r0ijsq)**2
2259               fac=rij-r0ijsq
2260             else
2261               evdwij=0.0d0
2262               fac=0.0d0
2263             endif
2264             evdw=evdw+evdwij
2265 C
2266 C Calculate the components of the gradient in DC and X
2267 C
2268             gg(1)=xj*fac
2269             gg(2)=yj*fac
2270             gg(3)=zj*fac
2271             do k=1,3
2272               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2273               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2274               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2275               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2276             enddo
2277 cgrad            do k=i,j-1
2278 cgrad              do l=1,3
2279 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2280 cgrad              enddo
2281 cgrad            enddo
2282           enddo ! j
2283         enddo ! iint
2284       enddo ! i
2285       return
2286       end
2287 C--------------------------------------------------------------------------
2288       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2289      &              eello_turn4)
2290 C
2291 C Soft-sphere potential of p-p interaction
2292 C
2293       implicit real*8 (a-h,o-z)
2294       include 'DIMENSIONS'
2295       include 'COMMON.CONTROL'
2296       include 'COMMON.IOUNITS'
2297       include 'COMMON.GEO'
2298       include 'COMMON.VAR'
2299       include 'COMMON.LOCAL'
2300       include 'COMMON.CHAIN'
2301       include 'COMMON.DERIV'
2302       include 'COMMON.INTERACT'
2303       include 'COMMON.CONTACTS'
2304       include 'COMMON.TORSION'
2305       include 'COMMON.VECTORS'
2306       include 'COMMON.FFIELD'
2307       dimension ggg(3)
2308 C      write(iout,*) 'In EELEC_soft_sphere'
2309       ees=0.0D0
2310       evdw1=0.0D0
2311       eel_loc=0.0d0
2312       eello_turn3=0.0d0
2313       eello_turn4=0.0d0
2314       ind=0
2315       do i=iatel_s,iatel_e
2316         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2317         dxi=dc(1,i)
2318         dyi=dc(2,i)
2319         dzi=dc(3,i)
2320         xmedi=c(1,i)+0.5d0*dxi
2321         ymedi=c(2,i)+0.5d0*dyi
2322         zmedi=c(3,i)+0.5d0*dzi
2323           xmedi=mod(xmedi,boxxsize)
2324           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2325           ymedi=mod(ymedi,boxysize)
2326           if (ymedi.lt.0) ymedi=ymedi+boxysize
2327           zmedi=mod(zmedi,boxzsize)
2328           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2329         num_conti=0
2330 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2331         do j=ielstart(i),ielend(i)
2332           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2333           ind=ind+1
2334           iteli=itel(i)
2335           itelj=itel(j)
2336           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2337           r0ij=rpp(iteli,itelj)
2338           r0ijsq=r0ij*r0ij
2339           dxj=dc(1,j)
2340           dyj=dc(2,j)
2341           dzj=dc(3,j)
2342           xj=c(1,j)+0.5D0*dxj
2343           yj=c(2,j)+0.5D0*dyj
2344           zj=c(3,j)+0.5D0*dzj
2345           xj=mod(xj,boxxsize)
2346           if (xj.lt.0) xj=xj+boxxsize
2347           yj=mod(yj,boxysize)
2348           if (yj.lt.0) yj=yj+boxysize
2349           zj=mod(zj,boxzsize)
2350           if (zj.lt.0) zj=zj+boxzsize
2351       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2352       xj_safe=xj
2353       yj_safe=yj
2354       zj_safe=zj
2355       isubchap=0
2356       do xshift=-1,1
2357       do yshift=-1,1
2358       do zshift=-1,1
2359           xj=xj_safe+xshift*boxxsize
2360           yj=yj_safe+yshift*boxysize
2361           zj=zj_safe+zshift*boxzsize
2362           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2363           if(dist_temp.lt.dist_init) then
2364             dist_init=dist_temp
2365             xj_temp=xj
2366             yj_temp=yj
2367             zj_temp=zj
2368             isubchap=1
2369           endif
2370        enddo
2371        enddo
2372        enddo
2373        if (isubchap.eq.1) then
2374           xj=xj_temp-xmedi
2375           yj=yj_temp-ymedi
2376           zj=zj_temp-zmedi
2377        else
2378           xj=xj_safe-xmedi
2379           yj=yj_safe-ymedi
2380           zj=zj_safe-zmedi
2381        endif
2382           rij=xj*xj+yj*yj+zj*zj
2383             sss=sscale(sqrt(rij))
2384             sssgrad=sscagrad(sqrt(rij))
2385           if (rij.lt.r0ijsq) then
2386             evdw1ij=0.25d0*(rij-r0ijsq)**2
2387             fac=rij-r0ijsq
2388           else
2389             evdw1ij=0.0d0
2390             fac=0.0d0
2391           endif
2392           evdw1=evdw1+evdw1ij*sss
2393 C
2394 C Calculate contributions to the Cartesian gradient.
2395 C
2396           ggg(1)=fac*xj*sssgrad
2397           ggg(2)=fac*yj*sssgrad
2398           ggg(3)=fac*zj*sssgrad
2399           do k=1,3
2400             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2401             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2402           enddo
2403 *
2404 * Loop over residues i+1 thru j-1.
2405 *
2406 cgrad          do k=i+1,j-1
2407 cgrad            do l=1,3
2408 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2409 cgrad            enddo
2410 cgrad          enddo
2411         enddo ! j
2412       enddo   ! i
2413 cgrad      do i=nnt,nct-1
2414 cgrad        do k=1,3
2415 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2416 cgrad        enddo
2417 cgrad        do j=i+1,nct-1
2418 cgrad          do k=1,3
2419 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2420 cgrad          enddo
2421 cgrad        enddo
2422 cgrad      enddo
2423       return
2424       end
2425 c------------------------------------------------------------------------------
2426       subroutine vec_and_deriv
2427       implicit real*8 (a-h,o-z)
2428       include 'DIMENSIONS'
2429 #ifdef MPI
2430       include 'mpif.h'
2431 #endif
2432       include 'COMMON.IOUNITS'
2433       include 'COMMON.GEO'
2434       include 'COMMON.VAR'
2435       include 'COMMON.LOCAL'
2436       include 'COMMON.CHAIN'
2437       include 'COMMON.VECTORS'
2438       include 'COMMON.SETUP'
2439       include 'COMMON.TIME1'
2440       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2441 C Compute the local reference systems. For reference system (i), the
2442 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2443 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2444 #ifdef PARVEC
2445       do i=ivec_start,ivec_end
2446 #else
2447       do i=1,nres-1
2448 #endif
2449           if (i.eq.nres-1) then
2450 C Case of the last full residue
2451 C Compute the Z-axis
2452             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2453             costh=dcos(pi-theta(nres))
2454             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2455             do k=1,3
2456               uz(k,i)=fac*uz(k,i)
2457             enddo
2458 C Compute the derivatives of uz
2459             uzder(1,1,1)= 0.0d0
2460             uzder(2,1,1)=-dc_norm(3,i-1)
2461             uzder(3,1,1)= dc_norm(2,i-1)
2462             uzder(1,2,1)= dc_norm(3,i-1)
2463             uzder(2,2,1)= 0.0d0
2464             uzder(3,2,1)=-dc_norm(1,i-1)
2465             uzder(1,3,1)=-dc_norm(2,i-1)
2466             uzder(2,3,1)= dc_norm(1,i-1)
2467             uzder(3,3,1)= 0.0d0
2468             uzder(1,1,2)= 0.0d0
2469             uzder(2,1,2)= dc_norm(3,i)
2470             uzder(3,1,2)=-dc_norm(2,i)
2471             uzder(1,2,2)=-dc_norm(3,i)
2472             uzder(2,2,2)= 0.0d0
2473             uzder(3,2,2)= dc_norm(1,i)
2474             uzder(1,3,2)= dc_norm(2,i)
2475             uzder(2,3,2)=-dc_norm(1,i)
2476             uzder(3,3,2)= 0.0d0
2477 C Compute the Y-axis
2478             facy=fac
2479             do k=1,3
2480               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2481             enddo
2482 C Compute the derivatives of uy
2483             do j=1,3
2484               do k=1,3
2485                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2486      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2487                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2488               enddo
2489               uyder(j,j,1)=uyder(j,j,1)-costh
2490               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2491             enddo
2492             do j=1,2
2493               do k=1,3
2494                 do l=1,3
2495                   uygrad(l,k,j,i)=uyder(l,k,j)
2496                   uzgrad(l,k,j,i)=uzder(l,k,j)
2497                 enddo
2498               enddo
2499             enddo
2500             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2501             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2502             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2503             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2504           else
2505 C Other residues
2506 C Compute the Z-axis
2507             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2508             costh=dcos(pi-theta(i+2))
2509             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2510             do k=1,3
2511               uz(k,i)=fac*uz(k,i)
2512             enddo
2513 C Compute the derivatives of uz
2514             uzder(1,1,1)= 0.0d0
2515             uzder(2,1,1)=-dc_norm(3,i+1)
2516             uzder(3,1,1)= dc_norm(2,i+1)
2517             uzder(1,2,1)= dc_norm(3,i+1)
2518             uzder(2,2,1)= 0.0d0
2519             uzder(3,2,1)=-dc_norm(1,i+1)
2520             uzder(1,3,1)=-dc_norm(2,i+1)
2521             uzder(2,3,1)= dc_norm(1,i+1)
2522             uzder(3,3,1)= 0.0d0
2523             uzder(1,1,2)= 0.0d0
2524             uzder(2,1,2)= dc_norm(3,i)
2525             uzder(3,1,2)=-dc_norm(2,i)
2526             uzder(1,2,2)=-dc_norm(3,i)
2527             uzder(2,2,2)= 0.0d0
2528             uzder(3,2,2)= dc_norm(1,i)
2529             uzder(1,3,2)= dc_norm(2,i)
2530             uzder(2,3,2)=-dc_norm(1,i)
2531             uzder(3,3,2)= 0.0d0
2532 C Compute the Y-axis
2533             facy=fac
2534             do k=1,3
2535               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2536             enddo
2537 C Compute the derivatives of uy
2538             do j=1,3
2539               do k=1,3
2540                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2541      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2542                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2543               enddo
2544               uyder(j,j,1)=uyder(j,j,1)-costh
2545               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2546             enddo
2547             do j=1,2
2548               do k=1,3
2549                 do l=1,3
2550                   uygrad(l,k,j,i)=uyder(l,k,j)
2551                   uzgrad(l,k,j,i)=uzder(l,k,j)
2552                 enddo
2553               enddo
2554             enddo
2555             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2556             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2557             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2558             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2559           endif
2560       enddo
2561       do i=1,nres-1
2562         vbld_inv_temp(1)=vbld_inv(i+1)
2563         if (i.lt.nres-1) then
2564           vbld_inv_temp(2)=vbld_inv(i+2)
2565           else
2566           vbld_inv_temp(2)=vbld_inv(i)
2567           endif
2568         do j=1,2
2569           do k=1,3
2570             do l=1,3
2571               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2572               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2573             enddo
2574           enddo
2575         enddo
2576       enddo
2577 #if defined(PARVEC) && defined(MPI)
2578       if (nfgtasks1.gt.1) then
2579         time00=MPI_Wtime()
2580 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2581 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2582 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2583         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2590      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2591      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2592         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2593      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2594      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2595         time_gather=time_gather+MPI_Wtime()-time00
2596       endif
2597 c      if (fg_rank.eq.0) then
2598 c        write (iout,*) "Arrays UY and UZ"
2599 c        do i=1,nres-1
2600 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2601 c     &     (uz(k,i),k=1,3)
2602 c        enddo
2603 c      endif
2604 #endif
2605       return
2606       end
2607 C-----------------------------------------------------------------------------
2608       subroutine check_vecgrad
2609       implicit real*8 (a-h,o-z)
2610       include 'DIMENSIONS'
2611       include 'COMMON.IOUNITS'
2612       include 'COMMON.GEO'
2613       include 'COMMON.VAR'
2614       include 'COMMON.LOCAL'
2615       include 'COMMON.CHAIN'
2616       include 'COMMON.VECTORS'
2617       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2618       dimension uyt(3,maxres),uzt(3,maxres)
2619       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2620       double precision delta /1.0d-7/
2621       call vec_and_deriv
2622 cd      do i=1,nres
2623 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2624 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2625 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2626 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2627 cd     &     (dc_norm(if90,i),if90=1,3)
2628 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2629 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2630 cd          write(iout,'(a)')
2631 cd      enddo
2632       do i=1,nres
2633         do j=1,2
2634           do k=1,3
2635             do l=1,3
2636               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2637               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2638             enddo
2639           enddo
2640         enddo
2641       enddo
2642       call vec_and_deriv
2643       do i=1,nres
2644         do j=1,3
2645           uyt(j,i)=uy(j,i)
2646           uzt(j,i)=uz(j,i)
2647         enddo
2648       enddo
2649       do i=1,nres
2650 cd        write (iout,*) 'i=',i
2651         do k=1,3
2652           erij(k)=dc_norm(k,i)
2653         enddo
2654         do j=1,3
2655           do k=1,3
2656             dc_norm(k,i)=erij(k)
2657           enddo
2658           dc_norm(j,i)=dc_norm(j,i)+delta
2659 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2660 c          do k=1,3
2661 c            dc_norm(k,i)=dc_norm(k,i)/fac
2662 c          enddo
2663 c          write (iout,*) (dc_norm(k,i),k=1,3)
2664 c          write (iout,*) (erij(k),k=1,3)
2665           call vec_and_deriv
2666           do k=1,3
2667             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2668             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2669             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2670             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2671           enddo
2672 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2673 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2674 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2675         enddo
2676         do k=1,3
2677           dc_norm(k,i)=erij(k)
2678         enddo
2679 cd        do k=1,3
2680 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2681 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2682 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2683 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2684 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2685 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2686 cd          write (iout,'(a)')
2687 cd        enddo
2688       enddo
2689       return
2690       end
2691 C--------------------------------------------------------------------------
2692       subroutine set_matrices
2693       implicit real*8 (a-h,o-z)
2694       include 'DIMENSIONS'
2695 #ifdef MPI
2696       include "mpif.h"
2697       include "COMMON.SETUP"
2698       integer IERR
2699       integer status(MPI_STATUS_SIZE)
2700 #endif
2701       include 'COMMON.IOUNITS'
2702       include 'COMMON.GEO'
2703       include 'COMMON.VAR'
2704       include 'COMMON.LOCAL'
2705       include 'COMMON.CHAIN'
2706       include 'COMMON.DERIV'
2707       include 'COMMON.INTERACT'
2708       include 'COMMON.CONTACTS'
2709       include 'COMMON.TORSION'
2710       include 'COMMON.VECTORS'
2711       include 'COMMON.FFIELD'
2712       double precision auxvec(2),auxmat(2,2)
2713 C
2714 C Compute the virtual-bond-torsional-angle dependent quantities needed
2715 C to calculate the el-loc multibody terms of various order.
2716 C
2717 c      write(iout,*) 'nphi=',nphi,nres
2718 #ifdef PARMAT
2719       do i=ivec_start+2,ivec_end+2
2720 #else
2721       do i=3,nres+1
2722 #endif
2723 #ifdef NEWCORR
2724         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2725           iti = itortyp(itype(i-2))
2726         else
2727           iti=ntortyp+1
2728         endif
2729 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2730         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2731           iti1 = itortyp(itype(i-1))
2732         else
2733           iti1=ntortyp+1
2734         endif
2735 c        write(iout,*),i
2736         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2737      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2738      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2739         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2740      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2741      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2742 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2743 c     &*(cos(theta(i)/2.0)
2744         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2745      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2746      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2747 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2748 c     &*(cos(theta(i)/2.0)
2749         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2750      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2751      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2752 c        if (ggb1(1,i).eq.0.0d0) then
2753 c        write(iout,*) 'i=',i,ggb1(1,i),
2754 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2755 c     &bnew1(2,1,iti)*cos(theta(i)),
2756 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2757 c        endif
2758         b1(2,i-2)=bnew1(1,2,iti)
2759         gtb1(2,i-2)=0.0
2760         b2(2,i-2)=bnew2(1,2,iti)
2761         gtb2(2,i-2)=0.0
2762         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2763         EE(1,2,i-2)=eeold(1,2,iti)
2764         EE(2,1,i-2)=eeold(2,1,iti)
2765         EE(2,2,i-2)=eeold(2,2,iti)
2766         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2767         gtEE(1,2,i-2)=0.0d0
2768         gtEE(2,2,i-2)=0.0d0
2769         gtEE(2,1,i-2)=0.0d0
2770 c        EE(2,2,iti)=0.0d0
2771 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2772 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2773 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2774 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2775        b1tilde(1,i-2)=b1(1,i-2)
2776        b1tilde(2,i-2)=-b1(2,i-2)
2777        b2tilde(1,i-2)=b2(1,i-2)
2778        b2tilde(2,i-2)=-b2(2,i-2)
2779 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2780 c       write(iout,*)  'b1=',b1(1,i-2)
2781 c       write (iout,*) 'theta=', theta(i-1)
2782        enddo
2783 #else
2784         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2785           iti = itortyp(itype(i-2))
2786         else
2787           iti=ntortyp+1
2788         endif
2789 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2790         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2791           iti1 = itortyp(itype(i-1))
2792         else
2793           iti1=ntortyp+1
2794         endif
2795         b1(1,i-2)=b(3,iti)
2796         b1(2,i-2)=b(5,iti)
2797         b2(1,i-2)=b(2,iti)
2798         b2(2,i-2)=b(4,iti)
2799        b1tilde(1,i-2)=b1(1,i-2)
2800        b1tilde(2,i-2)=-b1(2,i-2)
2801        b2tilde(1,i-2)=b2(1,i-2)
2802        b2tilde(2,i-2)=-b2(2,i-2)
2803         EE(1,2,i-2)=eeold(1,2,iti)
2804         EE(2,1,i-2)=eeold(2,1,iti)
2805         EE(2,2,i-2)=eeold(2,2,iti)
2806         EE(1,1,i-2)=eeold(1,1,iti)
2807       enddo
2808 #endif
2809 #ifdef PARMAT
2810       do i=ivec_start+2,ivec_end+2
2811 #else
2812       do i=3,nres+1
2813 #endif
2814         if (i .lt. nres+1) then
2815           sin1=dsin(phi(i))
2816           cos1=dcos(phi(i))
2817           sintab(i-2)=sin1
2818           costab(i-2)=cos1
2819           obrot(1,i-2)=cos1
2820           obrot(2,i-2)=sin1
2821           sin2=dsin(2*phi(i))
2822           cos2=dcos(2*phi(i))
2823           sintab2(i-2)=sin2
2824           costab2(i-2)=cos2
2825           obrot2(1,i-2)=cos2
2826           obrot2(2,i-2)=sin2
2827           Ug(1,1,i-2)=-cos1
2828           Ug(1,2,i-2)=-sin1
2829           Ug(2,1,i-2)=-sin1
2830           Ug(2,2,i-2)= cos1
2831           Ug2(1,1,i-2)=-cos2
2832           Ug2(1,2,i-2)=-sin2
2833           Ug2(2,1,i-2)=-sin2
2834           Ug2(2,2,i-2)= cos2
2835         else
2836           costab(i-2)=1.0d0
2837           sintab(i-2)=0.0d0
2838           obrot(1,i-2)=1.0d0
2839           obrot(2,i-2)=0.0d0
2840           obrot2(1,i-2)=0.0d0
2841           obrot2(2,i-2)=0.0d0
2842           Ug(1,1,i-2)=1.0d0
2843           Ug(1,2,i-2)=0.0d0
2844           Ug(2,1,i-2)=0.0d0
2845           Ug(2,2,i-2)=1.0d0
2846           Ug2(1,1,i-2)=0.0d0
2847           Ug2(1,2,i-2)=0.0d0
2848           Ug2(2,1,i-2)=0.0d0
2849           Ug2(2,2,i-2)=0.0d0
2850         endif
2851         if (i .gt. 3 .and. i .lt. nres+1) then
2852           obrot_der(1,i-2)=-sin1
2853           obrot_der(2,i-2)= cos1
2854           Ugder(1,1,i-2)= sin1
2855           Ugder(1,2,i-2)=-cos1
2856           Ugder(2,1,i-2)=-cos1
2857           Ugder(2,2,i-2)=-sin1
2858           dwacos2=cos2+cos2
2859           dwasin2=sin2+sin2
2860           obrot2_der(1,i-2)=-dwasin2
2861           obrot2_der(2,i-2)= dwacos2
2862           Ug2der(1,1,i-2)= dwasin2
2863           Ug2der(1,2,i-2)=-dwacos2
2864           Ug2der(2,1,i-2)=-dwacos2
2865           Ug2der(2,2,i-2)=-dwasin2
2866         else
2867           obrot_der(1,i-2)=0.0d0
2868           obrot_der(2,i-2)=0.0d0
2869           Ugder(1,1,i-2)=0.0d0
2870           Ugder(1,2,i-2)=0.0d0
2871           Ugder(2,1,i-2)=0.0d0
2872           Ugder(2,2,i-2)=0.0d0
2873           obrot2_der(1,i-2)=0.0d0
2874           obrot2_der(2,i-2)=0.0d0
2875           Ug2der(1,1,i-2)=0.0d0
2876           Ug2der(1,2,i-2)=0.0d0
2877           Ug2der(2,1,i-2)=0.0d0
2878           Ug2der(2,2,i-2)=0.0d0
2879         endif
2880 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2881         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2882           iti = itortyp(itype(i-2))
2883         else
2884           iti=ntortyp
2885         endif
2886 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2887         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2888           iti1 = itortyp(itype(i-1))
2889         else
2890           iti1=ntortyp
2891         endif
2892 cd        write (iout,*) '*******i',i,' iti1',iti
2893 cd        write (iout,*) 'b1',b1(:,iti)
2894 cd        write (iout,*) 'b2',b2(:,iti)
2895 cd         write (iout,*) "phi(",i,")=",phi(i)," sin1",sin1," cos1",cos1
2896 cd         write (iout,*) 'Ug',Ug(:,:,i-2)
2897 c        if (i .gt. iatel_s+2) then
2898         if (i .gt. nnt+2) then
2899           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2900 #ifdef NEWCORR
2901           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2902 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2903 #endif
2904 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2905 c     &    EE(1,2,iti),EE(2,2,iti)
2906           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2907           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2908 c          write(iout,*) "Macierz EUG",
2909 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2910 c     &    eug(2,2,i-2)
2911           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2912      &    then
2913           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2914           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2915           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2916           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2917           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2918           endif
2919         else
2920           do k=1,2
2921             Ub2(k,i-2)=0.0d0
2922             Ctobr(k,i-2)=0.0d0
2923             Dtobr2(k,i-2)=0.0d0
2924             do l=1,2
2925               EUg(l,k,i-2)=0.0d0
2926               CUg(l,k,i-2)=0.0d0
2927               DUg(l,k,i-2)=0.0d0
2928               DtUg2(l,k,i-2)=0.0d0
2929             enddo
2930           enddo
2931         endif
2932         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2933         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2934         do k=1,2
2935           muder(k,i-2)=Ub2der(k,i-2)
2936         enddo
2937 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2938         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2939           if (itype(i-1).le.ntyp) then
2940             iti1 = itortyp(itype(i-1))
2941           else
2942             iti1=ntortyp
2943           endif
2944         else
2945           iti1=ntortyp
2946         endif
2947         do k=1,2
2948           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2949         enddo
2950 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2951 cd        write (iout,*) 'mu  ',mu(:,i-2),i-2
2952 cd        write (iout,*) 'b1  ',b1(:,i-1),i-2
2953 cd        write (iout,*) 'Ub2 ',Ub2(:,i-2),i-2
2954 cd        write (iout,*) 'Ug  ',Ug(:,:,i-2),i-2
2955 cd        write (iout,*) 'b2  ',b2(:,i-2),i-2
2956 cd        write (iout,*) 'mu1',mu1(:,i-2)
2957 cd        write (iout,*) 'mu2',mu2(:,i-2)
2958         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2959      &  then
2960         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2961         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2962         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2963         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2964         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2965 C Vectors and matrices dependent on a single virtual-bond dihedral.
2966         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2967         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2968         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2969         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2970         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2971         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2972         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2973         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2974         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2975         endif
2976       enddo
2977 C Matrices dependent on two consecutive virtual-bond dihedrals.
2978 C The order of matrices is from left to right.
2979       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2980      &then
2981 c      do i=max0(ivec_start,2),ivec_end
2982       do i=2,nres-1
2983         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2984         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2985         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2986         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2987         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2988         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2989         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2990         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2991       enddo
2992       endif
2993 #if defined(MPI) && defined(PARMAT)
2994 #ifdef DEBUG
2995 c      if (fg_rank.eq.0) then
2996         write (iout,*) "Arrays UG and UGDER before GATHER"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     ((ug(l,k,i),l=1,2),k=1,2),
3000      &     ((ugder(l,k,i),l=1,2),k=1,2)
3001         enddo
3002         write (iout,*) "Arrays UG2 and UG2DER"
3003         do i=1,nres-1
3004           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3005      &     ((ug2(l,k,i),l=1,2),k=1,2),
3006      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3007         enddo
3008         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3009         do i=1,nres-1
3010           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3011      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3012      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3013         enddo
3014         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3015         do i=1,nres-1
3016           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3017      &     costab(i),sintab(i),costab2(i),sintab2(i)
3018         enddo
3019         write (iout,*) "Array MUDER"
3020         do i=1,nres-1
3021           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3022         enddo
3023 c      endif
3024 #endif
3025       if (nfgtasks.gt.1) then
3026         time00=MPI_Wtime()
3027 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3028 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3029 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3030 #ifdef MATGATHER
3031         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3047      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3048      &   FG_COMM1,IERR)
3049         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3050      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3051      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3052         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3053      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3054      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3055         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3056      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3057      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3058         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3059      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3060      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3061         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3062      &  then
3063         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3064      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3065      &   FG_COMM1,IERR)
3066         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3067      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3068      &   FG_COMM1,IERR)
3069         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3070      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3071      &   FG_COMM1,IERR)
3072        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3073      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3074      &   FG_COMM1,IERR)
3075         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3076      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3077      &   FG_COMM1,IERR)
3078         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3079      &   ivec_count(fg_rank1),
3080      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3083      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3084      &   FG_COMM1,IERR)
3085         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3086      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3087      &   FG_COMM1,IERR)
3088         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3089      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3092      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3093      &   FG_COMM1,IERR)
3094         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3095      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3096      &   FG_COMM1,IERR)
3097         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3098      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3099      &   FG_COMM1,IERR)
3100         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3101      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3102      &   FG_COMM1,IERR)
3103         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3104      &   ivec_count(fg_rank1),
3105      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3106      &   FG_COMM1,IERR)
3107         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3108      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3109      &   FG_COMM1,IERR)
3110        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3114      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3115      &   FG_COMM1,IERR)
3116        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3117      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3118      &   FG_COMM1,IERR)
3119         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3120      &   ivec_count(fg_rank1),
3121      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3122      &   FG_COMM1,IERR)
3123         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3124      &   ivec_count(fg_rank1),
3125      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3126      &   FG_COMM1,IERR)
3127         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3128      &   ivec_count(fg_rank1),
3129      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3130      &   MPI_MAT2,FG_COMM1,IERR)
3131         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3132      &   ivec_count(fg_rank1),
3133      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3134      &   MPI_MAT2,FG_COMM1,IERR)
3135         endif
3136 #else
3137 c Passes matrix info through the ring
3138       isend=fg_rank1
3139       irecv=fg_rank1-1
3140       if (irecv.lt.0) irecv=nfgtasks1-1
3141       iprev=irecv
3142       inext=fg_rank1+1
3143       if (inext.ge.nfgtasks1) inext=0
3144       do i=1,nfgtasks1-1
3145 c        write (iout,*) "isend",isend," irecv",irecv
3146 c        call flush(iout)
3147         lensend=lentyp(isend)
3148         lenrecv=lentyp(irecv)
3149 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3150 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3151 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3152 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3153 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3154 c        write (iout,*) "Gather ROTAT1"
3155 c        call flush(iout)
3156 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3157 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3158 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3159 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3160 c        write (iout,*) "Gather ROTAT2"
3161 c        call flush(iout)
3162         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3163      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3164      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3165      &   iprev,4400+irecv,FG_COMM,status,IERR)
3166 c        write (iout,*) "Gather ROTAT_OLD"
3167 c        call flush(iout)
3168         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3169      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3170      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3171      &   iprev,5500+irecv,FG_COMM,status,IERR)
3172 c        write (iout,*) "Gather PRECOMP11"
3173 c        call flush(iout)
3174         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3175      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3176      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3177      &   iprev,6600+irecv,FG_COMM,status,IERR)
3178 c        write (iout,*) "Gather PRECOMP12"
3179 c        call flush(iout)
3180         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3181      &  then
3182         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3183      &   MPI_ROTAT2(lensend),inext,7700+isend,
3184      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3185      &   iprev,7700+irecv,FG_COMM,status,IERR)
3186 c        write (iout,*) "Gather PRECOMP21"
3187 c        call flush(iout)
3188         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3189      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3190      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3191      &   iprev,8800+irecv,FG_COMM,status,IERR)
3192 c        write (iout,*) "Gather PRECOMP22"
3193 c        call flush(iout)
3194         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3195      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3196      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3197      &   MPI_PRECOMP23(lenrecv),
3198      &   iprev,9900+irecv,FG_COMM,status,IERR)
3199 c        write (iout,*) "Gather PRECOMP23"
3200 c        call flush(iout)
3201         endif
3202         isend=irecv
3203         irecv=irecv-1
3204         if (irecv.lt.0) irecv=nfgtasks1-1
3205       enddo
3206 #endif
3207         time_gather=time_gather+MPI_Wtime()-time00
3208       endif
3209 #ifdef DEBUG
3210 c      if (fg_rank.eq.0) then
3211         write (iout,*) "Arrays UG and UGDER"
3212         do i=1,nres-1
3213           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3214      &     ((ug(l,k,i),l=1,2),k=1,2),
3215      &     ((ugder(l,k,i),l=1,2),k=1,2)
3216         enddo
3217         write (iout,*) "Arrays UG2 and UG2DER"
3218         do i=1,nres-1
3219           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3220      &     ((ug2(l,k,i),l=1,2),k=1,2),
3221      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3222         enddo
3223         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3224         do i=1,nres-1
3225           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3226      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3227      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3228         enddo
3229         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3230         do i=1,nres-1
3231           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3232      &     costab(i),sintab(i),costab2(i),sintab2(i)
3233         enddo
3234         write (iout,*) "Array MUDER"
3235         do i=1,nres-1
3236           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3237         enddo
3238 c      endif
3239 #endif
3240 #endif
3241 cd      do i=1,nres
3242 cd        iti = itortyp(itype(i))
3243 cd        write (iout,*) i
3244 cd        do j=1,2
3245 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3246 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3247 cd        enddo
3248 cd      enddo
3249       return
3250       end
3251 C--------------------------------------------------------------------------
3252       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3253 C
3254 C This subroutine calculates the average interaction energy and its gradient
3255 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3256 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3257 C The potential depends both on the distance of peptide-group centers and on
3258 C the orientation of the CA-CA virtual bonds.
3259 C
3260       implicit real*8 (a-h,o-z)
3261 #ifdef MPI
3262       include 'mpif.h'
3263 #endif
3264       include 'DIMENSIONS'
3265       include 'COMMON.CONTROL'
3266       include 'COMMON.SETUP'
3267       include 'COMMON.IOUNITS'
3268       include 'COMMON.GEO'
3269       include 'COMMON.VAR'
3270       include 'COMMON.LOCAL'
3271       include 'COMMON.CHAIN'
3272       include 'COMMON.DERIV'
3273       include 'COMMON.INTERACT'
3274       include 'COMMON.CONTACTS'
3275       include 'COMMON.TORSION'
3276       include 'COMMON.VECTORS'
3277       include 'COMMON.FFIELD'
3278       include 'COMMON.TIME1'
3279       include 'COMMON.SPLITELE'
3280       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3281      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3282       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3283      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3284       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3285      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3286      &    num_conti,j1,j2
3287 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3288 #ifdef MOMENT
3289       double precision scal_el /1.0d0/
3290 #else
3291       double precision scal_el /0.5d0/
3292 #endif
3293 C 12/13/98
3294 C 13-go grudnia roku pamietnego...
3295       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3296      &                   0.0d0,1.0d0,0.0d0,
3297      &                   0.0d0,0.0d0,1.0d0/
3298 cd      write(iout,*) 'In EELEC'
3299 cd      do i=1,nloctyp
3300 cd        write(iout,*) 'Type',i
3301 cd        write(iout,*) 'B1',B1(:,i)
3302 cd        write(iout,*) 'B2',B2(:,i)
3303 cd        write(iout,*) 'CC',CC(:,:,i)
3304 cd        write(iout,*) 'DD',DD(:,:,i)
3305 cd        write(iout,*) 'EE',EE(:,:,i)
3306 cd      enddo
3307 cd      call check_vecgrad
3308 cd      stop
3309       if (icheckgrad.eq.1) then
3310         do i=1,nres-1
3311           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3312           do k=1,3
3313             dc_norm(k,i)=dc(k,i)*fac
3314           enddo
3315 c          write (iout,*) 'i',i,' fac',fac
3316         enddo
3317       endif
3318       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3319      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3320      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3321 c        call vec_and_deriv
3322 #ifdef TIMING
3323         time01=MPI_Wtime()
3324 #endif
3325         call set_matrices
3326 #ifdef TIMING
3327         time_mat=time_mat+MPI_Wtime()-time01
3328 #endif
3329       endif
3330 cd      do i=1,nres-1
3331 cd        write (iout,*) 'i=',i
3332 cd        do k=1,3
3333 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3334 cd        enddo
3335 cd        do k=1,3
3336 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3337 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3338 cd        enddo
3339 cd      enddo
3340       t_eelecij=0.0d0
3341       ees=0.0D0
3342       evdw1=0.0D0
3343       eel_loc=0.0d0
3344       eello_turn3=0.0d0
3345       eello_turn4=0.0d0
3346       ind=0
3347       do i=1,nres
3348         num_cont_hb(i)=0
3349       enddo
3350 cd      print '(a)','Enter EELEC'
3351 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3352       do i=1,nres
3353         gel_loc_loc(i)=0.0d0
3354         gcorr_loc(i)=0.0d0
3355       enddo
3356 c
3357 c
3358 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3359 C
3360 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3361 C
3362 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3363       do i=iturn3_start,iturn3_end
3364 CAna        if (i.le.1) cycle
3365 C        write(iout,*) "tu jest i",i
3366         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3367 C changes suggested by Ana to avoid out of bounds
3368 CAna     & .or.((i+4).gt.nres)
3369 CAna     & .or.((i-1).le.0)
3370 C end of changes by Ana
3371      &  .or. itype(i+2).eq.ntyp1
3372      &  .or. itype(i+3).eq.ntyp1) cycle
3373 CAna        if(i.gt.1)then
3374 CAna          if(itype(i-1).eq.ntyp1)cycle
3375 CAna        end if
3376 CAna        if(i.LT.nres-3)then
3377 CAna          if (itype(i+4).eq.ntyp1) cycle
3378 CAna        end if
3379         dxi=dc(1,i)
3380         dyi=dc(2,i)
3381         dzi=dc(3,i)
3382         dx_normi=dc_norm(1,i)
3383         dy_normi=dc_norm(2,i)
3384         dz_normi=dc_norm(3,i)
3385         xmedi=c(1,i)+0.5d0*dxi
3386         ymedi=c(2,i)+0.5d0*dyi
3387         zmedi=c(3,i)+0.5d0*dzi
3388           xmedi=mod(xmedi,boxxsize)
3389           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3390           ymedi=mod(ymedi,boxysize)
3391           if (ymedi.lt.0) ymedi=ymedi+boxysize
3392           zmedi=mod(zmedi,boxzsize)
3393           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3394         num_conti=0
3395         call eelecij(i,i+2,ees,evdw1,eel_loc)
3396         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3397         num_cont_hb(i)=num_conti
3398       enddo
3399       do i=iturn4_start,iturn4_end
3400 cAna        if (i.le.1) cycle
3401         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3402 C changes suggested by Ana to avoid out of bounds
3403 cAna     & .or.((i+5).gt.nres)
3404 cAna     & .or.((i-1).le.0)
3405 C end of changes suggested by Ana
3406      &    .or. itype(i+3).eq.ntyp1
3407      &    .or. itype(i+4).eq.ntyp1
3408 cAna     &    .or. itype(i+5).eq.ntyp1
3409 cAna     &    .or. itype(i).eq.ntyp1
3410 cAna     &    .or. itype(i-1).eq.ntyp1
3411      &                             ) cycle
3412         dxi=dc(1,i)
3413         dyi=dc(2,i)
3414         dzi=dc(3,i)
3415         dx_normi=dc_norm(1,i)
3416         dy_normi=dc_norm(2,i)
3417         dz_normi=dc_norm(3,i)
3418         xmedi=c(1,i)+0.5d0*dxi
3419         ymedi=c(2,i)+0.5d0*dyi
3420         zmedi=c(3,i)+0.5d0*dzi
3421 C Return atom into box, boxxsize is size of box in x dimension
3422 c  194   continue
3423 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3424 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3425 C Condition for being inside the proper box
3426 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3427 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3428 c        go to 194
3429 c        endif
3430 c  195   continue
3431 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3432 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3433 C Condition for being inside the proper box
3434 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3435 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3436 c        go to 195
3437 c        endif
3438 c  196   continue
3439 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3440 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3441 C Condition for being inside the proper box
3442 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3443 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3444 c        go to 196
3445 c        endif
3446           xmedi=mod(xmedi,boxxsize)
3447           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3448           ymedi=mod(ymedi,boxysize)
3449           if (ymedi.lt.0) ymedi=ymedi+boxysize
3450           zmedi=mod(zmedi,boxzsize)
3451           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3452
3453         num_conti=num_cont_hb(i)
3454 c        write(iout,*) "JESTEM W PETLI"
3455         call eelecij(i,i+3,ees,evdw1,eel_loc)
3456         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3457      &   call eturn4(i,eello_turn4)
3458         num_cont_hb(i)=num_conti
3459       enddo   ! i
3460 C Loop over all neighbouring boxes
3461 C      do xshift=-1,1
3462 C      do yshift=-1,1
3463 C      do zshift=-1,1
3464 c
3465 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3466 c
3467       do i=iatel_s,iatel_e
3468 cAna        if (i.le.1) cycle
3469         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3470 C changes suggested by Ana to avoid out of bounds
3471 cAna     & .or.((i+2).gt.nres)
3472 cAna     & .or.((i-1).le.0)
3473 C end of changes by Ana
3474 cAna     &  .or. itype(i+2).eq.ntyp1
3475 cAna     &  .or. itype(i-1).eq.ntyp1
3476      &                ) cycle
3477         dxi=dc(1,i)
3478         dyi=dc(2,i)
3479         dzi=dc(3,i)
3480         dx_normi=dc_norm(1,i)
3481         dy_normi=dc_norm(2,i)
3482         dz_normi=dc_norm(3,i)
3483         xmedi=c(1,i)+0.5d0*dxi
3484         ymedi=c(2,i)+0.5d0*dyi
3485         zmedi=c(3,i)+0.5d0*dzi
3486           xmedi=mod(xmedi,boxxsize)
3487           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3488           ymedi=mod(ymedi,boxysize)
3489           if (ymedi.lt.0) ymedi=ymedi+boxysize
3490           zmedi=mod(zmedi,boxzsize)
3491           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3492 C          xmedi=xmedi+xshift*boxxsize
3493 C          ymedi=ymedi+yshift*boxysize
3494 C          zmedi=zmedi+zshift*boxzsize
3495
3496 C Return tom into box, boxxsize is size of box in x dimension
3497 c  164   continue
3498 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3499 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3500 C Condition for being inside the proper box
3501 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3502 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3503 c        go to 164
3504 c        endif
3505 c  165   continue
3506 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3507 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3508 C Condition for being inside the proper box
3509 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3510 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3511 c        go to 165
3512 c        endif
3513 c  166   continue
3514 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3515 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3516 cC Condition for being inside the proper box
3517 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3518 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3519 c        go to 166
3520 c        endif
3521
3522 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3523         num_conti=num_cont_hb(i)
3524         do j=ielstart(i),ielend(i)
3525 C          write (iout,*) i,j
3526 cAna         if (j.le.1) cycle
3527           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3528 C changes suggested by Ana to avoid out of bounds
3529 cAna     & .or.((j+2).gt.nres)
3530 cAna     & .or.((j-1).le.0)
3531 C end of changes by Ana
3532 cAna     & .or.itype(j+2).eq.ntyp1
3533 cAna     & .or.itype(j-1).eq.ntyp1
3534      &) cycle
3535           call eelecij(i,j,ees,evdw1,eel_loc)
3536         enddo ! j
3537         num_cont_hb(i)=num_conti
3538       enddo   ! i
3539 C     enddo   ! zshift
3540 C      enddo   ! yshift
3541 C      enddo   ! xshift
3542
3543 c      write (iout,*) "Number of loop steps in EELEC:",ind
3544 cd      do i=1,nres
3545 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3546 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3547 cd      enddo
3548 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3549 ccc      eel_loc=eel_loc+eello_turn3
3550 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3551       return
3552       end
3553 C-------------------------------------------------------------------------------
3554       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557 #ifdef MPI
3558       include "mpif.h"
3559 #endif
3560       include 'COMMON.CONTROL'
3561       include 'COMMON.IOUNITS'
3562       include 'COMMON.GEO'
3563       include 'COMMON.VAR'
3564       include 'COMMON.LOCAL'
3565       include 'COMMON.CHAIN'
3566       include 'COMMON.DERIV'
3567       include 'COMMON.INTERACT'
3568       include 'COMMON.CONTACTS'
3569       include 'COMMON.TORSION'
3570       include 'COMMON.VECTORS'
3571       include 'COMMON.FFIELD'
3572       include 'COMMON.TIME1'
3573       include 'COMMON.SPLITELE'
3574       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3575      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3576       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3577      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3578      &    gmuij2(4),gmuji2(4)
3579       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3580      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3581      &    num_conti,j1,j2
3582 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3583 #ifdef MOMENT
3584       double precision scal_el /1.0d0/
3585 #else
3586       double precision scal_el /0.5d0/
3587 #endif
3588 C 12/13/98
3589 C 13-go grudnia roku pamietnego...
3590       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3591      &                   0.0d0,1.0d0,0.0d0,
3592      &                   0.0d0,0.0d0,1.0d0/
3593 c          time00=MPI_Wtime()
3594 cd      write (iout,*) "eelecij",i,j
3595 c          ind=ind+1
3596           iteli=itel(i)
3597           itelj=itel(j)
3598           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3599           aaa=app(iteli,itelj)
3600           bbb=bpp(iteli,itelj)
3601           ael6i=ael6(iteli,itelj)
3602           ael3i=ael3(iteli,itelj)
3603           dxj=dc(1,j)
3604           dyj=dc(2,j)
3605           dzj=dc(3,j)
3606           dx_normj=dc_norm(1,j)
3607           dy_normj=dc_norm(2,j)
3608           dz_normj=dc_norm(3,j)
3609 C          xj=c(1,j)+0.5D0*dxj-xmedi
3610 C          yj=c(2,j)+0.5D0*dyj-ymedi
3611 C          zj=c(3,j)+0.5D0*dzj-zmedi
3612           xj=c(1,j)+0.5D0*dxj
3613           yj=c(2,j)+0.5D0*dyj
3614           zj=c(3,j)+0.5D0*dzj
3615           xj=mod(xj,boxxsize)
3616           if (xj.lt.0) xj=xj+boxxsize
3617           yj=mod(yj,boxysize)
3618           if (yj.lt.0) yj=yj+boxysize
3619           zj=mod(zj,boxzsize)
3620           if (zj.lt.0) zj=zj+boxzsize
3621           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3622       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3623       xj_safe=xj
3624       yj_safe=yj
3625       zj_safe=zj
3626       isubchap=0
3627       do xshift=-1,1
3628       do yshift=-1,1
3629       do zshift=-1,1
3630           xj=xj_safe+xshift*boxxsize
3631           yj=yj_safe+yshift*boxysize
3632           zj=zj_safe+zshift*boxzsize
3633           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3634           if(dist_temp.lt.dist_init) then
3635             dist_init=dist_temp
3636             xj_temp=xj
3637             yj_temp=yj
3638             zj_temp=zj
3639             isubchap=1
3640           endif
3641        enddo
3642        enddo
3643        enddo
3644        if (isubchap.eq.1) then
3645           xj=xj_temp-xmedi
3646           yj=yj_temp-ymedi
3647           zj=zj_temp-zmedi
3648        else
3649           xj=xj_safe-xmedi
3650           yj=yj_safe-ymedi
3651           zj=zj_safe-zmedi
3652        endif
3653 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3654 c  174   continue
3655 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3656 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3657 C Condition for being inside the proper box
3658 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3659 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3660 c        go to 174
3661 c        endif
3662 c  175   continue
3663 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3664 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3665 C Condition for being inside the proper box
3666 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3667 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3668 c        go to 175
3669 c        endif
3670 c  176   continue
3671 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3672 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3673 C Condition for being inside the proper box
3674 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3675 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3676 c        go to 176
3677 c        endif
3678 C        endif !endPBC condintion
3679 C        xj=xj-xmedi
3680 C        yj=yj-ymedi
3681 C        zj=zj-zmedi
3682           rij=xj*xj+yj*yj+zj*zj
3683
3684             sss=sscale(sqrt(rij))
3685             sssgrad=sscagrad(sqrt(rij))
3686 c            if (sss.gt.0.0d0) then
3687           rrmij=1.0D0/rij
3688           rij=dsqrt(rij)
3689           rmij=1.0D0/rij
3690           r3ij=rrmij*rmij
3691           r6ij=r3ij*r3ij
3692           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3693           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3694           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3695           fac=cosa-3.0D0*cosb*cosg
3696           ev1=aaa*r6ij*r6ij
3697 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3698           if (j.eq.i+2) ev1=scal_el*ev1
3699           ev2=bbb*r6ij
3700           fac3=ael6i*r6ij
3701           fac4=ael3i*r3ij
3702           evdwij=(ev1+ev2)
3703           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3704           el2=fac4*fac
3705 C MARYSIA
3706           eesij=(el1+el2)
3707 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3708           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3709           ees=ees+eesij
3710           evdw1=evdw1+evdwij*sss
3711 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3712 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3713 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3714 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3715
3716           if (energy_dec) then
3717               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3718      &'evdw1',i,j,evdwij
3719 c     &,iteli,itelj,aaa,evdw1
3720               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3721           endif
3722
3723 C
3724 C Calculate contributions to the Cartesian gradient.
3725 C
3726 #ifdef SPLITELE
3727           facvdw=-6*rrmij*(ev1+evdwij)*sss
3728           facel=-3*rrmij*(el1+eesij)
3729           fac1=fac
3730           erij(1)=xj*rmij
3731           erij(2)=yj*rmij
3732           erij(3)=zj*rmij
3733 *
3734 * Radial derivatives. First process both termini of the fragment (i,j)
3735 *
3736           ggg(1)=facel*xj
3737           ggg(2)=facel*yj
3738           ggg(3)=facel*zj
3739 c          do k=1,3
3740 c            ghalf=0.5D0*ggg(k)
3741 c            gelc(k,i)=gelc(k,i)+ghalf
3742 c            gelc(k,j)=gelc(k,j)+ghalf
3743 c          enddo
3744 c 9/28/08 AL Gradient compotents will be summed only at the end
3745           do k=1,3
3746             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3747             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3748           enddo
3749 *
3750 * Loop over residues i+1 thru j-1.
3751 *
3752 cgrad          do k=i+1,j-1
3753 cgrad            do l=1,3
3754 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3755 cgrad            enddo
3756 cgrad          enddo
3757           if (sss.gt.0.0) then
3758           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3759           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3760           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3761           else
3762           ggg(1)=0.0
3763           ggg(2)=0.0
3764           ggg(3)=0.0
3765           endif
3766 c          do k=1,3
3767 c            ghalf=0.5D0*ggg(k)
3768 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3769 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3770 c          enddo
3771 c 9/28/08 AL Gradient compotents will be summed only at the end
3772           do k=1,3
3773             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3774             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3775           enddo
3776 *
3777 * Loop over residues i+1 thru j-1.
3778 *
3779 cgrad          do k=i+1,j-1
3780 cgrad            do l=1,3
3781 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3782 cgrad            enddo
3783 cgrad          enddo
3784 #else
3785 C MARYSIA
3786           facvdw=(ev1+evdwij)*sss
3787           facel=(el1+eesij)
3788           fac1=fac
3789           fac=-3*rrmij*(facvdw+facvdw+facel)
3790           erij(1)=xj*rmij
3791           erij(2)=yj*rmij
3792           erij(3)=zj*rmij
3793 *
3794 * Radial derivatives. First process both termini of the fragment (i,j)
3795 *
3796           ggg(1)=fac*xj
3797           ggg(2)=fac*yj
3798           ggg(3)=fac*zj
3799 c          do k=1,3
3800 c            ghalf=0.5D0*ggg(k)
3801 c            gelc(k,i)=gelc(k,i)+ghalf
3802 c            gelc(k,j)=gelc(k,j)+ghalf
3803 c          enddo
3804 c 9/28/08 AL Gradient compotents will be summed only at the end
3805           do k=1,3
3806             gelc_long(k,j)=gelc(k,j)+ggg(k)
3807             gelc_long(k,i)=gelc(k,i)-ggg(k)
3808           enddo
3809 *
3810 * Loop over residues i+1 thru j-1.
3811 *
3812 cgrad          do k=i+1,j-1
3813 cgrad            do l=1,3
3814 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3815 cgrad            enddo
3816 cgrad          enddo
3817 c 9/28/08 AL Gradient compotents will be summed only at the end
3818           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3819           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3820           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3821           do k=1,3
3822             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3823             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3824           enddo
3825 #endif
3826 *
3827 * Angular part
3828 *
3829           ecosa=2.0D0*fac3*fac1+fac4
3830           fac4=-3.0D0*fac4
3831           fac3=-6.0D0*fac3
3832           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3833           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
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 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3839 cd   &          (dcosg(k),k=1,3)
3840           do k=1,3
3841             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3842           enddo
3843 c          do k=1,3
3844 c            ghalf=0.5D0*ggg(k)
3845 c            gelc(k,i)=gelc(k,i)+ghalf
3846 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3847 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3848 c            gelc(k,j)=gelc(k,j)+ghalf
3849 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3850 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3851 c          enddo
3852 cgrad          do k=i+1,j-1
3853 cgrad            do l=1,3
3854 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3855 cgrad            enddo
3856 cgrad          enddo
3857           do k=1,3
3858             gelc(k,i)=gelc(k,i)
3859      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3860      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3861             gelc(k,j)=gelc(k,j)
3862      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3863      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3864             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3865             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3866           enddo
3867 C MARYSIA
3868 c          endif !sscale
3869           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3870      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3871      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3872 C
3873 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3874 C   energy of a peptide unit is assumed in the form of a second-order
3875 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3876 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3877 C   are computed for EVERY pair of non-contiguous peptide groups.
3878 C
3879
3880           if (j.lt.nres-1) then
3881             j1=j+1
3882             j2=j-1
3883           else
3884             j1=j-1
3885             j2=j-2
3886           endif
3887           kkk=0
3888           lll=0
3889           do k=1,2
3890             do l=1,2
3891               kkk=kkk+1
3892               muij(kkk)=mu(k,i)*mu(l,j)
3893 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3894 #ifdef NEWCORR
3895              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3896 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3897              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3898              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3899 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3900              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3901 #endif
3902             enddo
3903           enddo
3904 cd         write (iout,*) 'EELEC: i',i,' j',j
3905 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3906 cd          write(iout,*) 'muij',muij
3907           ury=scalar(uy(1,i),erij)
3908           urz=scalar(uz(1,i),erij)
3909           vry=scalar(uy(1,j),erij)
3910           vrz=scalar(uz(1,j),erij)
3911           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3912           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3913           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3914           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3915           fac=dsqrt(-ael6i)*r3ij
3916           a22=a22*fac
3917           a23=a23*fac
3918           a32=a32*fac
3919           a33=a33*fac
3920 cd          write (iout,'(4i5,4f10.5)')
3921 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3922 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3923 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3924 cd     &      uy(:,j),uz(:,j)
3925 cd          write (iout,'(4f10.5)')
3926 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3927 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3928 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3929 cd           write (iout,'(9f10.5/)')
3930 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3931 C Derivatives of the elements of A in virtual-bond vectors
3932           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3933           do k=1,3
3934             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3935             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3936             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3937             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3938             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3939             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3940             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3941             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3942             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3943             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3944             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3945             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3946           enddo
3947 C Compute radial contributions to the gradient
3948           facr=-3.0d0*rrmij
3949           a22der=a22*facr
3950           a23der=a23*facr
3951           a32der=a32*facr
3952           a33der=a33*facr
3953           agg(1,1)=a22der*xj
3954           agg(2,1)=a22der*yj
3955           agg(3,1)=a22der*zj
3956           agg(1,2)=a23der*xj
3957           agg(2,2)=a23der*yj
3958           agg(3,2)=a23der*zj
3959           agg(1,3)=a32der*xj
3960           agg(2,3)=a32der*yj
3961           agg(3,3)=a32der*zj
3962           agg(1,4)=a33der*xj
3963           agg(2,4)=a33der*yj
3964           agg(3,4)=a33der*zj
3965 C Add the contributions coming from er
3966           fac3=-3.0d0*fac
3967           do k=1,3
3968             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3969             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3970             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3971             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3972           enddo
3973           do k=1,3
3974 C Derivatives in DC(i)
3975 cgrad            ghalf1=0.5d0*agg(k,1)
3976 cgrad            ghalf2=0.5d0*agg(k,2)
3977 cgrad            ghalf3=0.5d0*agg(k,3)
3978 cgrad            ghalf4=0.5d0*agg(k,4)
3979             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3980      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3981             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3982      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3983             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3984      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3985             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3986      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3987 C Derivatives in DC(i+1)
3988             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3989      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3990             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3991      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3992             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3993      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3994             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3995      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3996 C Derivatives in DC(j)
3997             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3998      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3999             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4000      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4001             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4002      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4003             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4004      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4005 C Derivatives in DC(j+1) or DC(nres-1)
4006             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4007      &      -3.0d0*vryg(k,3)*ury)
4008             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4009      &      -3.0d0*vrzg(k,3)*ury)
4010             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4011      &      -3.0d0*vryg(k,3)*urz)
4012             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4013      &      -3.0d0*vrzg(k,3)*urz)
4014 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4015 cgrad              do l=1,4
4016 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4017 cgrad              enddo
4018 cgrad            endif
4019           enddo
4020           acipa(1,1)=a22
4021           acipa(1,2)=a23
4022           acipa(2,1)=a32
4023           acipa(2,2)=a33
4024           a22=-a22
4025           a23=-a23
4026           do l=1,2
4027             do k=1,3
4028               agg(k,l)=-agg(k,l)
4029               aggi(k,l)=-aggi(k,l)
4030               aggi1(k,l)=-aggi1(k,l)
4031               aggj(k,l)=-aggj(k,l)
4032               aggj1(k,l)=-aggj1(k,l)
4033             enddo
4034           enddo
4035           if (j.lt.nres-1) then
4036             a22=-a22
4037             a32=-a32
4038             do l=1,3,2
4039               do k=1,3
4040                 agg(k,l)=-agg(k,l)
4041                 aggi(k,l)=-aggi(k,l)
4042                 aggi1(k,l)=-aggi1(k,l)
4043                 aggj(k,l)=-aggj(k,l)
4044                 aggj1(k,l)=-aggj1(k,l)
4045               enddo
4046             enddo
4047           else
4048             a22=-a22
4049             a23=-a23
4050             a32=-a32
4051             a33=-a33
4052             do l=1,4
4053               do k=1,3
4054                 agg(k,l)=-agg(k,l)
4055                 aggi(k,l)=-aggi(k,l)
4056                 aggi1(k,l)=-aggi1(k,l)
4057                 aggj(k,l)=-aggj(k,l)
4058                 aggj1(k,l)=-aggj1(k,l)
4059               enddo
4060             enddo
4061           endif
4062           ENDIF ! WCORR
4063           IF (wel_loc.gt.0.0d0) THEN
4064 C Contribution to the local-electrostatic energy coming from the i-j pair
4065           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4066      &     +a33*muij(4)
4067 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4068 c     &                     ' eel_loc_ij',eel_loc_ij
4069 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4070 C Calculate patrial derivative for theta angle
4071 #ifdef NEWCORR
4072          geel_loc_ij=a22*gmuij1(1)
4073      &     +a23*gmuij1(2)
4074      &     +a32*gmuij1(3)
4075      &     +a33*gmuij1(4)
4076 c         write(iout,*) "derivative over thatai"
4077 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4078 c     &   a33*gmuij1(4)
4079          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4080      &      geel_loc_ij*wel_loc
4081 c         write(iout,*) "derivative over thatai-1"
4082 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4083 c     &   a33*gmuij2(4)
4084          geel_loc_ij=
4085      &     a22*gmuij2(1)
4086      &     +a23*gmuij2(2)
4087      &     +a32*gmuij2(3)
4088      &     +a33*gmuij2(4)
4089          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4090      &      geel_loc_ij*wel_loc
4091 c  Derivative over j residue
4092          geel_loc_ji=a22*gmuji1(1)
4093      &     +a23*gmuji1(2)
4094      &     +a32*gmuji1(3)
4095      &     +a33*gmuji1(4)
4096 c         write(iout,*) "derivative over thataj"
4097 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4098 c     &   a33*gmuji1(4)
4099
4100         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4101      &      geel_loc_ji*wel_loc
4102          geel_loc_ji=
4103      &     +a22*gmuji2(1)
4104      &     +a23*gmuji2(2)
4105      &     +a32*gmuji2(3)
4106      &     +a33*gmuji2(4)
4107 c         write(iout,*) "derivative over thataj-1"
4108 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4109 c     &   a33*gmuji2(4)
4110          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4111      &      geel_loc_ji*wel_loc
4112 #endif
4113 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4114
4115           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4116      &            'eelloc',i,j,eel_loc_ij
4117 c           if (eel_loc_ij.ne.0)
4118 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4119 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4120
4121           eel_loc=eel_loc+eel_loc_ij
4122 C Partial derivatives in virtual-bond dihedral angles gamma
4123           if (i.gt.1)
4124      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4125      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4126      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4127           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4128      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4129      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4130 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4131           do l=1,3
4132             ggg(l)=agg(l,1)*muij(1)+
4133      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4134             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4135             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4136 cgrad            ghalf=0.5d0*ggg(l)
4137 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4138 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4139           enddo
4140 cgrad          do k=i+1,j2
4141 cgrad            do l=1,3
4142 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4143 cgrad            enddo
4144 cgrad          enddo
4145 C Remaining derivatives of eello
4146           do l=1,3
4147             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4148      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4149             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4150      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4151             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4152      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4153             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4154      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4155           enddo
4156           ENDIF
4157 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4158 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4159           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4160      &       .and. num_conti.le.maxconts) then
4161 c            write (iout,*) i,j," entered corr"
4162 C
4163 C Calculate the contact function. The ith column of the array JCONT will
4164 C contain the numbers of atoms that make contacts with the atom I (of numbers
4165 C greater than I). The arrays FACONT and GACONT will contain the values of
4166 C the contact function and its derivative.
4167 c           r0ij=1.02D0*rpp(iteli,itelj)
4168 c           r0ij=1.11D0*rpp(iteli,itelj)
4169             r0ij=2.20D0*rpp(iteli,itelj)
4170 c           r0ij=1.55D0*rpp(iteli,itelj)
4171             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4172             if (fcont.gt.0.0D0) then
4173               num_conti=num_conti+1
4174               if (num_conti.gt.maxconts) then
4175                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4176      &                         ' will skip next contacts for this conf.'
4177               else
4178                 jcont_hb(num_conti,i)=j
4179 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4180 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4181                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4182      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4183 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4184 C  terms.
4185                 d_cont(num_conti,i)=rij
4186 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4187 C     --- Electrostatic-interaction matrix ---
4188                 a_chuj(1,1,num_conti,i)=a22
4189                 a_chuj(1,2,num_conti,i)=a23
4190                 a_chuj(2,1,num_conti,i)=a32
4191                 a_chuj(2,2,num_conti,i)=a33
4192 C     --- Gradient of rij
4193                 do kkk=1,3
4194                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4195                 enddo
4196                 kkll=0
4197                 do k=1,2
4198                   do l=1,2
4199                     kkll=kkll+1
4200                     do m=1,3
4201                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4202                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4203                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4204                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4205                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4206                     enddo
4207                   enddo
4208                 enddo
4209                 ENDIF
4210                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4211 C Calculate contact energies
4212                 cosa4=4.0D0*cosa
4213                 wij=cosa-3.0D0*cosb*cosg
4214                 cosbg1=cosb+cosg
4215                 cosbg2=cosb-cosg
4216 c               fac3=dsqrt(-ael6i)/r0ij**3
4217                 fac3=dsqrt(-ael6i)*r3ij
4218 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4219                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4220                 if (ees0tmp.gt.0) then
4221                   ees0pij=dsqrt(ees0tmp)
4222                 else
4223                   ees0pij=0
4224                 endif
4225 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4226                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4227                 if (ees0tmp.gt.0) then
4228                   ees0mij=dsqrt(ees0tmp)
4229                 else
4230                   ees0mij=0
4231                 endif
4232 c               ees0mij=0.0D0
4233                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4234                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4235 C Diagnostics. Comment out or remove after debugging!
4236 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4237 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4238 c               ees0m(num_conti,i)=0.0D0
4239 C End diagnostics.
4240 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4241 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4242 C Angular derivatives of the contact function
4243                 ees0pij1=fac3/ees0pij
4244                 ees0mij1=fac3/ees0mij
4245                 fac3p=-3.0D0*fac3*rrmij
4246                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4247                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4248 c               ees0mij1=0.0D0
4249                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4250                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4251                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4252                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4253                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4254                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4255                 ecosap=ecosa1+ecosa2
4256                 ecosbp=ecosb1+ecosb2
4257                 ecosgp=ecosg1+ecosg2
4258                 ecosam=ecosa1-ecosa2
4259                 ecosbm=ecosb1-ecosb2
4260                 ecosgm=ecosg1-ecosg2
4261 C Diagnostics
4262 c               ecosap=ecosa1
4263 c               ecosbp=ecosb1
4264 c               ecosgp=ecosg1
4265 c               ecosam=0.0D0
4266 c               ecosbm=0.0D0
4267 c               ecosgm=0.0D0
4268 C End diagnostics
4269                 facont_hb(num_conti,i)=fcont
4270                 fprimcont=fprimcont/rij
4271 cd              facont_hb(num_conti,i)=1.0D0
4272 C Following line is for diagnostics.
4273 cd              fprimcont=0.0D0
4274                 do k=1,3
4275                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4276                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4277                 enddo
4278                 do k=1,3
4279                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4280                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4281                 enddo
4282                 gggp(1)=gggp(1)+ees0pijp*xj
4283                 gggp(2)=gggp(2)+ees0pijp*yj
4284                 gggp(3)=gggp(3)+ees0pijp*zj
4285                 gggm(1)=gggm(1)+ees0mijp*xj
4286                 gggm(2)=gggm(2)+ees0mijp*yj
4287                 gggm(3)=gggm(3)+ees0mijp*zj
4288 C Derivatives due to the contact function
4289                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4290                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4291                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4292                 do k=1,3
4293 c
4294 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4295 c          following the change of gradient-summation algorithm.
4296 c
4297 cgrad                  ghalfp=0.5D0*gggp(k)
4298 cgrad                  ghalfm=0.5D0*gggm(k)
4299                   gacontp_hb1(k,num_conti,i)=!ghalfp
4300      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4301      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4302                   gacontp_hb2(k,num_conti,i)=!ghalfp
4303      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4304      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4305                   gacontp_hb3(k,num_conti,i)=gggp(k)
4306                   gacontm_hb1(k,num_conti,i)=!ghalfm
4307      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4308      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4309                   gacontm_hb2(k,num_conti,i)=!ghalfm
4310      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4311      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4312                   gacontm_hb3(k,num_conti,i)=gggm(k)
4313                 enddo
4314 C Diagnostics. Comment out or remove after debugging!
4315 cdiag           do k=1,3
4316 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4317 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4318 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4319 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4320 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4321 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4322 cdiag           enddo
4323               ENDIF ! wcorr
4324               endif  ! num_conti.le.maxconts
4325             endif  ! fcont.gt.0
4326           endif    ! j.gt.i+1
4327           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4328             do k=1,4
4329               do l=1,3
4330                 ghalf=0.5d0*agg(l,k)
4331                 aggi(l,k)=aggi(l,k)+ghalf
4332                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4333                 aggj(l,k)=aggj(l,k)+ghalf
4334               enddo
4335             enddo
4336             if (j.eq.nres-1 .and. i.lt.j-2) then
4337               do k=1,4
4338                 do l=1,3
4339                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4340                 enddo
4341               enddo
4342             endif
4343           endif
4344 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4345       return
4346       end
4347 C-----------------------------------------------------------------------------
4348       subroutine eturn3(i,eello_turn3)
4349 C Third- and fourth-order contributions from turns
4350       implicit real*8 (a-h,o-z)
4351       include 'DIMENSIONS'
4352       include 'COMMON.IOUNITS'
4353       include 'COMMON.GEO'
4354       include 'COMMON.VAR'
4355       include 'COMMON.LOCAL'
4356       include 'COMMON.CHAIN'
4357       include 'COMMON.DERIV'
4358       include 'COMMON.INTERACT'
4359       include 'COMMON.CONTACTS'
4360       include 'COMMON.TORSION'
4361       include 'COMMON.VECTORS'
4362       include 'COMMON.FFIELD'
4363       include 'COMMON.CONTROL'
4364       dimension ggg(3)
4365       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4366      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4367      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4368      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4369      &  auxgmat2(2,2),auxgmatt2(2,2)
4370       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4371      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4372       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4373      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4374      &    num_conti,j1,j2
4375       j=i+2
4376 c      write (iout,*) "eturn3",i,j,j1,j2
4377       a_temp(1,1)=a22
4378       a_temp(1,2)=a23
4379       a_temp(2,1)=a32
4380       a_temp(2,2)=a33
4381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4382 C
4383 C               Third-order contributions
4384 C
4385 C                 (i+2)o----(i+3)
4386 C                      | |
4387 C                      | |
4388 C                 (i+1)o----i
4389 C
4390 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4391 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4392         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4393 c auxalary matices for theta gradient
4394 c auxalary matrix for i+1 and constant i+2
4395         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4396 c auxalary matrix for i+2 and constant i+1
4397         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4398         call transpose2(auxmat(1,1),auxmat1(1,1))
4399         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4400         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4401         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4402         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4403         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4404         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4405 C Derivatives in theta
4406         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4407      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4408         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4409      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4410
4411         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4412      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4413 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4414 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4415 cd     &    ' eello_turn3_num',4*eello_turn3_num
4416 C Derivatives in gamma(i)
4417         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4418         call transpose2(auxmat2(1,1),auxmat3(1,1))
4419         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4420         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4421 C Derivatives in gamma(i+1)
4422         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4423         call transpose2(auxmat2(1,1),auxmat3(1,1))
4424         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4425         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4426      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4427 C Cartesian derivatives
4428 !DIR$ UNROLL(0)
4429         do l=1,3
4430 c            ghalf1=0.5d0*agg(l,1)
4431 c            ghalf2=0.5d0*agg(l,2)
4432 c            ghalf3=0.5d0*agg(l,3)
4433 c            ghalf4=0.5d0*agg(l,4)
4434           a_temp(1,1)=aggi(l,1)!+ghalf1
4435           a_temp(1,2)=aggi(l,2)!+ghalf2
4436           a_temp(2,1)=aggi(l,3)!+ghalf3
4437           a_temp(2,2)=aggi(l,4)!+ghalf4
4438           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4439           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4440      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4441           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4442           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4443           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4444           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4445           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4446           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4447      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4448           a_temp(1,1)=aggj(l,1)!+ghalf1
4449           a_temp(1,2)=aggj(l,2)!+ghalf2
4450           a_temp(2,1)=aggj(l,3)!+ghalf3
4451           a_temp(2,2)=aggj(l,4)!+ghalf4
4452           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4453           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4454      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4455           a_temp(1,1)=aggj1(l,1)
4456           a_temp(1,2)=aggj1(l,2)
4457           a_temp(2,1)=aggj1(l,3)
4458           a_temp(2,2)=aggj1(l,4)
4459           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4460           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4461      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4462         enddo
4463       return
4464       end
4465 C-------------------------------------------------------------------------------
4466       subroutine eturn4(i,eello_turn4)
4467 C Third- and fourth-order contributions from turns
4468       implicit real*8 (a-h,o-z)
4469       include 'DIMENSIONS'
4470       include 'COMMON.IOUNITS'
4471       include 'COMMON.GEO'
4472       include 'COMMON.VAR'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.CHAIN'
4475       include 'COMMON.DERIV'
4476       include 'COMMON.INTERACT'
4477       include 'COMMON.CONTACTS'
4478       include 'COMMON.TORSION'
4479       include 'COMMON.VECTORS'
4480       include 'COMMON.FFIELD'
4481       include 'COMMON.CONTROL'
4482       dimension ggg(3)
4483       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4484      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4485      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4486      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4487      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4488      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4489      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4490       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4491      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4492       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4493      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4494      &    num_conti,j1,j2
4495       j=i+3
4496 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4497 C
4498 C               Fourth-order contributions
4499 C
4500 C                 (i+3)o----(i+4)
4501 C                     /  |
4502 C               (i+2)o   |
4503 C                     \  |
4504 C                 (i+1)o----i
4505 C
4506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4507 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4508 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4509 c        write(iout,*)"WCHODZE W PROGRAM"
4510         a_temp(1,1)=a22
4511         a_temp(1,2)=a23
4512         a_temp(2,1)=a32
4513         a_temp(2,2)=a33
4514         iti1=itortyp(itype(i+1))
4515         iti2=itortyp(itype(i+2))
4516         iti3=itortyp(itype(i+3))
4517 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4518         call transpose2(EUg(1,1,i+1),e1t(1,1))
4519         call transpose2(Eug(1,1,i+2),e2t(1,1))
4520         call transpose2(Eug(1,1,i+3),e3t(1,1))
4521 C Ematrix derivative in theta
4522         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4523         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4524         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4525         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4526 c       eta1 in derivative theta
4527         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4528         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4529 c       auxgvec is derivative of Ub2 so i+3 theta
4530         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4531 c       auxalary matrix of E i+1
4532         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4533 c        s1=0.0
4534 c        gs1=0.0
4535         s1=scalar2(b1(1,i+2),auxvec(1))
4536 c derivative of theta i+2 with constant i+3
4537         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4538 c derivative of theta i+2 with constant i+2
4539         gs32=scalar2(b1(1,i+2),auxgvec(1))
4540 c derivative of E matix in theta of i+1
4541         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4542
4543         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4544 c       ea31 in derivative theta
4545         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4546         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4547 c auxilary matrix auxgvec of Ub2 with constant E matirx
4548         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4549 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4550         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4551
4552 c        s2=0.0
4553 c        gs2=0.0
4554         s2=scalar2(b1(1,i+1),auxvec(1))
4555 c derivative of theta i+1 with constant i+3
4556         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4557 c derivative of theta i+2 with constant i+1
4558         gs21=scalar2(b1(1,i+1),auxgvec(1))
4559 c derivative of theta i+3 with constant i+1
4560         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4561 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4562 c     &  gtb1(1,i+1)
4563         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4564 c two derivatives over diffetent matrices
4565 c gtae3e2 is derivative over i+3
4566         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4567 c ae3gte2 is derivative over i+2
4568         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4569         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4570 c three possible derivative over theta E matices
4571 c i+1
4572         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4573 c i+2
4574         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4575 c i+3
4576         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4577         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4578
4579         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4580         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4581         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4582
4583         eello_turn4=eello_turn4-(s1+s2+s3)
4584 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4585 c        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4586 c     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4587 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4588 cd     &    ' eello_turn4_num',8*eello_turn4_num
4589 #ifdef NEWCORR
4590         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4591      &                  -(gs13+gsE13+gsEE1)*wturn4
4592         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4593      &                    -(gs23+gs21+gsEE2)*wturn4
4594         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4595      &                    -(gs32+gsE31+gsEE3)*wturn4
4596 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4597 c     &   gs2
4598 #endif
4599         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4600      &      'eturn4',i,j,-(s1+s2+s3)
4601 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4602 c     &    ' eello_turn4_num',8*eello_turn4_num
4603 C Derivatives in gamma(i)
4604         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4605         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4606         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4607         s1=scalar2(b1(1,i+2),auxvec(1))
4608         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4609         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4610         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4611 C Derivatives in gamma(i+1)
4612         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4613         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4614         s2=scalar2(b1(1,i+1),auxvec(1))
4615         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4616         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4617         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4618         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4619 C Derivatives in gamma(i+2)
4620         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4621         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4622         s1=scalar2(b1(1,i+2),auxvec(1))
4623         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4624         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4625         s2=scalar2(b1(1,i+1),auxvec(1))
4626         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4627         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4628         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4629         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4630 C Cartesian derivatives
4631 C Derivatives of this turn contributions in DC(i+2)
4632         if (j.lt.nres-1) then
4633           do l=1,3
4634             a_temp(1,1)=agg(l,1)
4635             a_temp(1,2)=agg(l,2)
4636             a_temp(2,1)=agg(l,3)
4637             a_temp(2,2)=agg(l,4)
4638             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4639             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4640             s1=scalar2(b1(1,i+2),auxvec(1))
4641             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4642             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4643             s2=scalar2(b1(1,i+1),auxvec(1))
4644             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4645             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4646             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4647             ggg(l)=-(s1+s2+s3)
4648             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4649           enddo
4650         endif
4651 C Remaining derivatives of this turn contribution
4652         do l=1,3
4653           a_temp(1,1)=aggi(l,1)
4654           a_temp(1,2)=aggi(l,2)
4655           a_temp(2,1)=aggi(l,3)
4656           a_temp(2,2)=aggi(l,4)
4657           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4658           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4659           s1=scalar2(b1(1,i+2),auxvec(1))
4660           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4661           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4662           s2=scalar2(b1(1,i+1),auxvec(1))
4663           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4664           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4665           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4666           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4667           a_temp(1,1)=aggi1(l,1)
4668           a_temp(1,2)=aggi1(l,2)
4669           a_temp(2,1)=aggi1(l,3)
4670           a_temp(2,2)=aggi1(l,4)
4671           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4672           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4673           s1=scalar2(b1(1,i+2),auxvec(1))
4674           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4675           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4676           s2=scalar2(b1(1,i+1),auxvec(1))
4677           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4678           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4679           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4680           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4681           a_temp(1,1)=aggj(l,1)
4682           a_temp(1,2)=aggj(l,2)
4683           a_temp(2,1)=aggj(l,3)
4684           a_temp(2,2)=aggj(l,4)
4685           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4686           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4687           s1=scalar2(b1(1,i+2),auxvec(1))
4688           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4689           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4690           s2=scalar2(b1(1,i+1),auxvec(1))
4691           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4692           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4693           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4694           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4695           a_temp(1,1)=aggj1(l,1)
4696           a_temp(1,2)=aggj1(l,2)
4697           a_temp(2,1)=aggj1(l,3)
4698           a_temp(2,2)=aggj1(l,4)
4699           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4700           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4701           s1=scalar2(b1(1,i+2),auxvec(1))
4702           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4703           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4704           s2=scalar2(b1(1,i+1),auxvec(1))
4705           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4706           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4707           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4708 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4709           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4710         enddo
4711       return
4712       end
4713 C-----------------------------------------------------------------------------
4714       subroutine vecpr(u,v,w)
4715       implicit real*8(a-h,o-z)
4716       dimension u(3),v(3),w(3)
4717       w(1)=u(2)*v(3)-u(3)*v(2)
4718       w(2)=-u(1)*v(3)+u(3)*v(1)
4719       w(3)=u(1)*v(2)-u(2)*v(1)
4720       return
4721       end
4722 C-----------------------------------------------------------------------------
4723       subroutine unormderiv(u,ugrad,unorm,ungrad)
4724 C This subroutine computes the derivatives of a normalized vector u, given
4725 C the derivatives computed without normalization conditions, ugrad. Returns
4726 C ungrad.
4727       implicit none
4728       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4729       double precision vec(3)
4730       double precision scalar
4731       integer i,j
4732 c      write (2,*) 'ugrad',ugrad
4733 c      write (2,*) 'u',u
4734       do i=1,3
4735         vec(i)=scalar(ugrad(1,i),u(1))
4736       enddo
4737 c      write (2,*) 'vec',vec
4738       do i=1,3
4739         do j=1,3
4740           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4741         enddo
4742       enddo
4743 c      write (2,*) 'ungrad',ungrad
4744       return
4745       end
4746 C-----------------------------------------------------------------------------
4747       subroutine escp_soft_sphere(evdw2,evdw2_14)
4748 C
4749 C This subroutine calculates the excluded-volume interaction energy between
4750 C peptide-group centers and side chains and its gradient in virtual-bond and
4751 C side-chain vectors.
4752 C
4753       implicit real*8 (a-h,o-z)
4754       include 'DIMENSIONS'
4755       include 'COMMON.GEO'
4756       include 'COMMON.VAR'
4757       include 'COMMON.LOCAL'
4758       include 'COMMON.CHAIN'
4759       include 'COMMON.DERIV'
4760       include 'COMMON.INTERACT'
4761       include 'COMMON.FFIELD'
4762       include 'COMMON.IOUNITS'
4763       include 'COMMON.CONTROL'
4764       dimension ggg(3)
4765       evdw2=0.0D0
4766       evdw2_14=0.0d0
4767       r0_scp=4.5d0
4768 cd    print '(a)','Enter ESCP'
4769 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4770 C      do xshift=-1,1
4771 C      do yshift=-1,1
4772 C      do zshift=-1,1
4773       do i=iatscp_s,iatscp_e
4774         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4775         iteli=itel(i)
4776         xi=0.5D0*(c(1,i)+c(1,i+1))
4777         yi=0.5D0*(c(2,i)+c(2,i+1))
4778         zi=0.5D0*(c(3,i)+c(3,i+1))
4779 C Return atom into box, boxxsize is size of box in x dimension
4780 c  134   continue
4781 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4782 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4783 C Condition for being inside the proper box
4784 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4785 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4786 c        go to 134
4787 c        endif
4788 c  135   continue
4789 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4790 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4791 C Condition for being inside the proper box
4792 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4793 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4794 c        go to 135
4795 c c       endif
4796 c  136   continue
4797 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4798 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4799 cC Condition for being inside the proper box
4800 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4801 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4802 c        go to 136
4803 c        endif
4804           xi=mod(xi,boxxsize)
4805           if (xi.lt.0) xi=xi+boxxsize
4806           yi=mod(yi,boxysize)
4807           if (yi.lt.0) yi=yi+boxysize
4808           zi=mod(zi,boxzsize)
4809           if (zi.lt.0) zi=zi+boxzsize
4810 C          xi=xi+xshift*boxxsize
4811 C          yi=yi+yshift*boxysize
4812 C          zi=zi+zshift*boxzsize
4813         do iint=1,nscp_gr(i)
4814
4815         do j=iscpstart(i,iint),iscpend(i,iint)
4816           if (itype(j).eq.ntyp1) cycle
4817           itypj=iabs(itype(j))
4818 C Uncomment following three lines for SC-p interactions
4819 c         xj=c(1,nres+j)-xi
4820 c         yj=c(2,nres+j)-yi
4821 c         zj=c(3,nres+j)-zi
4822 C Uncomment following three lines for Ca-p interactions
4823           xj=c(1,j)
4824           yj=c(2,j)
4825           zj=c(3,j)
4826 c  174   continue
4827 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4828 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4829 C Condition for being inside the proper box
4830 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4831 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4832 c        go to 174
4833 c        endif
4834 c  175   continue
4835 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4836 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4837 cC Condition for being inside the proper box
4838 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4839 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4840 c        go to 175
4841 c        endif
4842 c  176   continue
4843 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4844 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4845 C Condition for being inside the proper box
4846 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4847 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4848 c        go to 176
4849           xj=mod(xj,boxxsize)
4850           if (xj.lt.0) xj=xj+boxxsize
4851           yj=mod(yj,boxysize)
4852           if (yj.lt.0) yj=yj+boxysize
4853           zj=mod(zj,boxzsize)
4854           if (zj.lt.0) zj=zj+boxzsize
4855       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4856       xj_safe=xj
4857       yj_safe=yj
4858       zj_safe=zj
4859       subchap=0
4860       do xshift=-1,1
4861       do yshift=-1,1
4862       do zshift=-1,1
4863           xj=xj_safe+xshift*boxxsize
4864           yj=yj_safe+yshift*boxysize
4865           zj=zj_safe+zshift*boxzsize
4866           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4867           if(dist_temp.lt.dist_init) then
4868             dist_init=dist_temp
4869             xj_temp=xj
4870             yj_temp=yj
4871             zj_temp=zj
4872             subchap=1
4873           endif
4874        enddo
4875        enddo
4876        enddo
4877        if (subchap.eq.1) then
4878           xj=xj_temp-xi
4879           yj=yj_temp-yi
4880           zj=zj_temp-zi
4881        else
4882           xj=xj_safe-xi
4883           yj=yj_safe-yi
4884           zj=zj_safe-zi
4885        endif
4886 c c       endif
4887 C          xj=xj-xi
4888 C          yj=yj-yi
4889 C          zj=zj-zi
4890           rij=xj*xj+yj*yj+zj*zj
4891
4892           r0ij=r0_scp
4893           r0ijsq=r0ij*r0ij
4894           if (rij.lt.r0ijsq) then
4895             evdwij=0.25d0*(rij-r0ijsq)**2
4896             fac=rij-r0ijsq
4897           else
4898             evdwij=0.0d0
4899             fac=0.0d0
4900           endif
4901           evdw2=evdw2+evdwij
4902 C
4903 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4904 C
4905           ggg(1)=xj*fac
4906           ggg(2)=yj*fac
4907           ggg(3)=zj*fac
4908 cgrad          if (j.lt.i) then
4909 cd          write (iout,*) 'j<i'
4910 C Uncomment following three lines for SC-p interactions
4911 c           do k=1,3
4912 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4913 c           enddo
4914 cgrad          else
4915 cd          write (iout,*) 'j>i'
4916 cgrad            do k=1,3
4917 cgrad              ggg(k)=-ggg(k)
4918 C Uncomment following line for SC-p interactions
4919 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4920 cgrad            enddo
4921 cgrad          endif
4922 cgrad          do k=1,3
4923 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4924 cgrad          enddo
4925 cgrad          kstart=min0(i+1,j)
4926 cgrad          kend=max0(i-1,j-1)
4927 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4928 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4929 cgrad          do k=kstart,kend
4930 cgrad            do l=1,3
4931 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4932 cgrad            enddo
4933 cgrad          enddo
4934           do k=1,3
4935             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4936             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4937           enddo
4938         enddo
4939
4940         enddo ! iint
4941       enddo ! i
4942 C      enddo !zshift
4943 C      enddo !yshift
4944 C      enddo !xshift
4945       return
4946       end
4947 C-----------------------------------------------------------------------------
4948       subroutine escp(evdw2,evdw2_14)
4949 C
4950 C This subroutine calculates the excluded-volume interaction energy between
4951 C peptide-group centers and side chains and its gradient in virtual-bond and
4952 C side-chain vectors.
4953 C
4954       implicit real*8 (a-h,o-z)
4955       include 'DIMENSIONS'
4956       include 'COMMON.GEO'
4957       include 'COMMON.VAR'
4958       include 'COMMON.LOCAL'
4959       include 'COMMON.CHAIN'
4960       include 'COMMON.DERIV'
4961       include 'COMMON.INTERACT'
4962       include 'COMMON.FFIELD'
4963       include 'COMMON.IOUNITS'
4964       include 'COMMON.CONTROL'
4965       include 'COMMON.SPLITELE'
4966       dimension ggg(3)
4967       evdw2=0.0D0
4968       evdw2_14=0.0d0
4969 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4970 cd    print '(a)','Enter ESCP'
4971 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4972 C      do xshift=-1,1
4973 C      do yshift=-1,1
4974 C      do zshift=-1,1
4975       do i=iatscp_s,iatscp_e
4976         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4977         iteli=itel(i)
4978         xi=0.5D0*(c(1,i)+c(1,i+1))
4979         yi=0.5D0*(c(2,i)+c(2,i+1))
4980         zi=0.5D0*(c(3,i)+c(3,i+1))
4981           xi=mod(xi,boxxsize)
4982           if (xi.lt.0) xi=xi+boxxsize
4983           yi=mod(yi,boxysize)
4984           if (yi.lt.0) yi=yi+boxysize
4985           zi=mod(zi,boxzsize)
4986           if (zi.lt.0) zi=zi+boxzsize
4987 c          xi=xi+xshift*boxxsize
4988 c          yi=yi+yshift*boxysize
4989 c          zi=zi+zshift*boxzsize
4990 c        print *,xi,yi,zi,'polozenie i'
4991 C Return atom into box, boxxsize is size of box in x dimension
4992 c  134   continue
4993 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4994 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4995 C Condition for being inside the proper box
4996 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4997 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4998 c        go to 134
4999 c        endif
5000 c  135   continue
5001 c          print *,xi,boxxsize,"pierwszy"
5002
5003 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5004 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5005 C Condition for being inside the proper box
5006 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5007 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5008 c        go to 135
5009 c        endif
5010 c  136   continue
5011 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5012 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5013 C Condition for being inside the proper box
5014 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5015 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5016 c        go to 136
5017 c        endif
5018         do iint=1,nscp_gr(i)
5019
5020         do j=iscpstart(i,iint),iscpend(i,iint)
5021           itypj=iabs(itype(j))
5022           if (itypj.eq.ntyp1) cycle
5023 C Uncomment following three lines for SC-p interactions
5024 c         xj=c(1,nres+j)-xi
5025 c         yj=c(2,nres+j)-yi
5026 c         zj=c(3,nres+j)-zi
5027 C Uncomment following three lines for Ca-p interactions
5028           xj=c(1,j)
5029           yj=c(2,j)
5030           zj=c(3,j)
5031           xj=mod(xj,boxxsize)
5032           if (xj.lt.0) xj=xj+boxxsize
5033           yj=mod(yj,boxysize)
5034           if (yj.lt.0) yj=yj+boxysize
5035           zj=mod(zj,boxzsize)
5036           if (zj.lt.0) zj=zj+boxzsize
5037 c  174   continue
5038 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5039 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5040 C Condition for being inside the proper box
5041 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5042 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5043 c        go to 174
5044 c        endif
5045 c  175   continue
5046 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5047 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5048 cC Condition for being inside the proper box
5049 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5050 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5051 c        go to 175
5052 c        endif
5053 c  176   continue
5054 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5055 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5056 C Condition for being inside the proper box
5057 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5058 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5059 c        go to 176
5060 c        endif
5061 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5062       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5063       xj_safe=xj
5064       yj_safe=yj
5065       zj_safe=zj
5066       subchap=0
5067       do xshift=-1,1
5068       do yshift=-1,1
5069       do zshift=-1,1
5070           xj=xj_safe+xshift*boxxsize
5071           yj=yj_safe+yshift*boxysize
5072           zj=zj_safe+zshift*boxzsize
5073           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5074           if(dist_temp.lt.dist_init) then
5075             dist_init=dist_temp
5076             xj_temp=xj
5077             yj_temp=yj
5078             zj_temp=zj
5079             subchap=1
5080           endif
5081        enddo
5082        enddo
5083        enddo
5084        if (subchap.eq.1) then
5085           xj=xj_temp-xi
5086           yj=yj_temp-yi
5087           zj=zj_temp-zi
5088        else
5089           xj=xj_safe-xi
5090           yj=yj_safe-yi
5091           zj=zj_safe-zi
5092        endif
5093 c          print *,xj,yj,zj,'polozenie j'
5094           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5095 c          print *,rrij
5096           sss=sscale(1.0d0/(dsqrt(rrij)))
5097 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5098 c          if (sss.eq.0) print *,'czasem jest OK'
5099           if (sss.le.0.0d0) cycle
5100           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5101           fac=rrij**expon2
5102           e1=fac*fac*aad(itypj,iteli)
5103           e2=fac*bad(itypj,iteli)
5104           if (iabs(j-i) .le. 2) then
5105             e1=scal14*e1
5106             e2=scal14*e2
5107             evdw2_14=evdw2_14+(e1+e2)*sss
5108           endif
5109           evdwij=e1+e2
5110           evdw2=evdw2+evdwij*sss
5111           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5112      &        'evdw2',i,j,evdwij
5113 c     &        ,iteli,itypj,fac,aad(itypj,iteli),bad(itypj,iteli)
5114 C
5115 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5116 C
5117           fac=-(evdwij+e1)*rrij*sss
5118           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5119           ggg(1)=xj*fac
5120           ggg(2)=yj*fac
5121           ggg(3)=zj*fac
5122 cgrad          if (j.lt.i) then
5123 cd          write (iout,*) 'j<i'
5124 C Uncomment following three lines for SC-p interactions
5125 c           do k=1,3
5126 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5127 c           enddo
5128 cgrad          else
5129 cd          write (iout,*) 'j>i'
5130 cgrad            do k=1,3
5131 cgrad              ggg(k)=-ggg(k)
5132 C Uncomment following line for SC-p interactions
5133 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5134 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5135 cgrad            enddo
5136 cgrad          endif
5137 cgrad          do k=1,3
5138 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5139 cgrad          enddo
5140 cgrad          kstart=min0(i+1,j)
5141 cgrad          kend=max0(i-1,j-1)
5142 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5143 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5144 cgrad          do k=kstart,kend
5145 cgrad            do l=1,3
5146 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5147 cgrad            enddo
5148 cgrad          enddo
5149           do k=1,3
5150             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5151             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5152           enddo
5153 c        endif !endif for sscale cutoff
5154         enddo ! j
5155
5156         enddo ! iint
5157       enddo ! i
5158 c      enddo !zshift
5159 c      enddo !yshift
5160 c      enddo !xshift
5161       do i=1,nct
5162         do j=1,3
5163           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5164           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5165           gradx_scp(j,i)=expon*gradx_scp(j,i)
5166         enddo
5167       enddo
5168 C******************************************************************************
5169 C
5170 C                              N O T E !!!
5171 C
5172 C To save time the factor EXPON has been extracted from ALL components
5173 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5174 C use!
5175 C
5176 C******************************************************************************
5177       return
5178       end
5179 C--------------------------------------------------------------------------
5180       subroutine edis(ehpb)
5181 C
5182 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5183 C
5184       implicit real*8 (a-h,o-z)
5185       include 'DIMENSIONS'
5186       include 'COMMON.SBRIDGE'
5187       include 'COMMON.CHAIN'
5188       include 'COMMON.DERIV'
5189       include 'COMMON.VAR'
5190       include 'COMMON.INTERACT'
5191       include 'COMMON.IOUNITS'
5192       dimension ggg(3)
5193       ehpb=0.0D0
5194 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5195 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5196       if (link_end.eq.0) return
5197       do i=link_start,link_end
5198 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5199 C CA-CA distance used in regularization of structure.
5200         ii=ihpb(i)
5201         jj=jhpb(i)
5202 C iii and jjj point to the residues for which the distance is assigned.
5203         if (ii.gt.nres) then
5204           iii=ii-nres
5205           jjj=jj-nres
5206         else
5207           iii=ii
5208           jjj=jj
5209         endif
5210 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5211 c     &    dhpb(i),dhpb1(i),forcon(i)
5212 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5213 C    distance and angle dependent SS bond potential.
5214 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5215 C     & iabs(itype(jjj)).eq.1) then
5216 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5217 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5218         if (.not.dyn_ss .and. i.le.nss) then
5219 C 15/02/13 CC dynamic SSbond - additional check
5220          if (ii.gt.nres
5221      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5222           call ssbond_ene(iii,jjj,eij)
5223           ehpb=ehpb+2*eij
5224          endif
5225 cd          write (iout,*) "eij",eij
5226         else
5227 C Calculate the distance between the two points and its difference from the
5228 C target distance.
5229           dd=dist(ii,jj)
5230             rdis=dd-dhpb(i)
5231 C Get the force constant corresponding to this distance.
5232             waga=forcon(i)
5233 C Calculate the contribution to energy.
5234             ehpb=ehpb+waga*rdis*rdis
5235 C
5236 C Evaluate gradient.
5237 C
5238             fac=waga*rdis/dd
5239 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5240 cd   &   ' waga=',waga,' fac=',fac
5241             do j=1,3
5242               ggg(j)=fac*(c(j,jj)-c(j,ii))
5243             enddo
5244 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5245 C If this is a SC-SC distance, we need to calculate the contributions to the
5246 C Cartesian gradient in the SC vectors (ghpbx).
5247           if (iii.lt.ii) then
5248           do j=1,3
5249             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5250             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5251           enddo
5252           endif
5253 cgrad        do j=iii,jjj-1
5254 cgrad          do k=1,3
5255 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5256 cgrad          enddo
5257 cgrad        enddo
5258           do k=1,3
5259             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5260             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5261           enddo
5262         endif
5263       enddo
5264       ehpb=0.5D0*ehpb
5265       return
5266       end
5267 C--------------------------------------------------------------------------
5268       subroutine ssbond_ene(i,j,eij)
5269 C
5270 C Calculate the distance and angle dependent SS-bond potential energy
5271 C using a free-energy function derived based on RHF/6-31G** ab initio
5272 C calculations of diethyl disulfide.
5273 C
5274 C A. Liwo and U. Kozlowska, 11/24/03
5275 C
5276       implicit real*8 (a-h,o-z)
5277       include 'DIMENSIONS'
5278       include 'COMMON.SBRIDGE'
5279       include 'COMMON.CHAIN'
5280       include 'COMMON.DERIV'
5281       include 'COMMON.LOCAL'
5282       include 'COMMON.INTERACT'
5283       include 'COMMON.VAR'
5284       include 'COMMON.IOUNITS'
5285       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5286       itypi=iabs(itype(i))
5287       xi=c(1,nres+i)
5288       yi=c(2,nres+i)
5289       zi=c(3,nres+i)
5290       dxi=dc_norm(1,nres+i)
5291       dyi=dc_norm(2,nres+i)
5292       dzi=dc_norm(3,nres+i)
5293 c      dsci_inv=dsc_inv(itypi)
5294       dsci_inv=vbld_inv(nres+i)
5295       itypj=iabs(itype(j))
5296 c      dscj_inv=dsc_inv(itypj)
5297       dscj_inv=vbld_inv(nres+j)
5298       xj=c(1,nres+j)-xi
5299       yj=c(2,nres+j)-yi
5300       zj=c(3,nres+j)-zi
5301       dxj=dc_norm(1,nres+j)
5302       dyj=dc_norm(2,nres+j)
5303       dzj=dc_norm(3,nres+j)
5304       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5305       rij=dsqrt(rrij)
5306       erij(1)=xj*rij
5307       erij(2)=yj*rij
5308       erij(3)=zj*rij
5309       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5310       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5311       om12=dxi*dxj+dyi*dyj+dzi*dzj
5312       do k=1,3
5313         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5314         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5315       enddo
5316       rij=1.0d0/rij
5317       deltad=rij-d0cm
5318       deltat1=1.0d0-om1
5319       deltat2=1.0d0+om2
5320       deltat12=om2-om1+2.0d0
5321       cosphi=om12-om1*om2
5322       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5323      &  +akct*deltad*deltat12
5324      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5325 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5326 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5327 c     &  " deltat12",deltat12," eij",eij
5328       ed=2*akcm*deltad+akct*deltat12
5329       pom1=akct*deltad
5330       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5331       eom1=-2*akth*deltat1-pom1-om2*pom2
5332       eom2= 2*akth*deltat2+pom1-om1*pom2
5333       eom12=pom2
5334       do k=1,3
5335         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5336         ghpbx(k,i)=ghpbx(k,i)-ggk
5337      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5338      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5339         ghpbx(k,j)=ghpbx(k,j)+ggk
5340      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5341      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5342         ghpbc(k,i)=ghpbc(k,i)-ggk
5343         ghpbc(k,j)=ghpbc(k,j)+ggk
5344       enddo
5345 C
5346 C Calculate the components of the gradient in DC and X
5347 C
5348 cgrad      do k=i,j-1
5349 cgrad        do l=1,3
5350 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5351 cgrad        enddo
5352 cgrad      enddo
5353       return
5354       end
5355 C--------------------------------------------------------------------------
5356       subroutine ebond(estr)
5357 c
5358 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5359 c
5360       implicit real*8 (a-h,o-z)
5361       include 'DIMENSIONS'
5362       include 'COMMON.LOCAL'
5363       include 'COMMON.GEO'
5364       include 'COMMON.INTERACT'
5365       include 'COMMON.DERIV'
5366       include 'COMMON.VAR'
5367       include 'COMMON.CHAIN'
5368       include 'COMMON.IOUNITS'
5369       include 'COMMON.NAMES'
5370       include 'COMMON.FFIELD'
5371       include 'COMMON.CONTROL'
5372       include 'COMMON.SETUP'
5373       double precision u(3),ud(3)
5374       estr=0.0d0
5375       estr1=0.0d0
5376       do i=ibondp_start,ibondp_end
5377         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5378 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5379 c          do j=1,3
5380 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5381 c     &      *dc(j,i-1)/vbld(i)
5382 c          enddo
5383 c          if (energy_dec) write(iout,*)
5384 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5385 c        else
5386 C       Checking if it involves dummy (NH3+ or COO-) group
5387          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5388 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5389         diff = vbld(i)-vbldpDUM
5390          else
5391 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5392         diff = vbld(i)-vbldp0
5393          endif
5394         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5395      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5396         estr=estr+diff*diff
5397         do j=1,3
5398           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5399         enddo
5400 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5401 c        endif
5402       enddo
5403       estr=0.5d0*AKP*estr+estr1
5404 c
5405 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5406 c
5407       do i=ibond_start,ibond_end
5408         iti=iabs(itype(i))
5409         if (iti.ne.10 .and. iti.ne.ntyp1) then
5410           nbi=nbondterm(iti)
5411           if (nbi.eq.1) then
5412             diff=vbld(i+nres)-vbldsc0(1,iti)
5413             if (energy_dec)  write (iout,*)
5414      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5415      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5416             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5417             do j=1,3
5418               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5419             enddo
5420           else
5421             do j=1,nbi
5422               diff=vbld(i+nres)-vbldsc0(j,iti)
5423               ud(j)=aksc(j,iti)*diff
5424               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5425             enddo
5426             uprod=u(1)
5427             do j=2,nbi
5428               uprod=uprod*u(j)
5429             enddo
5430             usum=0.0d0
5431             usumsqder=0.0d0
5432             do j=1,nbi
5433               uprod1=1.0d0
5434               uprod2=1.0d0
5435               do k=1,nbi
5436                 if (k.ne.j) then
5437                   uprod1=uprod1*u(k)
5438                   uprod2=uprod2*u(k)*u(k)
5439                 endif
5440               enddo
5441               usum=usum+uprod1
5442               usumsqder=usumsqder+ud(j)*uprod2
5443             enddo
5444             estr=estr+uprod/usum
5445             do j=1,3
5446              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5447             enddo
5448           endif
5449         endif
5450       enddo
5451       return
5452       end
5453 #ifdef CRYST_THETA
5454 C--------------------------------------------------------------------------
5455       subroutine ebend(etheta)
5456 C
5457 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5458 C angles gamma and its derivatives in consecutive thetas and gammas.
5459 C
5460       implicit real*8 (a-h,o-z)
5461       include 'DIMENSIONS'
5462       include 'COMMON.LOCAL'
5463       include 'COMMON.GEO'
5464       include 'COMMON.INTERACT'
5465       include 'COMMON.DERIV'
5466       include 'COMMON.VAR'
5467       include 'COMMON.CHAIN'
5468       include 'COMMON.IOUNITS'
5469       include 'COMMON.NAMES'
5470       include 'COMMON.FFIELD'
5471       include 'COMMON.CONTROL'
5472       common /calcthet/ term1,term2,termm,diffak,ratak,
5473      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5474      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5475       double precision y(2),z(2)
5476       delta=0.02d0*pi
5477 c      time11=dexp(-2*time)
5478 c      time12=1.0d0
5479       etheta=0.0D0
5480 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5481       do i=ithet_start,ithet_end
5482         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5483      &  .or.itype(i).eq.ntyp1) cycle
5484 C Zero the energy function and its derivative at 0 or pi.
5485         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5486         it=itype(i-1)
5487         ichir1=isign(1,itype(i-2))
5488         ichir2=isign(1,itype(i))
5489          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5490          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5491          if (itype(i-1).eq.10) then
5492           itype1=isign(10,itype(i-2))
5493           ichir11=isign(1,itype(i-2))
5494           ichir12=isign(1,itype(i-2))
5495           itype2=isign(10,itype(i))
5496           ichir21=isign(1,itype(i))
5497           ichir22=isign(1,itype(i))
5498          endif
5499
5500         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5501 #ifdef OSF
5502           phii=phi(i)
5503           if (phii.ne.phii) phii=150.0
5504 #else
5505           phii=phi(i)
5506 #endif
5507           y(1)=dcos(phii)
5508           y(2)=dsin(phii)
5509         else
5510           y(1)=0.0D0
5511           y(2)=0.0D0
5512         endif
5513         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5514 #ifdef OSF
5515           phii1=phi(i+1)
5516           if (phii1.ne.phii1) phii1=150.0
5517           phii1=pinorm(phii1)
5518           z(1)=cos(phii1)
5519 #else
5520           phii1=phi(i+1)
5521 #endif
5522           z(1)=dcos(phii1)
5523           z(2)=dsin(phii1)
5524         else
5525           z(1)=0.0D0
5526           z(2)=0.0D0
5527         endif
5528 C Calculate the "mean" value of theta from the part of the distribution
5529 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5530 C In following comments this theta will be referred to as t_c.
5531         thet_pred_mean=0.0d0
5532         do k=1,2
5533             athetk=athet(k,it,ichir1,ichir2)
5534             bthetk=bthet(k,it,ichir1,ichir2)
5535           if (it.eq.10) then
5536              athetk=athet(k,itype1,ichir11,ichir12)
5537              bthetk=bthet(k,itype2,ichir21,ichir22)
5538           endif
5539          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5540 c         write(iout,*) 'chuj tu', y(k),z(k)
5541         enddo
5542         dthett=thet_pred_mean*ssd
5543         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5544 C Derivatives of the "mean" values in gamma1 and gamma2.
5545         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5546      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5547          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5548      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5549          if (it.eq.10) then
5550       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5551      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5552         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5553      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5554          endif
5555         if (theta(i).gt.pi-delta) then
5556           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5557      &         E_tc0)
5558           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5559           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5560           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5561      &        E_theta)
5562           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5563      &        E_tc)
5564         else if (theta(i).lt.delta) then
5565           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5566           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5567           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5568      &        E_theta)
5569           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5570           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5571      &        E_tc)
5572         else
5573           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5574      &        E_theta,E_tc)
5575         endif
5576         etheta=etheta+ethetai
5577         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5578      &      'ebend',i,ethetai,theta(i),itype(i)
5579         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5580         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5581         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5582       enddo
5583 C Ufff.... We've done all this!!!
5584       return
5585       end
5586 C---------------------------------------------------------------------------
5587       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5588      &     E_tc)
5589       implicit real*8 (a-h,o-z)
5590       include 'DIMENSIONS'
5591       include 'COMMON.LOCAL'
5592       include 'COMMON.IOUNITS'
5593       common /calcthet/ term1,term2,termm,diffak,ratak,
5594      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5595      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5596 C Calculate the contributions to both Gaussian lobes.
5597 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5598 C The "polynomial part" of the "standard deviation" of this part of
5599 C the distributioni.
5600 ccc        write (iout,*) thetai,thet_pred_mean
5601         sig=polthet(3,it)
5602         do j=2,0,-1
5603           sig=sig*thet_pred_mean+polthet(j,it)
5604         enddo
5605 C Derivative of the "interior part" of the "standard deviation of the"
5606 C gamma-dependent Gaussian lobe in t_c.
5607         sigtc=3*polthet(3,it)
5608         do j=2,1,-1
5609           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5610         enddo
5611         sigtc=sig*sigtc
5612 C Set the parameters of both Gaussian lobes of the distribution.
5613 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5614         fac=sig*sig+sigc0(it)
5615         sigcsq=fac+fac
5616         sigc=1.0D0/sigcsq
5617 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5618         sigsqtc=-4.0D0*sigcsq*sigtc
5619 c       print *,i,sig,sigtc,sigsqtc
5620 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5621         sigtc=-sigtc/(fac*fac)
5622 C Following variable is sigma(t_c)**(-2)
5623         sigcsq=sigcsq*sigcsq
5624         sig0i=sig0(it)
5625         sig0inv=1.0D0/sig0i**2
5626         delthec=thetai-thet_pred_mean
5627         delthe0=thetai-theta0i
5628         term1=-0.5D0*sigcsq*delthec*delthec
5629         term2=-0.5D0*sig0inv*delthe0*delthe0
5630 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5631 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5632 C NaNs in taking the logarithm. We extract the largest exponent which is added
5633 C to the energy (this being the log of the distribution) at the end of energy
5634 C term evaluation for this virtual-bond angle.
5635         if (term1.gt.term2) then
5636           termm=term1
5637           term2=dexp(term2-termm)
5638           term1=1.0d0
5639         else
5640           termm=term2
5641           term1=dexp(term1-termm)
5642           term2=1.0d0
5643         endif
5644 C The ratio between the gamma-independent and gamma-dependent lobes of
5645 C the distribution is a Gaussian function of thet_pred_mean too.
5646         diffak=gthet(2,it)-thet_pred_mean
5647         ratak=diffak/gthet(3,it)**2
5648         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5649 C Let's differentiate it in thet_pred_mean NOW.
5650         aktc=ak*ratak
5651 C Now put together the distribution terms to make complete distribution.
5652         termexp=term1+ak*term2
5653         termpre=sigc+ak*sig0i
5654 C Contribution of the bending energy from this theta is just the -log of
5655 C the sum of the contributions from the two lobes and the pre-exponential
5656 C factor. Simple enough, isn't it?
5657         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5658 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5659 C NOW the derivatives!!!
5660 C 6/6/97 Take into account the deformation.
5661         E_theta=(delthec*sigcsq*term1
5662      &       +ak*delthe0*sig0inv*term2)/termexp
5663         E_tc=((sigtc+aktc*sig0i)/termpre
5664      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5665      &       aktc*term2)/termexp)
5666       return
5667       end
5668 c-----------------------------------------------------------------------------
5669       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5670       implicit real*8 (a-h,o-z)
5671       include 'DIMENSIONS'
5672       include 'COMMON.LOCAL'
5673       include 'COMMON.IOUNITS'
5674       common /calcthet/ term1,term2,termm,diffak,ratak,
5675      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5676      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5677       delthec=thetai-thet_pred_mean
5678       delthe0=thetai-theta0i
5679 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5680       t3 = thetai-thet_pred_mean
5681       t6 = t3**2
5682       t9 = term1
5683       t12 = t3*sigcsq
5684       t14 = t12+t6*sigsqtc
5685       t16 = 1.0d0
5686       t21 = thetai-theta0i
5687       t23 = t21**2
5688       t26 = term2
5689       t27 = t21*t26
5690       t32 = termexp
5691       t40 = t32**2
5692       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5693      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5694      & *(-t12*t9-ak*sig0inv*t27)
5695       return
5696       end
5697 #else
5698 C--------------------------------------------------------------------------
5699       subroutine ebend(etheta)
5700 C
5701 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5702 C angles gamma and its derivatives in consecutive thetas and gammas.
5703 C ab initio-derived potentials from
5704 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5705 C
5706       implicit real*8 (a-h,o-z)
5707       include 'DIMENSIONS'
5708       include 'COMMON.LOCAL'
5709       include 'COMMON.GEO'
5710       include 'COMMON.INTERACT'
5711       include 'COMMON.DERIV'
5712       include 'COMMON.VAR'
5713       include 'COMMON.CHAIN'
5714       include 'COMMON.IOUNITS'
5715       include 'COMMON.NAMES'
5716       include 'COMMON.FFIELD'
5717       include 'COMMON.CONTROL'
5718       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5719      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5720      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5721      & sinph1ph2(maxdouble,maxdouble)
5722       logical lprn /.false./, lprn1 /.false./
5723       etheta=0.0D0
5724       do i=ithet_start,ithet_end
5725 c        if (i.eq.2) cycle
5726 c        print *,i,itype(i-1),itype(i),itype(i-2)
5727         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5728      &  .or.(itype(i).eq.ntyp1)) cycle
5729 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5730
5731         if (iabs(itype(i+1)).eq.20) iblock=2
5732         if (iabs(itype(i+1)).ne.20) iblock=1
5733         dethetai=0.0d0
5734         dephii=0.0d0
5735         dephii1=0.0d0
5736         theti2=0.5d0*theta(i)
5737         ityp2=ithetyp((itype(i-1)))
5738         do k=1,nntheterm
5739           coskt(k)=dcos(k*theti2)
5740           sinkt(k)=dsin(k*theti2)
5741         enddo
5742         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5743 #ifdef OSF
5744           phii=phi(i)
5745           if (phii.ne.phii) phii=150.0
5746 #else
5747           phii=phi(i)
5748 #endif
5749           ityp1=ithetyp((itype(i-2)))
5750 C propagation of chirality for glycine type
5751           do k=1,nsingle
5752             cosph1(k)=dcos(k*phii)
5753             sinph1(k)=dsin(k*phii)
5754           enddo
5755         else
5756           phii=0.0d0
5757           ityp1=ithetyp(itype(i-2))
5758           do k=1,nsingle
5759             cosph1(k)=0.0d0
5760             sinph1(k)=0.0d0
5761           enddo
5762         endif
5763         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5764 #ifdef OSF
5765           phii1=phi(i+1)
5766           if (phii1.ne.phii1) phii1=150.0
5767           phii1=pinorm(phii1)
5768 #else
5769           phii1=phi(i+1)
5770 #endif
5771           ityp3=ithetyp((itype(i)))
5772           do k=1,nsingle
5773             cosph2(k)=dcos(k*phii1)
5774             sinph2(k)=dsin(k*phii1)
5775           enddo
5776         else
5777           phii1=0.0d0
5778           ityp3=ithetyp(itype(i))
5779           do k=1,nsingle
5780             cosph2(k)=0.0d0
5781             sinph2(k)=0.0d0
5782           enddo
5783         endif
5784         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5785         do k=1,ndouble
5786           do l=1,k-1
5787             ccl=cosph1(l)*cosph2(k-l)
5788             ssl=sinph1(l)*sinph2(k-l)
5789             scl=sinph1(l)*cosph2(k-l)
5790             csl=cosph1(l)*sinph2(k-l)
5791             cosph1ph2(l,k)=ccl-ssl
5792             cosph1ph2(k,l)=ccl+ssl
5793             sinph1ph2(l,k)=scl+csl
5794             sinph1ph2(k,l)=scl-csl
5795           enddo
5796         enddo
5797         if (lprn) then
5798         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5799      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5800         write (iout,*) "coskt and sinkt"
5801         do k=1,nntheterm
5802           write (iout,*) k,coskt(k),sinkt(k)
5803         enddo
5804         endif
5805         do k=1,ntheterm
5806           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5807           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5808      &      *coskt(k)
5809           if (lprn)
5810      &    write (iout,*) "k",k,"
5811      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5812      &     " ethetai",ethetai
5813         enddo
5814         if (lprn) then
5815         write (iout,*) "cosph and sinph"
5816         do k=1,nsingle
5817           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5818         enddo
5819         write (iout,*) "cosph1ph2 and sinph2ph2"
5820         do k=2,ndouble
5821           do l=1,k-1
5822             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5823      &         sinph1ph2(l,k),sinph1ph2(k,l)
5824           enddo
5825         enddo
5826         write(iout,*) "ethetai",ethetai
5827         endif
5828         do m=1,ntheterm2
5829           do k=1,nsingle
5830             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5831      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5832      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5833      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5834             ethetai=ethetai+sinkt(m)*aux
5835             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5836             dephii=dephii+k*sinkt(m)*(
5837      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5838      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5839             dephii1=dephii1+k*sinkt(m)*(
5840      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5841      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5842             if (lprn)
5843      &      write (iout,*) "m",m," k",k," bbthet",
5844      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5845      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5846      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5847      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5848           enddo
5849         enddo
5850         if (lprn)
5851      &  write(iout,*) "ethetai",ethetai
5852         do m=1,ntheterm3
5853           do k=2,ndouble
5854             do l=1,k-1
5855               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5856      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5857      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5858      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5859               ethetai=ethetai+sinkt(m)*aux
5860               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5861               dephii=dephii+l*sinkt(m)*(
5862      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5863      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5864      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5865      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5866               dephii1=dephii1+(k-l)*sinkt(m)*(
5867      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5868      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5869      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5870      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5871               if (lprn) then
5872               write (iout,*) "m",m," k",k," l",l," ffthet",
5873      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5874      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5875      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5876      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5877      &            " ethetai",ethetai
5878               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5879      &            cosph1ph2(k,l)*sinkt(m),
5880      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5881               endif
5882             enddo
5883           enddo
5884         enddo
5885 10      continue
5886 c        lprn1=.true.
5887         if (lprn1)
5888      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5889      &   i,theta(i)*rad2deg,phii*rad2deg,
5890      &   phii1*rad2deg,ethetai
5891 c        lprn1=.false.
5892         etheta=etheta+ethetai
5893         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5894      &      'ebend',i,ethetai
5895         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5896         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5897         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5898       enddo
5899       return
5900       end
5901 #endif
5902 #ifdef CRYST_SC
5903 c-----------------------------------------------------------------------------
5904       subroutine esc(escloc)
5905 C Calculate the local energy of a side chain and its derivatives in the
5906 C corresponding virtual-bond valence angles THETA and the spherical angles
5907 C ALPHA and OMEGA.
5908       implicit real*8 (a-h,o-z)
5909       include 'DIMENSIONS'
5910       include 'COMMON.GEO'
5911       include 'COMMON.LOCAL'
5912       include 'COMMON.VAR'
5913       include 'COMMON.INTERACT'
5914       include 'COMMON.DERIV'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.IOUNITS'
5917       include 'COMMON.NAMES'
5918       include 'COMMON.FFIELD'
5919       include 'COMMON.CONTROL'
5920       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5921      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5922       common /sccalc/ time11,time12,time112,theti,it,nlobit
5923       delta=0.02d0*pi
5924       escloc=0.0D0
5925 c     write (iout,'(a)') 'ESC'
5926       do i=loc_start,loc_end
5927         it=itype(i)
5928         if (it.eq.ntyp1) cycle
5929         if (it.eq.10) goto 1
5930         nlobit=nlob(iabs(it))
5931 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5932 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5933         theti=theta(i+1)-pipol
5934         x(1)=dtan(theti)
5935         x(2)=alph(i)
5936         x(3)=omeg(i)
5937
5938         if (x(2).gt.pi-delta) then
5939           xtemp(1)=x(1)
5940           xtemp(2)=pi-delta
5941           xtemp(3)=x(3)
5942           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5943           xtemp(2)=pi
5944           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5945           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5946      &        escloci,dersc(2))
5947           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5948      &        ddersc0(1),dersc(1))
5949           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5950      &        ddersc0(3),dersc(3))
5951           xtemp(2)=pi-delta
5952           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5953           xtemp(2)=pi
5954           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5955           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5956      &            dersc0(2),esclocbi,dersc02)
5957           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5958      &            dersc12,dersc01)
5959           call splinthet(x(2),0.5d0*delta,ss,ssd)
5960           dersc0(1)=dersc01
5961           dersc0(2)=dersc02
5962           dersc0(3)=0.0d0
5963           do k=1,3
5964             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5965           enddo
5966           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5967 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5968 c    &             esclocbi,ss,ssd
5969           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5970 c         escloci=esclocbi
5971 c         write (iout,*) escloci
5972         else if (x(2).lt.delta) then
5973           xtemp(1)=x(1)
5974           xtemp(2)=delta
5975           xtemp(3)=x(3)
5976           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5977           xtemp(2)=0.0d0
5978           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5979           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5980      &        escloci,dersc(2))
5981           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5982      &        ddersc0(1),dersc(1))
5983           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5984      &        ddersc0(3),dersc(3))
5985           xtemp(2)=delta
5986           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5987           xtemp(2)=0.0d0
5988           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5989           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5990      &            dersc0(2),esclocbi,dersc02)
5991           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5992      &            dersc12,dersc01)
5993           dersc0(1)=dersc01
5994           dersc0(2)=dersc02
5995           dersc0(3)=0.0d0
5996           call splinthet(x(2),0.5d0*delta,ss,ssd)
5997           do k=1,3
5998             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5999           enddo
6000           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6001 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6002 c    &             esclocbi,ss,ssd
6003           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6004 c         write (iout,*) escloci
6005         else
6006           call enesc(x,escloci,dersc,ddummy,.false.)
6007         endif
6008
6009         escloc=escloc+escloci
6010         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6011      &     'escloc',i,escloci
6012 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6013
6014         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6015      &   wscloc*dersc(1)
6016         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6017         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6018     1   continue
6019       enddo
6020       return
6021       end
6022 C---------------------------------------------------------------------------
6023       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6024       implicit real*8 (a-h,o-z)
6025       include 'DIMENSIONS'
6026       include 'COMMON.GEO'
6027       include 'COMMON.LOCAL'
6028       include 'COMMON.IOUNITS'
6029       common /sccalc/ time11,time12,time112,theti,it,nlobit
6030       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6031       double precision contr(maxlob,-1:1)
6032       logical mixed
6033 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6034         escloc_i=0.0D0
6035         do j=1,3
6036           dersc(j)=0.0D0
6037           if (mixed) ddersc(j)=0.0d0
6038         enddo
6039         x3=x(3)
6040
6041 C Because of periodicity of the dependence of the SC energy in omega we have
6042 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6043 C To avoid underflows, first compute & store the exponents.
6044
6045         do iii=-1,1
6046
6047           x(3)=x3+iii*dwapi
6048
6049           do j=1,nlobit
6050             do k=1,3
6051               z(k)=x(k)-censc(k,j,it)
6052             enddo
6053             do k=1,3
6054               Axk=0.0D0
6055               do l=1,3
6056                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6057               enddo
6058               Ax(k,j,iii)=Axk
6059             enddo
6060             expfac=0.0D0
6061             do k=1,3
6062               expfac=expfac+Ax(k,j,iii)*z(k)
6063             enddo
6064             contr(j,iii)=expfac
6065           enddo ! j
6066
6067         enddo ! iii
6068
6069         x(3)=x3
6070 C As in the case of ebend, we want to avoid underflows in exponentiation and
6071 C subsequent NaNs and INFs in energy calculation.
6072 C Find the largest exponent
6073         emin=contr(1,-1)
6074         do iii=-1,1
6075           do j=1,nlobit
6076             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6077           enddo
6078         enddo
6079         emin=0.5D0*emin
6080 cd      print *,'it=',it,' emin=',emin
6081
6082 C Compute the contribution to SC energy and derivatives
6083         do iii=-1,1
6084
6085           do j=1,nlobit
6086 #ifdef OSF
6087             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6088             if(adexp.ne.adexp) adexp=1.0
6089             expfac=dexp(adexp)
6090 #else
6091             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6092 #endif
6093 cd          print *,'j=',j,' expfac=',expfac
6094             escloc_i=escloc_i+expfac
6095             do k=1,3
6096               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6097             enddo
6098             if (mixed) then
6099               do k=1,3,2
6100                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6101      &            +gaussc(k,2,j,it))*expfac
6102               enddo
6103             endif
6104           enddo
6105
6106         enddo ! iii
6107
6108         dersc(1)=dersc(1)/cos(theti)**2
6109         ddersc(1)=ddersc(1)/cos(theti)**2
6110         ddersc(3)=ddersc(3)
6111
6112         escloci=-(dlog(escloc_i)-emin)
6113         do j=1,3
6114           dersc(j)=dersc(j)/escloc_i
6115         enddo
6116         if (mixed) then
6117           do j=1,3,2
6118             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6119           enddo
6120         endif
6121       return
6122       end
6123 C------------------------------------------------------------------------------
6124       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6125       implicit real*8 (a-h,o-z)
6126       include 'DIMENSIONS'
6127       include 'COMMON.GEO'
6128       include 'COMMON.LOCAL'
6129       include 'COMMON.IOUNITS'
6130       common /sccalc/ time11,time12,time112,theti,it,nlobit
6131       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6132       double precision contr(maxlob)
6133       logical mixed
6134
6135       escloc_i=0.0D0
6136
6137       do j=1,3
6138         dersc(j)=0.0D0
6139       enddo
6140
6141       do j=1,nlobit
6142         do k=1,2
6143           z(k)=x(k)-censc(k,j,it)
6144         enddo
6145         z(3)=dwapi
6146         do k=1,3
6147           Axk=0.0D0
6148           do l=1,3
6149             Axk=Axk+gaussc(l,k,j,it)*z(l)
6150           enddo
6151           Ax(k,j)=Axk
6152         enddo
6153         expfac=0.0D0
6154         do k=1,3
6155           expfac=expfac+Ax(k,j)*z(k)
6156         enddo
6157         contr(j)=expfac
6158       enddo ! j
6159
6160 C As in the case of ebend, we want to avoid underflows in exponentiation and
6161 C subsequent NaNs and INFs in energy calculation.
6162 C Find the largest exponent
6163       emin=contr(1)
6164       do j=1,nlobit
6165         if (emin.gt.contr(j)) emin=contr(j)
6166       enddo
6167       emin=0.5D0*emin
6168
6169 C Compute the contribution to SC energy and derivatives
6170
6171       dersc12=0.0d0
6172       do j=1,nlobit
6173         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6174         escloc_i=escloc_i+expfac
6175         do k=1,2
6176           dersc(k)=dersc(k)+Ax(k,j)*expfac
6177         enddo
6178         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6179      &            +gaussc(1,2,j,it))*expfac
6180         dersc(3)=0.0d0
6181       enddo
6182
6183       dersc(1)=dersc(1)/cos(theti)**2
6184       dersc12=dersc12/cos(theti)**2
6185       escloci=-(dlog(escloc_i)-emin)
6186       do j=1,2
6187         dersc(j)=dersc(j)/escloc_i
6188       enddo
6189       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6190       return
6191       end
6192 #else
6193 c----------------------------------------------------------------------------------
6194       subroutine esc(escloc)
6195 C Calculate the local energy of a side chain and its derivatives in the
6196 C corresponding virtual-bond valence angles THETA and the spherical angles
6197 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6198 C added by Urszula Kozlowska. 07/11/2007
6199 C
6200       implicit real*8 (a-h,o-z)
6201       include 'DIMENSIONS'
6202       include 'COMMON.GEO'
6203       include 'COMMON.LOCAL'
6204       include 'COMMON.VAR'
6205       include 'COMMON.SCROT'
6206       include 'COMMON.INTERACT'
6207       include 'COMMON.DERIV'
6208       include 'COMMON.CHAIN'
6209       include 'COMMON.IOUNITS'
6210       include 'COMMON.NAMES'
6211       include 'COMMON.FFIELD'
6212       include 'COMMON.CONTROL'
6213       include 'COMMON.VECTORS'
6214       double precision x_prime(3),y_prime(3),z_prime(3)
6215      &    , sumene,dsc_i,dp2_i,x(65),
6216      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6217      &    de_dxx,de_dyy,de_dzz,de_dt
6218       double precision s1_t,s1_6_t,s2_t,s2_6_t
6219       double precision
6220      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6221      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6222      & dt_dCi(3),dt_dCi1(3)
6223       common /sccalc/ time11,time12,time112,theti,it,nlobit
6224       delta=0.02d0*pi
6225       escloc=0.0D0
6226       do i=loc_start,loc_end
6227         if (itype(i).eq.ntyp1) cycle
6228         costtab(i+1) =dcos(theta(i+1))
6229         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6230         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6231         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6232         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6233         cosfac=dsqrt(cosfac2)
6234         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6235         sinfac=dsqrt(sinfac2)
6236         it=iabs(itype(i))
6237         if (it.eq.10) goto 1
6238 c
6239 C  Compute the axes of tghe local cartesian coordinates system; store in
6240 c   x_prime, y_prime and z_prime
6241 c
6242         do j=1,3
6243           x_prime(j) = 0.00
6244           y_prime(j) = 0.00
6245           z_prime(j) = 0.00
6246         enddo
6247 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6248 C     &   dc_norm(3,i+nres)
6249         do j = 1,3
6250           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6251           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6252         enddo
6253         do j = 1,3
6254           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6255         enddo
6256 c       write (2,*) "i",i
6257 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6258 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6259 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6260 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6261 c      & " xy",scalar(x_prime(1),y_prime(1)),
6262 c      & " xz",scalar(x_prime(1),z_prime(1)),
6263 c      & " yy",scalar(y_prime(1),y_prime(1)),
6264 c      & " yz",scalar(y_prime(1),z_prime(1)),
6265 c      & " zz",scalar(z_prime(1),z_prime(1))
6266 c
6267 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6268 C to local coordinate system. Store in xx, yy, zz.
6269 c
6270         xx=0.0d0
6271         yy=0.0d0
6272         zz=0.0d0
6273         do j = 1,3
6274           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6275           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6276           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6277         enddo
6278
6279         xxtab(i)=xx
6280         yytab(i)=yy
6281         zztab(i)=zz
6282 C
6283 C Compute the energy of the ith side cbain
6284 C
6285 c        write (2,*) "xx",xx," yy",yy," zz",zz
6286         it=iabs(itype(i))
6287         do j = 1,65
6288           x(j) = sc_parmin(j,it)
6289         enddo
6290 #ifdef CHECK_COORD
6291 Cc diagnostics - remove later
6292         xx1 = dcos(alph(2))
6293         yy1 = dsin(alph(2))*dcos(omeg(2))
6294         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6295         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6296      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6297      &    xx1,yy1,zz1
6298 C,"  --- ", xx_w,yy_w,zz_w
6299 c end diagnostics
6300 #endif
6301         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6302      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6303      &   + x(10)*yy*zz
6304         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6305      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6306      & + x(20)*yy*zz
6307         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6308      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6309      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6310      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6311      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6312      &  +x(40)*xx*yy*zz
6313         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6314      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6315      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6316      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6317      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6318      &  +x(60)*xx*yy*zz
6319         dsc_i   = 0.743d0+x(61)
6320         dp2_i   = 1.9d0+x(62)
6321         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6322      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6323         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6324      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6325         s1=(1+x(63))/(0.1d0 + dscp1)
6326         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6327         s2=(1+x(65))/(0.1d0 + dscp2)
6328         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6329         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6330      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6331 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6332 c     &   sumene4,
6333 c     &   dscp1,dscp2,sumene
6334 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6335         escloc = escloc + sumene
6336         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6337      &     'escloc',i,sumene
6338 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6339 c     & ,zz,xx,yy
6340 c#define DEBUG
6341 #ifdef DEBUG
6342 C
6343 C This section to check the numerical derivatives of the energy of ith side
6344 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6345 C #define DEBUG in the code to turn it on.
6346 C
6347         write (2,*) "sumene               =",sumene
6348         aincr=1.0d-7
6349         xxsave=xx
6350         xx=xx+aincr
6351         write (2,*) xx,yy,zz
6352         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6353         de_dxx_num=(sumenep-sumene)/aincr
6354         xx=xxsave
6355         write (2,*) "xx+ sumene from enesc=",sumenep
6356         yysave=yy
6357         yy=yy+aincr
6358         write (2,*) xx,yy,zz
6359         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6360         de_dyy_num=(sumenep-sumene)/aincr
6361         yy=yysave
6362         write (2,*) "yy+ sumene from enesc=",sumenep
6363         zzsave=zz
6364         zz=zz+aincr
6365         write (2,*) xx,yy,zz
6366         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6367         de_dzz_num=(sumenep-sumene)/aincr
6368         zz=zzsave
6369         write (2,*) "zz+ sumene from enesc=",sumenep
6370         costsave=cost2tab(i+1)
6371         sintsave=sint2tab(i+1)
6372         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6373         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6374         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6375         de_dt_num=(sumenep-sumene)/aincr
6376         write (2,*) " t+ sumene from enesc=",sumenep
6377         cost2tab(i+1)=costsave
6378         sint2tab(i+1)=sintsave
6379 C End of diagnostics section.
6380 #endif
6381 C
6382 C Compute the gradient of esc
6383 C
6384 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6385         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6386         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6387         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6388         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6389         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6390         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6391         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6392         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6393         pom1=(sumene3*sint2tab(i+1)+sumene1)
6394      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6395         pom2=(sumene4*cost2tab(i+1)+sumene2)
6396      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6397         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6398         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6399      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6400      &  +x(40)*yy*zz
6401         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6402         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6403      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6404      &  +x(60)*yy*zz
6405         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6406      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6407      &        +(pom1+pom2)*pom_dx
6408 #ifdef DEBUG
6409         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6410 #endif
6411 C
6412         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6413         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6414      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6415      &  +x(40)*xx*zz
6416         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6417         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6418      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6419      &  +x(59)*zz**2 +x(60)*xx*zz
6420         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6421      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6422      &        +(pom1-pom2)*pom_dy
6423 #ifdef DEBUG
6424         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6425 #endif
6426 C
6427         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6428      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6429      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6430      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6431      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6432      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6433      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6434      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6435 #ifdef DEBUG
6436         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6437 #endif
6438 C
6439         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6440      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6441      &  +pom1*pom_dt1+pom2*pom_dt2
6442 #ifdef DEBUG
6443         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6444 #endif
6445 c#undef DEBUG
6446 c
6447 C
6448        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6449        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6450        cosfac2xx=cosfac2*xx
6451        sinfac2yy=sinfac2*yy
6452        do k = 1,3
6453          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6454      &      vbld_inv(i+1)
6455          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6456      &      vbld_inv(i)
6457          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6458          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6459 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6460 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6461 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6462 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6463          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6464          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6465          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6466          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6467          dZZ_Ci1(k)=0.0d0
6468          dZZ_Ci(k)=0.0d0
6469          do j=1,3
6470            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6471      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6472            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6473      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6474          enddo
6475
6476          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6477          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6478          dZZ_XYZ(k)=vbld_inv(i+nres)*
6479      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6480 c
6481          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6482          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6483        enddo
6484
6485        do k=1,3
6486          dXX_Ctab(k,i)=dXX_Ci(k)
6487          dXX_C1tab(k,i)=dXX_Ci1(k)
6488          dYY_Ctab(k,i)=dYY_Ci(k)
6489          dYY_C1tab(k,i)=dYY_Ci1(k)
6490          dZZ_Ctab(k,i)=dZZ_Ci(k)
6491          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6492          dXX_XYZtab(k,i)=dXX_XYZ(k)
6493          dYY_XYZtab(k,i)=dYY_XYZ(k)
6494          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6495        enddo
6496
6497        do k = 1,3
6498 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6499 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6500 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6501 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6502 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6503 c     &    dt_dci(k)
6504 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6505 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6506          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6507      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6508          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6509      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6510          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6511      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6512        enddo
6513 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6514 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6515
6516 C to check gradient call subroutine check_grad
6517
6518     1 continue
6519       enddo
6520       return
6521       end
6522 c------------------------------------------------------------------------------
6523       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6524       implicit none
6525       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6526      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6527       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6528      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6529      &   + x(10)*yy*zz
6530       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6531      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6532      & + x(20)*yy*zz
6533       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6534      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6535      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6536      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6537      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6538      &  +x(40)*xx*yy*zz
6539       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6540      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6541      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6542      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6543      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6544      &  +x(60)*xx*yy*zz
6545       dsc_i   = 0.743d0+x(61)
6546       dp2_i   = 1.9d0+x(62)
6547       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6548      &          *(xx*cost2+yy*sint2))
6549       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6550      &          *(xx*cost2-yy*sint2))
6551       s1=(1+x(63))/(0.1d0 + dscp1)
6552       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6553       s2=(1+x(65))/(0.1d0 + dscp2)
6554       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6555       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6556      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6557       enesc=sumene
6558       return
6559       end
6560 #endif
6561 c------------------------------------------------------------------------------
6562       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6563 C
6564 C This procedure calculates two-body contact function g(rij) and its derivative:
6565 C
6566 C           eps0ij                                     !       x < -1
6567 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6568 C            0                                         !       x > 1
6569 C
6570 C where x=(rij-r0ij)/delta
6571 C
6572 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6573 C
6574       implicit none
6575       double precision rij,r0ij,eps0ij,fcont,fprimcont
6576       double precision x,x2,x4,delta
6577 c     delta=0.02D0*r0ij
6578 c      delta=0.2D0*r0ij
6579       x=(rij-r0ij)/delta
6580       if (x.lt.-1.0D0) then
6581         fcont=eps0ij
6582         fprimcont=0.0D0
6583       else if (x.le.1.0D0) then
6584         x2=x*x
6585         x4=x2*x2
6586         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6587         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6588       else
6589         fcont=0.0D0
6590         fprimcont=0.0D0
6591       endif
6592       return
6593       end
6594 c------------------------------------------------------------------------------
6595       subroutine splinthet(theti,delta,ss,ssder)
6596       implicit real*8 (a-h,o-z)
6597       include 'DIMENSIONS'
6598       include 'COMMON.VAR'
6599       include 'COMMON.GEO'
6600       thetup=pi-delta
6601       thetlow=delta
6602       if (theti.gt.pipol) then
6603         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6604       else
6605         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6606         ssder=-ssder
6607       endif
6608       return
6609       end
6610 c------------------------------------------------------------------------------
6611       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6612       implicit none
6613       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6614       double precision ksi,ksi2,ksi3,a1,a2,a3
6615       a1=fprim0*delta/(f1-f0)
6616       a2=3.0d0-2.0d0*a1
6617       a3=a1-2.0d0
6618       ksi=(x-x0)/delta
6619       ksi2=ksi*ksi
6620       ksi3=ksi2*ksi
6621       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6622       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6623       return
6624       end
6625 c------------------------------------------------------------------------------
6626       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6627       implicit none
6628       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6629       double precision ksi,ksi2,ksi3,a1,a2,a3
6630       ksi=(x-x0)/delta
6631       ksi2=ksi*ksi
6632       ksi3=ksi2*ksi
6633       a1=fprim0x*delta
6634       a2=3*(f1x-f0x)-2*fprim0x*delta
6635       a3=fprim0x*delta-2*(f1x-f0x)
6636       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6637       return
6638       end
6639 C-----------------------------------------------------------------------------
6640 #ifdef CRYST_TOR
6641 C-----------------------------------------------------------------------------
6642       subroutine etor(etors,edihcnstr)
6643       implicit real*8 (a-h,o-z)
6644       include 'DIMENSIONS'
6645       include 'COMMON.VAR'
6646       include 'COMMON.GEO'
6647       include 'COMMON.LOCAL'
6648       include 'COMMON.TORSION'
6649       include 'COMMON.INTERACT'
6650       include 'COMMON.DERIV'
6651       include 'COMMON.CHAIN'
6652       include 'COMMON.NAMES'
6653       include 'COMMON.IOUNITS'
6654       include 'COMMON.FFIELD'
6655       include 'COMMON.TORCNSTR'
6656       include 'COMMON.CONTROL'
6657       logical lprn
6658 C Set lprn=.true. for debugging
6659       lprn=.false.
6660 c      lprn=.true.
6661       etors=0.0D0
6662       do i=iphi_start,iphi_end
6663       etors_ii=0.0D0
6664         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6665      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6666         itori=itortyp(itype(i-2))
6667         itori1=itortyp(itype(i-1))
6668         phii=phi(i)
6669         gloci=0.0D0
6670 C Proline-Proline pair is a special case...
6671         if (itori.eq.3 .and. itori1.eq.3) then
6672           if (phii.gt.-dwapi3) then
6673             cosphi=dcos(3*phii)
6674             fac=1.0D0/(1.0D0-cosphi)
6675             etorsi=v1(1,3,3)*fac
6676             etorsi=etorsi+etorsi
6677             etors=etors+etorsi-v1(1,3,3)
6678             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6679             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6680           endif
6681           do j=1,3
6682             v1ij=v1(j+1,itori,itori1)
6683             v2ij=v2(j+1,itori,itori1)
6684             cosphi=dcos(j*phii)
6685             sinphi=dsin(j*phii)
6686             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6687             if (energy_dec) etors_ii=etors_ii+
6688      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6689             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6690           enddo
6691         else
6692           do j=1,nterm_old
6693             v1ij=v1(j,itori,itori1)
6694             v2ij=v2(j,itori,itori1)
6695             cosphi=dcos(j*phii)
6696             sinphi=dsin(j*phii)
6697             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6698             if (energy_dec) etors_ii=etors_ii+
6699      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6700             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6701           enddo
6702         endif
6703         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6704              'etor',i,etors_ii
6705         if (lprn)
6706      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6707      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6708      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6709         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6710 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6711       enddo
6712 ! 6/20/98 - dihedral angle constraints
6713       edihcnstr=0.0d0
6714       do i=1,ndih_constr
6715         itori=idih_constr(i)
6716         phii=phi(itori)
6717         difi=phii-phi0(i)
6718         if (difi.gt.drange(i)) then
6719           difi=difi-drange(i)
6720           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6721           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6722         else if (difi.lt.-drange(i)) then
6723           difi=difi+drange(i)
6724           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6725           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6726         endif
6727 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6728 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6729       enddo
6730 !      write (iout,*) 'edihcnstr',edihcnstr
6731       return
6732       end
6733 c------------------------------------------------------------------------------
6734 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6735       subroutine e_modeller(ehomology_constr)
6736       ehomology_constr=0.0d0
6737       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6738       return
6739       end
6740 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6741
6742 c------------------------------------------------------------------------------
6743       subroutine etor_d(etors_d)
6744       etors_d=0.0d0
6745       return
6746       end
6747 c----------------------------------------------------------------------------
6748 #else
6749       subroutine etor(etors,edihcnstr)
6750       implicit real*8 (a-h,o-z)
6751       include 'DIMENSIONS'
6752       include 'COMMON.VAR'
6753       include 'COMMON.GEO'
6754       include 'COMMON.LOCAL'
6755       include 'COMMON.TORSION'
6756       include 'COMMON.INTERACT'
6757       include 'COMMON.DERIV'
6758       include 'COMMON.CHAIN'
6759       include 'COMMON.NAMES'
6760       include 'COMMON.IOUNITS'
6761       include 'COMMON.FFIELD'
6762       include 'COMMON.TORCNSTR'
6763       include 'COMMON.CONTROL'
6764       logical lprn
6765 C Set lprn=.true. for debugging
6766       lprn=.false.
6767 c     lprn=.true.
6768       etors=0.0D0
6769       do i=iphi_start,iphi_end
6770 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6771 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6772 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6773 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6774         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6775      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6776 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6777 C For introducing the NH3+ and COO- group please check the etor_d for reference
6778 C and guidance
6779         etors_ii=0.0D0
6780          if (iabs(itype(i)).eq.20) then
6781          iblock=2
6782          else
6783          iblock=1
6784          endif
6785         itori=itortyp(itype(i-2))
6786         itori1=itortyp(itype(i-1))
6787         phii=phi(i)
6788         gloci=0.0D0
6789 C Regular cosine and sine terms
6790         do j=1,nterm(itori,itori1,iblock)
6791           v1ij=v1(j,itori,itori1,iblock)
6792           v2ij=v2(j,itori,itori1,iblock)
6793           cosphi=dcos(j*phii)
6794           sinphi=dsin(j*phii)
6795           etors=etors+v1ij*cosphi+v2ij*sinphi
6796           if (energy_dec) etors_ii=etors_ii+
6797      &                v1ij*cosphi+v2ij*sinphi
6798           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6799         enddo
6800 C Lorentz terms
6801 C                         v1
6802 C  E = SUM ----------------------------------- - v1
6803 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6804 C
6805         cosphi=dcos(0.5d0*phii)
6806         sinphi=dsin(0.5d0*phii)
6807         do j=1,nlor(itori,itori1,iblock)
6808           vl1ij=vlor1(j,itori,itori1)
6809           vl2ij=vlor2(j,itori,itori1)
6810           vl3ij=vlor3(j,itori,itori1)
6811           pom=vl2ij*cosphi+vl3ij*sinphi
6812           pom1=1.0d0/(pom*pom+1.0d0)
6813           etors=etors+vl1ij*pom1
6814           if (energy_dec) etors_ii=etors_ii+
6815      &                vl1ij*pom1
6816           pom=-pom*pom1*pom1
6817           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6818         enddo
6819 C Subtract the constant term
6820         etors=etors-v0(itori,itori1,iblock)
6821           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6822      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6823         if (lprn)
6824      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6825      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6826      &  (v1(j,itori,itori1,iblock),j=1,6),
6827      &  (v2(j,itori,itori1,iblock),j=1,6)
6828         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6829 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6830       enddo
6831 ! 6/20/98 - dihedral angle constraints
6832       edihcnstr=0.0d0
6833 c      do i=1,ndih_constr
6834       do i=idihconstr_start,idihconstr_end
6835         itori=idih_constr(i)
6836         phii=phi(itori)
6837         difi=pinorm(phii-phi0(i))
6838         if (difi.gt.drange(i)) then
6839           difi=difi-drange(i)
6840           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6841           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6842         else if (difi.lt.-drange(i)) then
6843           difi=difi+drange(i)
6844           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6845           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6846         else
6847           difi=0.0
6848         endif
6849 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6850 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6851 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6852       enddo
6853 cd       write (iout,*) 'edihcnstr',edihcnstr
6854       return
6855       end
6856 c----------------------------------------------------------------------------
6857 c MODELLER restraint function
6858       subroutine e_modeller(ehomology_constr)
6859       implicit real*8 (a-h,o-z)
6860       include 'DIMENSIONS'
6861
6862       integer nnn, i, j, k, ki, irec, l
6863       integer katy, odleglosci, test7
6864       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6865       real*8 Eval,Erot
6866       real*8 distance(max_template),distancek(max_template),
6867      &    min_odl,godl(max_template),dih_diff(max_template)
6868
6869 c
6870 c     FP - 30/10/2014 Temporary specifications for homology restraints
6871 c
6872       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6873      &                 sgtheta
6874       double precision, dimension (maxres) :: guscdiff,usc_diff
6875       double precision, dimension (max_template) ::
6876      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6877      &           theta_diff
6878 c
6879
6880       include 'COMMON.SBRIDGE'
6881       include 'COMMON.CHAIN'
6882       include 'COMMON.GEO'
6883       include 'COMMON.DERIV'
6884       include 'COMMON.LOCAL'
6885       include 'COMMON.INTERACT'
6886       include 'COMMON.VAR'
6887       include 'COMMON.IOUNITS'
6888       include 'COMMON.MD'
6889       include 'COMMON.CONTROL'
6890 c
6891 c     From subroutine Econstr_back
6892 c
6893       include 'COMMON.NAMES'
6894       include 'COMMON.TIME1'
6895 c
6896
6897
6898       do i=1,max_template
6899         distancek(i)=9999999.9
6900       enddo
6901
6902
6903       odleg=0.0d0
6904
6905 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6906 c function)
6907 C AL 5/2/14 - Introduce list of restraints
6908 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6909 #ifdef DEBUG
6910       write(iout,*) "------- dist restrs start -------"
6911 #endif
6912       do ii = link_start_homo,link_end_homo
6913          i = ires_homo(ii)
6914          j = jres_homo(ii)
6915          dij=dist(i,j)
6916 c        write (iout,*) "dij(",i,j,") =",dij
6917          nexl=0
6918          do k=1,constr_homology
6919 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6920            if(.not.l_homo(k,ii)) then
6921              nexl=nexl+1
6922              cycle
6923            endif
6924            distance(k)=odl(k,ii)-dij
6925 c          write (iout,*) "distance(",k,") =",distance(k)
6926 c
6927 c          For Gaussian-type Urestr
6928 c
6929            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6930 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6931 c          write (iout,*) "distancek(",k,") =",distancek(k)
6932 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6933 c
6934 c          For Lorentzian-type Urestr
6935 c
6936            if (waga_dist.lt.0.0d0) then
6937               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6938               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6939      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6940            endif
6941          enddo
6942
6943 c         min_odl=minval(distancek)
6944          do kk=1,constr_homology
6945           if(l_homo(kk,ii)) then
6946             min_odl=distancek(kk)
6947             exit
6948           endif
6949          enddo
6950          do kk=1,constr_homology
6951           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6952      &              min_odl=distancek(kk)
6953          enddo
6954
6955 c        write (iout,* )"min_odl",min_odl
6956 #ifdef DEBUG
6957          write (iout,*) "ij dij",i,j,dij
6958          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6959          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6960          write (iout,* )"min_odl",min_odl
6961 #endif
6962 #ifdef OLDRESTR
6963          odleg2=0.0d0
6964 #else
6965          if (waga_dist.ge.0.0d0) then
6966            odleg2=nexl
6967          else
6968            odleg2=0.0d0
6969          endif
6970 #endif
6971          do k=1,constr_homology
6972 c Nie wiem po co to liczycie jeszcze raz!
6973 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6974 c     &              (2*(sigma_odl(i,j,k))**2))
6975            if(.not.l_homo(k,ii)) cycle
6976            if (waga_dist.ge.0.0d0) then
6977 c
6978 c          For Gaussian-type Urestr
6979 c
6980             godl(k)=dexp(-distancek(k)+min_odl)
6981             odleg2=odleg2+godl(k)
6982 c
6983 c          For Lorentzian-type Urestr
6984 c
6985            else
6986             odleg2=odleg2+distancek(k)
6987            endif
6988
6989 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6990 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6991 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6992 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6993
6994          enddo
6995 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6996 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6997 #ifdef DEBUG
6998          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6999          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7000 #endif
7001            if (waga_dist.ge.0.0d0) then
7002 c
7003 c          For Gaussian-type Urestr
7004 c
7005               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7006 c
7007 c          For Lorentzian-type Urestr
7008 c
7009            else
7010               odleg=odleg+odleg2/constr_homology
7011            endif
7012 c
7013 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7014 c Gradient
7015 c
7016 c          For Gaussian-type Urestr
7017 c
7018          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7019          sum_sgodl=0.0d0
7020          do k=1,constr_homology
7021 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7022 c     &           *waga_dist)+min_odl
7023 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7024 c
7025          if(.not.l_homo(k,ii)) cycle
7026          if (waga_dist.ge.0.0d0) then
7027 c          For Gaussian-type Urestr
7028 c
7029            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7030 c
7031 c          For Lorentzian-type Urestr
7032 c
7033          else
7034            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7035      &           sigma_odlir(k,ii)**2)**2)
7036          endif
7037            sum_sgodl=sum_sgodl+sgodl
7038
7039 c            sgodl2=sgodl2+sgodl
7040 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7041 c      write(iout,*) "constr_homology=",constr_homology
7042 c      write(iout,*) i, j, k, "TEST K"
7043          enddo
7044          if (waga_dist.ge.0.0d0) then
7045 c
7046 c          For Gaussian-type Urestr
7047 c
7048             grad_odl3=waga_homology(iset)*waga_dist
7049      &                *sum_sgodl/(sum_godl*dij)
7050 c
7051 c          For Lorentzian-type Urestr
7052 c
7053          else
7054 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7055 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7056             grad_odl3=-waga_homology(iset)*waga_dist*
7057      &                sum_sgodl/(constr_homology*dij)
7058          endif
7059 c
7060 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7061
7062
7063 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7064 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7065 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7066
7067 ccc      write(iout,*) godl, sgodl, grad_odl3
7068
7069 c          grad_odl=grad_odl+grad_odl3
7070
7071          do jik=1,3
7072             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7073 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7074 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7075 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7076             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7077             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7078 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7079 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7080 c         if (i.eq.25.and.j.eq.27) then
7081 c         write(iout,*) "jik",jik,"i",i,"j",j
7082 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7083 c         write(iout,*) "grad_odl3",grad_odl3
7084 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7085 c         write(iout,*) "ggodl",ggodl
7086 c         write(iout,*) "ghpbc(",jik,i,")",
7087 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7088 c     &                 ghpbc(jik,j)
7089 c         endif
7090          enddo
7091 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7092 ccc     & dLOG(odleg2),"-odleg=", -odleg
7093
7094       enddo ! ii-loop for dist
7095 #ifdef DEBUG
7096       write(iout,*) "------- dist restrs end -------"
7097 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7098 c    &     waga_d.eq.1.0d0) call sum_gradient
7099 #endif
7100 c Pseudo-energy and gradient from dihedral-angle restraints from
7101 c homology templates
7102 c      write (iout,*) "End of distance loop"
7103 c      call flush(iout)
7104       kat=0.0d0
7105 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7106 #ifdef DEBUG
7107       write(iout,*) "------- dih restrs start -------"
7108       do i=idihconstr_start_homo,idihconstr_end_homo
7109         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7110       enddo
7111 #endif
7112       do i=idihconstr_start_homo,idihconstr_end_homo
7113         kat2=0.0d0
7114 c        betai=beta(i,i+1,i+2,i+3)
7115         betai = phi(i)
7116 c       write (iout,*) "betai =",betai
7117         do k=1,constr_homology
7118           dih_diff(k)=pinorm(dih(k,i)-betai)
7119 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7120 cd     &                  ,sigma_dih(k,i)
7121 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7122 c     &                                   -(6.28318-dih_diff(i,k))
7123 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7124 c     &                                   6.28318+dih_diff(i,k)
7125 #ifdef OLD_DIHED
7126           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7127 #else
7128           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7129 #endif
7130 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7131           gdih(k)=dexp(kat3)
7132           kat2=kat2+gdih(k)
7133 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7134 c          write(*,*)""
7135         enddo
7136 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7137 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7138 #ifdef DEBUG
7139         write (iout,*) "i",i," betai",betai," kat2",kat2
7140         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7141 #endif
7142         if (kat2.le.1.0d-14) cycle
7143         kat=kat-dLOG(kat2/constr_homology)
7144 c       write (iout,*) "kat",kat ! sum of -ln-s
7145
7146 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7147 ccc     & dLOG(kat2), "-kat=", -kat
7148
7149 c ----------------------------------------------------------------------
7150 c Gradient
7151 c ----------------------------------------------------------------------
7152
7153         sum_gdih=kat2
7154         sum_sgdih=0.0d0
7155         do k=1,constr_homology
7156 #ifdef OLD_DIHED
7157           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7158 #else
7159           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7160 #endif
7161 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7162           sum_sgdih=sum_sgdih+sgdih
7163         enddo
7164 c       grad_dih3=sum_sgdih/sum_gdih
7165         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7166
7167 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7168 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7169 ccc     & gloc(nphi+i-3,icg)
7170         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7171 c        if (i.eq.25) then
7172 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7173 c        endif
7174 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7175 ccc     & gloc(nphi+i-3,icg)
7176
7177       enddo ! i-loop for dih
7178 #ifdef DEBUG
7179       write(iout,*) "------- dih restrs end -------"
7180 #endif
7181
7182 c Pseudo-energy and gradient for theta angle restraints from
7183 c homology templates
7184 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7185 c adapted
7186
7187 c
7188 c     For constr_homology reference structures (FP)
7189 c
7190 c     Uconst_back_tot=0.0d0
7191       Eval=0.0d0
7192       Erot=0.0d0
7193 c     Econstr_back legacy
7194       do i=1,nres
7195 c     do i=ithet_start,ithet_end
7196        dutheta(i)=0.0d0
7197 c     enddo
7198 c     do i=loc_start,loc_end
7199         do j=1,3
7200           duscdiff(j,i)=0.0d0
7201           duscdiffx(j,i)=0.0d0
7202         enddo
7203       enddo
7204 c
7205 c     do iref=1,nref
7206 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7207 c     write (iout,*) "waga_theta",waga_theta
7208       if (waga_theta.gt.0.0d0) then
7209 #ifdef DEBUG
7210       write (iout,*) "usampl",usampl
7211       write(iout,*) "------- theta restrs start -------"
7212 c     do i=ithet_start,ithet_end
7213 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7214 c     enddo
7215 #endif
7216 c     write (iout,*) "maxres",maxres,"nres",nres
7217
7218       do i=ithet_start,ithet_end
7219 c
7220 c     do i=1,nfrag_back
7221 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7222 c
7223 c Deviation of theta angles wrt constr_homology ref structures
7224 c
7225         utheta_i=0.0d0 ! argument of Gaussian for single k
7226         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7227 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7228 c       over residues in a fragment
7229 c       write (iout,*) "theta(",i,")=",theta(i)
7230         do k=1,constr_homology
7231 c
7232 c         dtheta_i=theta(j)-thetaref(j,iref)
7233 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7234           theta_diff(k)=thetatpl(k,i)-theta(i)
7235 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7236 cd     &                  ,sigma_theta(k,i)
7237
7238 c
7239           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7240 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7241           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7242           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7243 c         Gradient for single Gaussian restraint in subr Econstr_back
7244 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7245 c
7246         enddo
7247 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7248 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7249
7250 c
7251 c         Gradient for multiple Gaussian restraint
7252         sum_gtheta=gutheta_i
7253         sum_sgtheta=0.0d0
7254         do k=1,constr_homology
7255 c        New generalized expr for multiple Gaussian from Econstr_back
7256          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7257 c
7258 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7259           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7260         enddo
7261 c       Final value of gradient using same var as in Econstr_back
7262         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7263      &      +sum_sgtheta/sum_gtheta*waga_theta
7264      &               *waga_homology(iset)
7265 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7266 c     &               *waga_homology(iset)
7267 c       dutheta(i)=sum_sgtheta/sum_gtheta
7268 c
7269 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7270         Eval=Eval-dLOG(gutheta_i/constr_homology)
7271 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7272 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7273 c       Uconst_back=Uconst_back+utheta(i)
7274       enddo ! (i-loop for theta)
7275 #ifdef DEBUG
7276       write(iout,*) "------- theta restrs end -------"
7277 #endif
7278       endif
7279 c
7280 c Deviation of local SC geometry
7281 c
7282 c Separation of two i-loops (instructed by AL - 11/3/2014)
7283 c
7284 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7285 c     write (iout,*) "waga_d",waga_d
7286
7287 #ifdef DEBUG
7288       write(iout,*) "------- SC restrs start -------"
7289       write (iout,*) "Initial duscdiff,duscdiffx"
7290       do i=loc_start,loc_end
7291         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7292      &                 (duscdiffx(jik,i),jik=1,3)
7293       enddo
7294 #endif
7295       do i=loc_start,loc_end
7296         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7297         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7298 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7299 c       write(iout,*) "xxtab, yytab, zztab"
7300 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7301         do k=1,constr_homology
7302 c
7303           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7304 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7305           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7306           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7307 c         write(iout,*) "dxx, dyy, dzz"
7308 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
7309 c
7310           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7311 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7312 c         uscdiffk(k)=usc_diff(i)
7313           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7314 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
7315 c     &       " guscdiff2",guscdiff2(k)
7316           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
7317 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7318 c     &      xxref(j),yyref(j),zzref(j)
7319         enddo
7320 c
7321 c       Gradient
7322 c
7323 c       Generalized expression for multiple Gaussian acc to that for a single
7324 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7325 c
7326 c       Original implementation
7327 c       sum_guscdiff=guscdiff(i)
7328 c
7329 c       sum_sguscdiff=0.0d0
7330 c       do k=1,constr_homology
7331 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7332 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7333 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7334 c       enddo
7335 c
7336 c       Implementation of new expressions for gradient (Jan. 2015)
7337 c
7338 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7339         do k=1,constr_homology
7340 c
7341 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7342 c       before. Now the drivatives should be correct
7343 c
7344           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7345 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7346           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7347           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7348 c
7349 c         New implementation
7350 c
7351           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7352      &                 sigma_d(k,i) ! for the grad wrt r'
7353 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7354 c
7355 c
7356 c        New implementation
7357          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7358          do jik=1,3
7359             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7360      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7361      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7362             duscdiff(jik,i)=duscdiff(jik,i)+
7363      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7364      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7365             duscdiffx(jik,i)=duscdiffx(jik,i)+
7366      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7367      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7368 c
7369 #ifdef DEBUG
7370              write(iout,*) "jik",jik,"i",i
7371              write(iout,*) "dxx, dyy, dzz"
7372              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7373              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7374 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7375 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7376 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7377 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7378 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7379 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7380 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7381 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7382 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7383 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7384 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7385 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7386 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7387 c            endif
7388 #endif
7389          enddo
7390         enddo
7391 c
7392 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7393 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7394 c
7395 c        write (iout,*) i," uscdiff",uscdiff(i)
7396 c
7397 c Put together deviations from local geometry
7398
7399 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7400 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7401         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7402 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7403 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7404 c       Uconst_back=Uconst_back+usc_diff(i)
7405 c
7406 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7407 c
7408 c     New implment: multiplied by sum_sguscdiff
7409 c
7410
7411       enddo ! (i-loop for dscdiff)
7412
7413 c      endif
7414
7415 #ifdef DEBUG
7416       write(iout,*) "------- SC restrs end -------"
7417         write (iout,*) "------ After SC loop in e_modeller ------"
7418         do i=loc_start,loc_end
7419          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7420          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7421         enddo
7422       if (waga_theta.eq.1.0d0) then
7423       write (iout,*) "in e_modeller after SC restr end: dutheta"
7424       do i=ithet_start,ithet_end
7425         write (iout,*) i,dutheta(i)
7426       enddo
7427       endif
7428       if (waga_d.eq.1.0d0) then
7429       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7430       do i=1,nres
7431         write (iout,*) i,(duscdiff(j,i),j=1,3)
7432         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7433       enddo
7434       endif
7435 #endif
7436
7437 c Total energy from homology restraints
7438 #ifdef DEBUG
7439       write (iout,*) "odleg",odleg," kat",kat
7440 #endif
7441 c
7442 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7443 c
7444 c     ehomology_constr=odleg+kat
7445 c
7446 c     For Lorentzian-type Urestr
7447 c
7448
7449       if (waga_dist.ge.0.0d0) then
7450 c
7451 c          For Gaussian-type Urestr
7452 c
7453         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7454      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7455 c     write (iout,*) "ehomology_constr=",ehomology_constr
7456       else
7457 c
7458 c          For Lorentzian-type Urestr
7459 c
7460         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7461      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7462 c     write (iout,*) "ehomology_constr=",ehomology_constr
7463       endif
7464 #ifdef DEBUG
7465       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7466      & "Eval",waga_theta,eval,
7467      &   "Erot",waga_d,Erot
7468       write (iout,*) "ehomology_constr",ehomology_constr
7469 #endif
7470       return
7471 c
7472 c FP 01/15 end
7473 c
7474   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7475   747 format(a12,i4,i4,i4,f8.3,f8.3)
7476   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7477   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7478   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7479      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7480       end
7481
7482 c------------------------------------------------------------------------------
7483       subroutine etor_d(etors_d)
7484 C 6/23/01 Compute double torsional energy
7485       implicit real*8 (a-h,o-z)
7486       include 'DIMENSIONS'
7487       include 'COMMON.VAR'
7488       include 'COMMON.GEO'
7489       include 'COMMON.LOCAL'
7490       include 'COMMON.TORSION'
7491       include 'COMMON.INTERACT'
7492       include 'COMMON.DERIV'
7493       include 'COMMON.CHAIN'
7494       include 'COMMON.NAMES'
7495       include 'COMMON.IOUNITS'
7496       include 'COMMON.FFIELD'
7497       include 'COMMON.TORCNSTR'
7498       include 'COMMON.CONTROL'
7499       logical lprn
7500 C Set lprn=.true. for debugging
7501       lprn=.false.
7502 c     lprn=.true.
7503       etors_d=0.0D0
7504 c      write(iout,*) "a tu??"
7505       do i=iphid_start,iphid_end
7506 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7507 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7508 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7509 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7510 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7511          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7512      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7513      &  (itype(i+1).eq.ntyp1)) cycle
7514 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7515         etors_d_ii=0.0D0
7516         itori=itortyp(itype(i-2))
7517         itori1=itortyp(itype(i-1))
7518         itori2=itortyp(itype(i))
7519         phii=phi(i)
7520         phii1=phi(i+1)
7521         gloci1=0.0D0
7522         gloci2=0.0D0
7523         iblock=1
7524         if (iabs(itype(i+1)).eq.20) iblock=2
7525 C Iblock=2 Proline type
7526 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7527 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7528 C        if (itype(i+1).eq.ntyp1) iblock=3
7529 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7530 C IS or IS NOT need for this
7531 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7532 C        is (itype(i-3).eq.ntyp1) ntblock=2
7533 C        ntblock is N-terminal blocking group
7534
7535 C Regular cosine and sine terms
7536         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7537 C Example of changes for NH3+ blocking group
7538 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7539 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7540           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7541           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7542           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7543           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7544           cosphi1=dcos(j*phii)
7545           sinphi1=dsin(j*phii)
7546           cosphi2=dcos(j*phii1)
7547           sinphi2=dsin(j*phii1)
7548           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7549      &     v2cij*cosphi2+v2sij*sinphi2
7550           if (energy_dec) etors_d_ii=etors_d_ii+
7551      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7552           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7553           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7554         enddo
7555         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7556           do l=1,k-1
7557             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7558             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7559             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7560             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7561             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7562             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7563             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7564             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7565             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7566      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7567             if (energy_dec) etors_d_ii=etors_d_ii+
7568      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7569      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7570             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7571      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7572             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7573      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7574           enddo
7575         enddo
7576           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7577      &         'etor_d',i,etors_d_ii
7578         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7579         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7580       enddo
7581       return
7582       end
7583 #endif
7584 c------------------------------------------------------------------------------
7585       subroutine eback_sc_corr(esccor)
7586 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7587 c        conformational states; temporarily implemented as differences
7588 c        between UNRES torsional potentials (dependent on three types of
7589 c        residues) and the torsional potentials dependent on all 20 types
7590 c        of residues computed from AM1  energy surfaces of terminally-blocked
7591 c        amino-acid residues.
7592       implicit real*8 (a-h,o-z)
7593       include 'DIMENSIONS'
7594       include 'COMMON.VAR'
7595       include 'COMMON.GEO'
7596       include 'COMMON.LOCAL'
7597       include 'COMMON.TORSION'
7598       include 'COMMON.SCCOR'
7599       include 'COMMON.INTERACT'
7600       include 'COMMON.DERIV'
7601       include 'COMMON.CHAIN'
7602       include 'COMMON.NAMES'
7603       include 'COMMON.IOUNITS'
7604       include 'COMMON.FFIELD'
7605       include 'COMMON.CONTROL'
7606       logical lprn
7607 C Set lprn=.true. for debugging
7608       lprn=.false.
7609 c      lprn=.true.
7610 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7611       esccor=0.0D0
7612       do i=itau_start,itau_end
7613         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7614         isccori=isccortyp(itype(i-2))
7615         isccori1=isccortyp(itype(i-1))
7616 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7617         phii=phi(i)
7618         do intertyp=1,3 !intertyp
7619          esccor_ii=0.0D0
7620 cc Added 09 May 2012 (Adasko)
7621 cc  Intertyp means interaction type of backbone mainchain correlation:
7622 c   1 = SC...Ca...Ca...Ca
7623 c   2 = Ca...Ca...Ca...SC
7624 c   3 = SC...Ca...Ca...SCi
7625         gloci=0.0D0
7626         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7627      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7628      &      (itype(i-1).eq.ntyp1)))
7629      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7630      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7631      &     .or.(itype(i).eq.ntyp1)))
7632      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7633      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7634      &      (itype(i-3).eq.ntyp1)))) cycle
7635         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7636         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7637      & cycle
7638        do j=1,nterm_sccor(isccori,isccori1)
7639           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7640           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7641           cosphi=dcos(j*tauangle(intertyp,i))
7642           sinphi=dsin(j*tauangle(intertyp,i))
7643           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7644           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7645           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7646         enddo
7647          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
7648      &         'esccor',i,intertyp,esccor_ii
7649 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7650         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7651         if (lprn)
7652      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7653      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7654      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7655      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7656         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7657        enddo !intertyp
7658       enddo
7659
7660       return
7661       end
7662 c----------------------------------------------------------------------------
7663       subroutine multibody(ecorr)
7664 C This subroutine calculates multi-body contributions to energy following
7665 C the idea of Skolnick et al. If side chains I and J make a contact and
7666 C at the same time side chains I+1 and J+1 make a contact, an extra
7667 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7668       implicit real*8 (a-h,o-z)
7669       include 'DIMENSIONS'
7670       include 'COMMON.IOUNITS'
7671       include 'COMMON.DERIV'
7672       include 'COMMON.INTERACT'
7673       include 'COMMON.CONTACTS'
7674       double precision gx(3),gx1(3)
7675       logical lprn
7676
7677 C Set lprn=.true. for debugging
7678       lprn=.false.
7679
7680       if (lprn) then
7681         write (iout,'(a)') 'Contact function values:'
7682         do i=nnt,nct-2
7683           write (iout,'(i2,20(1x,i2,f10.5))')
7684      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7685         enddo
7686       endif
7687       ecorr=0.0D0
7688       do i=nnt,nct
7689         do j=1,3
7690           gradcorr(j,i)=0.0D0
7691           gradxorr(j,i)=0.0D0
7692         enddo
7693       enddo
7694       do i=nnt,nct-2
7695
7696         DO ISHIFT = 3,4
7697
7698         i1=i+ishift
7699         num_conti=num_cont(i)
7700         num_conti1=num_cont(i1)
7701         do jj=1,num_conti
7702           j=jcont(jj,i)
7703           do kk=1,num_conti1
7704             j1=jcont(kk,i1)
7705             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7706 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7707 cd   &                   ' ishift=',ishift
7708 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7709 C The system gains extra energy.
7710               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7711             endif   ! j1==j+-ishift
7712           enddo     ! kk
7713         enddo       ! jj
7714
7715         ENDDO ! ISHIFT
7716
7717       enddo         ! i
7718       return
7719       end
7720 c------------------------------------------------------------------------------
7721       double precision function esccorr(i,j,k,l,jj,kk)
7722       implicit real*8 (a-h,o-z)
7723       include 'DIMENSIONS'
7724       include 'COMMON.IOUNITS'
7725       include 'COMMON.DERIV'
7726       include 'COMMON.INTERACT'
7727       include 'COMMON.CONTACTS'
7728       double precision gx(3),gx1(3)
7729       logical lprn
7730       lprn=.false.
7731       eij=facont(jj,i)
7732       ekl=facont(kk,k)
7733 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7734 C Calculate the multi-body contribution to energy.
7735 C Calculate multi-body contributions to the gradient.
7736 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7737 cd   & k,l,(gacont(m,kk,k),m=1,3)
7738       do m=1,3
7739         gx(m) =ekl*gacont(m,jj,i)
7740         gx1(m)=eij*gacont(m,kk,k)
7741         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7742         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7743         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7744         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7745       enddo
7746       do m=i,j-1
7747         do ll=1,3
7748           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7749         enddo
7750       enddo
7751       do m=k,l-1
7752         do ll=1,3
7753           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7754         enddo
7755       enddo
7756       esccorr=-eij*ekl
7757       return
7758       end
7759 c------------------------------------------------------------------------------
7760       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7761 C This subroutine calculates multi-body contributions to hydrogen-bonding
7762       implicit real*8 (a-h,o-z)
7763       include 'DIMENSIONS'
7764       include 'COMMON.IOUNITS'
7765 #ifdef MPI
7766       include "mpif.h"
7767       parameter (max_cont=maxconts)
7768       parameter (max_dim=26)
7769       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7770       double precision zapas(max_dim,maxconts,max_fg_procs),
7771      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7772       common /przechowalnia/ zapas
7773       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7774      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7775 #endif
7776       include 'COMMON.SETUP'
7777       include 'COMMON.FFIELD'
7778       include 'COMMON.DERIV'
7779       include 'COMMON.INTERACT'
7780       include 'COMMON.CONTACTS'
7781       include 'COMMON.CONTROL'
7782       include 'COMMON.LOCAL'
7783       double precision gx(3),gx1(3),time00
7784       logical lprn,ldone
7785
7786 C Set lprn=.true. for debugging
7787       lprn=.false.
7788 #ifdef MPI
7789       n_corr=0
7790       n_corr1=0
7791       if (nfgtasks.le.1) goto 30
7792       if (lprn) then
7793         write (iout,'(a)') 'Contact function values before RECEIVE:'
7794         do i=nnt,nct-2
7795           write (iout,'(2i3,50(1x,i2,f5.2))')
7796      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7797      &    j=1,num_cont_hb(i))
7798         enddo
7799       endif
7800       call flush(iout)
7801       do i=1,ntask_cont_from
7802         ncont_recv(i)=0
7803       enddo
7804       do i=1,ntask_cont_to
7805         ncont_sent(i)=0
7806       enddo
7807 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7808 c     & ntask_cont_to
7809 C Make the list of contacts to send to send to other procesors
7810 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7811 c      call flush(iout)
7812       do i=iturn3_start,iturn3_end
7813 c        write (iout,*) "make contact list turn3",i," num_cont",
7814 c     &    num_cont_hb(i)
7815         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7816       enddo
7817       do i=iturn4_start,iturn4_end
7818 c        write (iout,*) "make contact list turn4",i," num_cont",
7819 c     &   num_cont_hb(i)
7820         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7821       enddo
7822       do ii=1,nat_sent
7823         i=iat_sent(ii)
7824 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7825 c     &    num_cont_hb(i)
7826         do j=1,num_cont_hb(i)
7827         do k=1,4
7828           jjc=jcont_hb(j,i)
7829           iproc=iint_sent_local(k,jjc,ii)
7830 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7831           if (iproc.gt.0) then
7832             ncont_sent(iproc)=ncont_sent(iproc)+1
7833             nn=ncont_sent(iproc)
7834             zapas(1,nn,iproc)=i
7835             zapas(2,nn,iproc)=jjc
7836             zapas(3,nn,iproc)=facont_hb(j,i)
7837             zapas(4,nn,iproc)=ees0p(j,i)
7838             zapas(5,nn,iproc)=ees0m(j,i)
7839             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7840             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7841             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7842             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7843             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7844             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7845             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7846             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7847             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7848             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7849             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7850             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7851             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7852             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7853             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7854             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7855             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7856             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7857             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7858             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7859             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7860           endif
7861         enddo
7862         enddo
7863       enddo
7864       if (lprn) then
7865       write (iout,*)
7866      &  "Numbers of contacts to be sent to other processors",
7867      &  (ncont_sent(i),i=1,ntask_cont_to)
7868       write (iout,*) "Contacts sent"
7869       do ii=1,ntask_cont_to
7870         nn=ncont_sent(ii)
7871         iproc=itask_cont_to(ii)
7872         write (iout,*) nn," contacts to processor",iproc,
7873      &   " of CONT_TO_COMM group"
7874         do i=1,nn
7875           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7876         enddo
7877       enddo
7878       call flush(iout)
7879       endif
7880       CorrelType=477
7881       CorrelID=fg_rank+1
7882       CorrelType1=478
7883       CorrelID1=nfgtasks+fg_rank+1
7884       ireq=0
7885 C Receive the numbers of needed contacts from other processors
7886       do ii=1,ntask_cont_from
7887         iproc=itask_cont_from(ii)
7888         ireq=ireq+1
7889         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7890      &    FG_COMM,req(ireq),IERR)
7891       enddo
7892 c      write (iout,*) "IRECV ended"
7893 c      call flush(iout)
7894 C Send the number of contacts needed by other processors
7895       do ii=1,ntask_cont_to
7896         iproc=itask_cont_to(ii)
7897         ireq=ireq+1
7898         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7899      &    FG_COMM,req(ireq),IERR)
7900       enddo
7901 c      write (iout,*) "ISEND ended"
7902 c      write (iout,*) "number of requests (nn)",ireq
7903       call flush(iout)
7904       if (ireq.gt.0)
7905      &  call MPI_Waitall(ireq,req,status_array,ierr)
7906 c      write (iout,*)
7907 c     &  "Numbers of contacts to be received from other processors",
7908 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7909 c      call flush(iout)
7910 C Receive contacts
7911       ireq=0
7912       do ii=1,ntask_cont_from
7913         iproc=itask_cont_from(ii)
7914         nn=ncont_recv(ii)
7915 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7916 c     &   " of CONT_TO_COMM group"
7917         call flush(iout)
7918         if (nn.gt.0) then
7919           ireq=ireq+1
7920           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7921      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7922 c          write (iout,*) "ireq,req",ireq,req(ireq)
7923         endif
7924       enddo
7925 C Send the contacts to processors that need them
7926       do ii=1,ntask_cont_to
7927         iproc=itask_cont_to(ii)
7928         nn=ncont_sent(ii)
7929 c        write (iout,*) nn," contacts to processor",iproc,
7930 c     &   " of CONT_TO_COMM group"
7931         if (nn.gt.0) then
7932           ireq=ireq+1
7933           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7934      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7935 c          write (iout,*) "ireq,req",ireq,req(ireq)
7936 c          do i=1,nn
7937 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7938 c          enddo
7939         endif
7940       enddo
7941 c      write (iout,*) "number of requests (contacts)",ireq
7942 c      write (iout,*) "req",(req(i),i=1,4)
7943 c      call flush(iout)
7944       if (ireq.gt.0)
7945      & call MPI_Waitall(ireq,req,status_array,ierr)
7946       do iii=1,ntask_cont_from
7947         iproc=itask_cont_from(iii)
7948         nn=ncont_recv(iii)
7949         if (lprn) then
7950         write (iout,*) "Received",nn," contacts from processor",iproc,
7951      &   " of CONT_FROM_COMM group"
7952         call flush(iout)
7953         do i=1,nn
7954           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7955         enddo
7956         call flush(iout)
7957         endif
7958         do i=1,nn
7959           ii=zapas_recv(1,i,iii)
7960 c Flag the received contacts to prevent double-counting
7961           jj=-zapas_recv(2,i,iii)
7962 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7963 c          call flush(iout)
7964           nnn=num_cont_hb(ii)+1
7965           num_cont_hb(ii)=nnn
7966           jcont_hb(nnn,ii)=jj
7967           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7968           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7969           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7970           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7971           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7972           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7973           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7974           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7975           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7976           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7977           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7978           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7979           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7980           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7981           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7982           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7983           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7984           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7985           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7986           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7987           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7988           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7989           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7990           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7991         enddo
7992       enddo
7993       call flush(iout)
7994       if (lprn) then
7995         write (iout,'(a)') 'Contact function values after receive:'
7996         do i=nnt,nct-2
7997           write (iout,'(2i3,50(1x,i3,f5.2))')
7998      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7999      &    j=1,num_cont_hb(i))
8000         enddo
8001         call flush(iout)
8002       endif
8003    30 continue
8004 #endif
8005       if (lprn) then
8006         write (iout,'(a)') 'Contact function values:'
8007         do i=nnt,nct-2
8008           write (iout,'(2i3,50(1x,i3,f5.2))')
8009      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8010      &    j=1,num_cont_hb(i))
8011         enddo
8012       endif
8013       ecorr=0.0D0
8014 C Remove the loop below after debugging !!!
8015       do i=nnt,nct
8016         do j=1,3
8017           gradcorr(j,i)=0.0D0
8018           gradxorr(j,i)=0.0D0
8019         enddo
8020       enddo
8021 C Calculate the local-electrostatic correlation terms
8022       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8023         i1=i+1
8024         num_conti=num_cont_hb(i)
8025         num_conti1=num_cont_hb(i+1)
8026         do jj=1,num_conti
8027           j=jcont_hb(jj,i)
8028           jp=iabs(j)
8029           do kk=1,num_conti1
8030             j1=jcont_hb(kk,i1)
8031             jp1=iabs(j1)
8032 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8033 c     &         ' jj=',jj,' kk=',kk
8034             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8035      &          .or. j.lt.0 .and. j1.gt.0) .and.
8036      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8037 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8038 C The system gains extra energy.
8039               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8040               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8041      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8042               n_corr=n_corr+1
8043             else if (j1.eq.j) then
8044 C Contacts I-J and I-(J+1) occur simultaneously.
8045 C The system loses extra energy.
8046 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8047             endif
8048           enddo ! kk
8049           do kk=1,num_conti
8050             j1=jcont_hb(kk,i)
8051 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8052 c    &         ' jj=',jj,' kk=',kk
8053             if (j1.eq.j+1) then
8054 C Contacts I-J and (I+1)-J occur simultaneously.
8055 C The system loses extra energy.
8056 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8057             endif ! j1==j+1
8058           enddo ! kk
8059         enddo ! jj
8060       enddo ! i
8061       return
8062       end
8063 c------------------------------------------------------------------------------
8064       subroutine add_hb_contact(ii,jj,itask)
8065       implicit real*8 (a-h,o-z)
8066       include "DIMENSIONS"
8067       include "COMMON.IOUNITS"
8068       integer max_cont
8069       integer max_dim
8070       parameter (max_cont=maxconts)
8071       parameter (max_dim=26)
8072       include "COMMON.CONTACTS"
8073       double precision zapas(max_dim,maxconts,max_fg_procs),
8074      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8075       common /przechowalnia/ zapas
8076       integer i,j,ii,jj,iproc,itask(4),nn
8077 c      write (iout,*) "itask",itask
8078       do i=1,2
8079         iproc=itask(i)
8080         if (iproc.gt.0) then
8081           do j=1,num_cont_hb(ii)
8082             jjc=jcont_hb(j,ii)
8083 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8084             if (jjc.eq.jj) then
8085               ncont_sent(iproc)=ncont_sent(iproc)+1
8086               nn=ncont_sent(iproc)
8087               zapas(1,nn,iproc)=ii
8088               zapas(2,nn,iproc)=jjc
8089               zapas(3,nn,iproc)=facont_hb(j,ii)
8090               zapas(4,nn,iproc)=ees0p(j,ii)
8091               zapas(5,nn,iproc)=ees0m(j,ii)
8092               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8093               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8094               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8095               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8096               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8097               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8098               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8099               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8100               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8101               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8102               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8103               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8104               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8105               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8106               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8107               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8108               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8109               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8110               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8111               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8112               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8113               exit
8114             endif
8115           enddo
8116         endif
8117       enddo
8118       return
8119       end
8120 c------------------------------------------------------------------------------
8121       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8122      &  n_corr1)
8123 C This subroutine calculates multi-body contributions to hydrogen-bonding
8124       implicit real*8 (a-h,o-z)
8125       include 'DIMENSIONS'
8126       include 'COMMON.IOUNITS'
8127 #ifdef MPI
8128       include "mpif.h"
8129       parameter (max_cont=maxconts)
8130       parameter (max_dim=70)
8131       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8132       double precision zapas(max_dim,maxconts,max_fg_procs),
8133      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8134       common /przechowalnia/ zapas
8135       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8136      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8137 #endif
8138       include 'COMMON.SETUP'
8139       include 'COMMON.FFIELD'
8140       include 'COMMON.DERIV'
8141       include 'COMMON.LOCAL'
8142       include 'COMMON.INTERACT'
8143       include 'COMMON.CONTACTS'
8144       include 'COMMON.CHAIN'
8145       include 'COMMON.CONTROL'
8146       double precision gx(3),gx1(3)
8147       integer num_cont_hb_old(maxres)
8148       logical lprn,ldone
8149       double precision eello4,eello5,eelo6,eello_turn6
8150       external eello4,eello5,eello6,eello_turn6
8151 C Set lprn=.true. for debugging
8152       lprn=.false.
8153       eturn6=0.0d0
8154 #ifdef MPI
8155       do i=1,nres
8156         num_cont_hb_old(i)=num_cont_hb(i)
8157       enddo
8158       n_corr=0
8159       n_corr1=0
8160       if (nfgtasks.le.1) goto 30
8161       if (lprn) then
8162         write (iout,'(a)') 'Contact function values before RECEIVE:'
8163         do i=nnt,nct-2
8164           write (iout,'(2i3,50(1x,i2,f5.2))')
8165      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8166      &    j=1,num_cont_hb(i))
8167         enddo
8168       endif
8169       call flush(iout)
8170       do i=1,ntask_cont_from
8171         ncont_recv(i)=0
8172       enddo
8173       do i=1,ntask_cont_to
8174         ncont_sent(i)=0
8175       enddo
8176 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8177 c     & ntask_cont_to
8178 C Make the list of contacts to send to send to other procesors
8179       do i=iturn3_start,iturn3_end
8180 c        write (iout,*) "make contact list turn3",i," num_cont",
8181 c     &    num_cont_hb(i)
8182         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8183       enddo
8184       do i=iturn4_start,iturn4_end
8185 c        write (iout,*) "make contact list turn4",i," num_cont",
8186 c     &   num_cont_hb(i)
8187         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8188       enddo
8189       do ii=1,nat_sent
8190         i=iat_sent(ii)
8191 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8192 c     &    num_cont_hb(i)
8193         do j=1,num_cont_hb(i)
8194         do k=1,4
8195           jjc=jcont_hb(j,i)
8196           iproc=iint_sent_local(k,jjc,ii)
8197 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8198           if (iproc.ne.0) then
8199             ncont_sent(iproc)=ncont_sent(iproc)+1
8200             nn=ncont_sent(iproc)
8201             zapas(1,nn,iproc)=i
8202             zapas(2,nn,iproc)=jjc
8203             zapas(3,nn,iproc)=d_cont(j,i)
8204             ind=3
8205             do kk=1,3
8206               ind=ind+1
8207               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8208             enddo
8209             do kk=1,2
8210               do ll=1,2
8211                 ind=ind+1
8212                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8213               enddo
8214             enddo
8215             do jj=1,5
8216               do kk=1,3
8217                 do ll=1,2
8218                   do mm=1,2
8219                     ind=ind+1
8220                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8221                   enddo
8222                 enddo
8223               enddo
8224             enddo
8225           endif
8226         enddo
8227         enddo
8228       enddo
8229       if (lprn) then
8230       write (iout,*)
8231      &  "Numbers of contacts to be sent to other processors",
8232      &  (ncont_sent(i),i=1,ntask_cont_to)
8233       write (iout,*) "Contacts sent"
8234       do ii=1,ntask_cont_to
8235         nn=ncont_sent(ii)
8236         iproc=itask_cont_to(ii)
8237         write (iout,*) nn," contacts to processor",iproc,
8238      &   " of CONT_TO_COMM group"
8239         do i=1,nn
8240           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8241         enddo
8242       enddo
8243       call flush(iout)
8244       endif
8245       CorrelType=477
8246       CorrelID=fg_rank+1
8247       CorrelType1=478
8248       CorrelID1=nfgtasks+fg_rank+1
8249       ireq=0
8250 C Receive the numbers of needed contacts from other processors
8251       do ii=1,ntask_cont_from
8252         iproc=itask_cont_from(ii)
8253         ireq=ireq+1
8254         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8255      &    FG_COMM,req(ireq),IERR)
8256       enddo
8257 c      write (iout,*) "IRECV ended"
8258 c      call flush(iout)
8259 C Send the number of contacts needed by other processors
8260       do ii=1,ntask_cont_to
8261         iproc=itask_cont_to(ii)
8262         ireq=ireq+1
8263         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8264      &    FG_COMM,req(ireq),IERR)
8265       enddo
8266 c      write (iout,*) "ISEND ended"
8267 c      write (iout,*) "number of requests (nn)",ireq
8268       call flush(iout)
8269       if (ireq.gt.0)
8270      &  call MPI_Waitall(ireq,req,status_array,ierr)
8271 c      write (iout,*)
8272 c     &  "Numbers of contacts to be received from other processors",
8273 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8274 c      call flush(iout)
8275 C Receive contacts
8276       ireq=0
8277       do ii=1,ntask_cont_from
8278         iproc=itask_cont_from(ii)
8279         nn=ncont_recv(ii)
8280 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8281 c     &   " of CONT_TO_COMM group"
8282         call flush(iout)
8283         if (nn.gt.0) then
8284           ireq=ireq+1
8285           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8286      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8287 c          write (iout,*) "ireq,req",ireq,req(ireq)
8288         endif
8289       enddo
8290 C Send the contacts to processors that need them
8291       do ii=1,ntask_cont_to
8292         iproc=itask_cont_to(ii)
8293         nn=ncont_sent(ii)
8294 c        write (iout,*) nn," contacts to processor",iproc,
8295 c     &   " of CONT_TO_COMM group"
8296         if (nn.gt.0) then
8297           ireq=ireq+1
8298           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8299      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8300 c          write (iout,*) "ireq,req",ireq,req(ireq)
8301 c          do i=1,nn
8302 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8303 c          enddo
8304         endif
8305       enddo
8306 c      write (iout,*) "number of requests (contacts)",ireq
8307 c      write (iout,*) "req",(req(i),i=1,4)
8308 c      call flush(iout)
8309       if (ireq.gt.0)
8310      & call MPI_Waitall(ireq,req,status_array,ierr)
8311       do iii=1,ntask_cont_from
8312         iproc=itask_cont_from(iii)
8313         nn=ncont_recv(iii)
8314         if (lprn) then
8315         write (iout,*) "Received",nn," contacts from processor",iproc,
8316      &   " of CONT_FROM_COMM group"
8317         call flush(iout)
8318         do i=1,nn
8319           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8320         enddo
8321         call flush(iout)
8322         endif
8323         do i=1,nn
8324           ii=zapas_recv(1,i,iii)
8325 c Flag the received contacts to prevent double-counting
8326           jj=-zapas_recv(2,i,iii)
8327 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8328 c          call flush(iout)
8329           nnn=num_cont_hb(ii)+1
8330           num_cont_hb(ii)=nnn
8331           jcont_hb(nnn,ii)=jj
8332           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8333           ind=3
8334           do kk=1,3
8335             ind=ind+1
8336             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8337           enddo
8338           do kk=1,2
8339             do ll=1,2
8340               ind=ind+1
8341               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8342             enddo
8343           enddo
8344           do jj=1,5
8345             do kk=1,3
8346               do ll=1,2
8347                 do mm=1,2
8348                   ind=ind+1
8349                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8350                 enddo
8351               enddo
8352             enddo
8353           enddo
8354         enddo
8355       enddo
8356       call flush(iout)
8357       if (lprn) then
8358         write (iout,'(a)') 'Contact function values after receive:'
8359         do i=nnt,nct-2
8360           write (iout,'(2i3,50(1x,i3,5f6.3))')
8361      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8362      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8363         enddo
8364         call flush(iout)
8365       endif
8366    30 continue
8367 #endif
8368       if (lprn) then
8369         write (iout,'(a)') 'Contact function values:'
8370         do i=nnt,nct-2
8371           write (iout,'(2i3,50(1x,i2,5f6.3))')
8372      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8373      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8374         enddo
8375       endif
8376       ecorr=0.0D0
8377       ecorr5=0.0d0
8378       ecorr6=0.0d0
8379 C Remove the loop below after debugging !!!
8380       do i=nnt,nct
8381         do j=1,3
8382           gradcorr(j,i)=0.0D0
8383           gradxorr(j,i)=0.0D0
8384         enddo
8385       enddo
8386 C Calculate the dipole-dipole interaction energies
8387       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8388       do i=iatel_s,iatel_e+1
8389         num_conti=num_cont_hb(i)
8390         do jj=1,num_conti
8391           j=jcont_hb(jj,i)
8392 #ifdef MOMENT
8393           call dipole(i,j,jj)
8394 #endif
8395         enddo
8396       enddo
8397       endif
8398 C Calculate the local-electrostatic correlation terms
8399 c                write (iout,*) "gradcorr5 in eello5 before loop"
8400 c                do iii=1,nres
8401 c                  write (iout,'(i5,3f10.5)')
8402 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8403 c                enddo
8404       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8405 c        write (iout,*) "corr loop i",i
8406         i1=i+1
8407         num_conti=num_cont_hb(i)
8408         num_conti1=num_cont_hb(i+1)
8409         do jj=1,num_conti
8410           j=jcont_hb(jj,i)
8411           jp=iabs(j)
8412           do kk=1,num_conti1
8413             j1=jcont_hb(kk,i1)
8414             jp1=iabs(j1)
8415 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8416 c     &         ' jj=',jj,' kk=',kk
8417 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8418             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8419      &          .or. j.lt.0 .and. j1.gt.0) .and.
8420      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8421 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8422 C The system gains extra energy.
8423               n_corr=n_corr+1
8424               sqd1=dsqrt(d_cont(jj,i))
8425               sqd2=dsqrt(d_cont(kk,i1))
8426               sred_geom = sqd1*sqd2
8427               IF (sred_geom.lt.cutoff_corr) THEN
8428                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8429      &            ekont,fprimcont)
8430 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8431 cd     &         ' jj=',jj,' kk=',kk
8432                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8433                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8434                 do l=1,3
8435                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8436                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8437                 enddo
8438                 n_corr1=n_corr1+1
8439 cd               write (iout,*) 'sred_geom=',sred_geom,
8440 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8441 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8442 cd               write (iout,*) "g_contij",g_contij
8443 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8444 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8445                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8446                 if (wcorr4.gt.0.0d0)
8447      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8448                   if (energy_dec.and.wcorr4.gt.0.0d0)
8449      1                 write (iout,'(a6,4i5,0pf7.3)')
8450      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8451 c                write (iout,*) "gradcorr5 before eello5"
8452 c                do iii=1,nres
8453 c                  write (iout,'(i5,3f10.5)')
8454 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8455 c                enddo
8456                 if (wcorr5.gt.0.0d0)
8457      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8458 c                write (iout,*) "gradcorr5 after eello5"
8459 c                do iii=1,nres
8460 c                  write (iout,'(i5,3f10.5)')
8461 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8462 c                enddo
8463                   if (energy_dec.and.wcorr5.gt.0.0d0)
8464      1                 write (iout,'(a6,4i5,0pf7.3)')
8465      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8466 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8467 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8468                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8469      &               .or. wturn6.eq.0.0d0))then
8470 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8471                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8472                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8473      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8474 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8475 cd     &            'ecorr6=',ecorr6
8476 cd                write (iout,'(4e15.5)') sred_geom,
8477 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8478 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8479 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8480                 else if (wturn6.gt.0.0d0
8481      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8482 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8483                   eturn6=eturn6+eello_turn6(i,jj,kk)
8484                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8485      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8486 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8487                 endif
8488               ENDIF
8489 1111          continue
8490             endif
8491           enddo ! kk
8492         enddo ! jj
8493       enddo ! i
8494       do i=1,nres
8495         num_cont_hb(i)=num_cont_hb_old(i)
8496       enddo
8497 c                write (iout,*) "gradcorr5 in eello5"
8498 c                do iii=1,nres
8499 c                  write (iout,'(i5,3f10.5)')
8500 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8501 c                enddo
8502       return
8503       end
8504 c------------------------------------------------------------------------------
8505       subroutine add_hb_contact_eello(ii,jj,itask)
8506       implicit real*8 (a-h,o-z)
8507       include "DIMENSIONS"
8508       include "COMMON.IOUNITS"
8509       integer max_cont
8510       integer max_dim
8511       parameter (max_cont=maxconts)
8512       parameter (max_dim=70)
8513       include "COMMON.CONTACTS"
8514       double precision zapas(max_dim,maxconts,max_fg_procs),
8515      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8516       common /przechowalnia/ zapas
8517       integer i,j,ii,jj,iproc,itask(4),nn
8518 c      write (iout,*) "itask",itask
8519       do i=1,2
8520         iproc=itask(i)
8521         if (iproc.gt.0) then
8522           do j=1,num_cont_hb(ii)
8523             jjc=jcont_hb(j,ii)
8524 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8525             if (jjc.eq.jj) then
8526               ncont_sent(iproc)=ncont_sent(iproc)+1
8527               nn=ncont_sent(iproc)
8528               zapas(1,nn,iproc)=ii
8529               zapas(2,nn,iproc)=jjc
8530               zapas(3,nn,iproc)=d_cont(j,ii)
8531               ind=3
8532               do kk=1,3
8533                 ind=ind+1
8534                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8535               enddo
8536               do kk=1,2
8537                 do ll=1,2
8538                   ind=ind+1
8539                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8540                 enddo
8541               enddo
8542               do jj=1,5
8543                 do kk=1,3
8544                   do ll=1,2
8545                     do mm=1,2
8546                       ind=ind+1
8547                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8548                     enddo
8549                   enddo
8550                 enddo
8551               enddo
8552               exit
8553             endif
8554           enddo
8555         endif
8556       enddo
8557       return
8558       end
8559 c------------------------------------------------------------------------------
8560       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8561       implicit real*8 (a-h,o-z)
8562       include 'DIMENSIONS'
8563       include 'COMMON.IOUNITS'
8564       include 'COMMON.DERIV'
8565       include 'COMMON.INTERACT'
8566       include 'COMMON.CONTACTS'
8567       double precision gx(3),gx1(3)
8568       logical lprn
8569       lprn=.false.
8570       eij=facont_hb(jj,i)
8571       ekl=facont_hb(kk,k)
8572       ees0pij=ees0p(jj,i)
8573       ees0pkl=ees0p(kk,k)
8574       ees0mij=ees0m(jj,i)
8575       ees0mkl=ees0m(kk,k)
8576       ekont=eij*ekl
8577       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8578 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8579 C Following 4 lines for diagnostics.
8580 cd    ees0pkl=0.0D0
8581 cd    ees0pij=1.0D0
8582 cd    ees0mkl=0.0D0
8583 cd    ees0mij=1.0D0
8584 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8585 c     & 'Contacts ',i,j,
8586 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8587 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8588 c     & 'gradcorr_long'
8589 C Calculate the multi-body contribution to energy.
8590 c      ecorr=ecorr+ekont*ees
8591 C Calculate multi-body contributions to the gradient.
8592       coeffpees0pij=coeffp*ees0pij
8593       coeffmees0mij=coeffm*ees0mij
8594       coeffpees0pkl=coeffp*ees0pkl
8595       coeffmees0mkl=coeffm*ees0mkl
8596       do ll=1,3
8597 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8598         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8599      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8600      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8601         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8602      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8603      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8604 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8605         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8606      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8607      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8608         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8609      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8610      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8611         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8612      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8613      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8614         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8615         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8616         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8617      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8618      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8619         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8620         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8621 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8622       enddo
8623 c      write (iout,*)
8624 cgrad      do m=i+1,j-1
8625 cgrad        do ll=1,3
8626 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8627 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8628 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8629 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8630 cgrad        enddo
8631 cgrad      enddo
8632 cgrad      do m=k+1,l-1
8633 cgrad        do ll=1,3
8634 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8635 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8636 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8637 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8638 cgrad        enddo
8639 cgrad      enddo
8640 c      write (iout,*) "ehbcorr",ekont*ees
8641       ehbcorr=ekont*ees
8642       return
8643       end
8644 #ifdef MOMENT
8645 C---------------------------------------------------------------------------
8646       subroutine dipole(i,j,jj)
8647       implicit real*8 (a-h,o-z)
8648       include 'DIMENSIONS'
8649       include 'COMMON.IOUNITS'
8650       include 'COMMON.CHAIN'
8651       include 'COMMON.FFIELD'
8652       include 'COMMON.DERIV'
8653       include 'COMMON.INTERACT'
8654       include 'COMMON.CONTACTS'
8655       include 'COMMON.TORSION'
8656       include 'COMMON.VAR'
8657       include 'COMMON.GEO'
8658       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8659      &  auxmat(2,2)
8660       iti1 = itortyp(itype(i+1))
8661       if (j.lt.nres-1) then
8662         itj1 = itortyp(itype(j+1))
8663       else
8664         itj1=ntortyp
8665       endif
8666       do iii=1,2
8667         dipi(iii,1)=Ub2(iii,i)
8668         dipderi(iii)=Ub2der(iii,i)
8669         dipi(iii,2)=b1(iii,i+1)
8670         dipj(iii,1)=Ub2(iii,j)
8671         dipderj(iii)=Ub2der(iii,j)
8672         dipj(iii,2)=b1(iii,j+1)
8673       enddo
8674       kkk=0
8675       do iii=1,2
8676         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8677         do jjj=1,2
8678           kkk=kkk+1
8679           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8680         enddo
8681       enddo
8682       do kkk=1,5
8683         do lll=1,3
8684           mmm=0
8685           do iii=1,2
8686             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8687      &        auxvec(1))
8688             do jjj=1,2
8689               mmm=mmm+1
8690               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8691             enddo
8692           enddo
8693         enddo
8694       enddo
8695       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8696       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8697       do iii=1,2
8698         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8699       enddo
8700       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8701       do iii=1,2
8702         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8703       enddo
8704       return
8705       end
8706 #endif
8707 C---------------------------------------------------------------------------
8708       subroutine calc_eello(i,j,k,l,jj,kk)
8709 C
8710 C This subroutine computes matrices and vectors needed to calculate
8711 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8712 C
8713       implicit real*8 (a-h,o-z)
8714       include 'DIMENSIONS'
8715       include 'COMMON.IOUNITS'
8716       include 'COMMON.CHAIN'
8717       include 'COMMON.DERIV'
8718       include 'COMMON.INTERACT'
8719       include 'COMMON.CONTACTS'
8720       include 'COMMON.TORSION'
8721       include 'COMMON.VAR'
8722       include 'COMMON.GEO'
8723       include 'COMMON.FFIELD'
8724       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8725      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8726       logical lprn
8727       common /kutas/ lprn
8728 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8729 cd     & ' jj=',jj,' kk=',kk
8730 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8731 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8732 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8733       do iii=1,2
8734         do jjj=1,2
8735           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8736           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8737         enddo
8738       enddo
8739       call transpose2(aa1(1,1),aa1t(1,1))
8740       call transpose2(aa2(1,1),aa2t(1,1))
8741       do kkk=1,5
8742         do lll=1,3
8743           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8744      &      aa1tder(1,1,lll,kkk))
8745           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8746      &      aa2tder(1,1,lll,kkk))
8747         enddo
8748       enddo
8749       if (l.eq.j+1) then
8750 C parallel orientation of the two CA-CA-CA frames.
8751         if (i.gt.1) then
8752           iti=itortyp(itype(i))
8753         else
8754           iti=ntortyp
8755         endif
8756         itk1=itortyp(itype(k+1))
8757         itj=itortyp(itype(j))
8758         if (l.lt.nres-1) then
8759           itl1=itortyp(itype(l+1))
8760         else
8761           itl1=ntortyp
8762         endif
8763 C A1 kernel(j+1) A2T
8764 cd        do iii=1,2
8765 cd          write (iout,'(3f10.5,5x,3f10.5)')
8766 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8767 cd        enddo
8768         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8769      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8770      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8771 C Following matrices are needed only for 6-th order cumulants
8772         IF (wcorr6.gt.0.0d0) THEN
8773         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8774      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8775      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8776         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8777      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8778      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8779      &   ADtEAderx(1,1,1,1,1,1))
8780         lprn=.false.
8781         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8782      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8783      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8784      &   ADtEA1derx(1,1,1,1,1,1))
8785         ENDIF
8786 C End 6-th order cumulants
8787 cd        lprn=.false.
8788 cd        if (lprn) then
8789 cd        write (2,*) 'In calc_eello6'
8790 cd        do iii=1,2
8791 cd          write (2,*) 'iii=',iii
8792 cd          do kkk=1,5
8793 cd            write (2,*) 'kkk=',kkk
8794 cd            do jjj=1,2
8795 cd              write (2,'(3(2f10.5),5x)')
8796 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8797 cd            enddo
8798 cd          enddo
8799 cd        enddo
8800 cd        endif
8801         call transpose2(EUgder(1,1,k),auxmat(1,1))
8802         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8803         call transpose2(EUg(1,1,k),auxmat(1,1))
8804         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8805         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8806         do iii=1,2
8807           do kkk=1,5
8808             do lll=1,3
8809               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8810      &          EAEAderx(1,1,lll,kkk,iii,1))
8811             enddo
8812           enddo
8813         enddo
8814 C A1T kernel(i+1) A2
8815         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8816      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8817      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8818 C Following matrices are needed only for 6-th order cumulants
8819         IF (wcorr6.gt.0.0d0) THEN
8820         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8821      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8822      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8823         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8824      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8825      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8826      &   ADtEAderx(1,1,1,1,1,2))
8827         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8828      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8829      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8830      &   ADtEA1derx(1,1,1,1,1,2))
8831         ENDIF
8832 C End 6-th order cumulants
8833         call transpose2(EUgder(1,1,l),auxmat(1,1))
8834         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8835         call transpose2(EUg(1,1,l),auxmat(1,1))
8836         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8837         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8838         do iii=1,2
8839           do kkk=1,5
8840             do lll=1,3
8841               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8842      &          EAEAderx(1,1,lll,kkk,iii,2))
8843             enddo
8844           enddo
8845         enddo
8846 C AEAb1 and AEAb2
8847 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8848 C They are needed only when the fifth- or the sixth-order cumulants are
8849 C indluded.
8850         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8851         call transpose2(AEA(1,1,1),auxmat(1,1))
8852         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8853         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8854         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8855         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8856         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8857         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8858         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8859         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8860         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8861         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8862         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8863         call transpose2(AEA(1,1,2),auxmat(1,1))
8864         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8865         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8866         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8867         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8868         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8869         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8870         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8871         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8872         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8873         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8874         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8875 C Calculate the Cartesian derivatives of the vectors.
8876         do iii=1,2
8877           do kkk=1,5
8878             do lll=1,3
8879               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8880               call matvec2(auxmat(1,1),b1(1,i),
8881      &          AEAb1derx(1,lll,kkk,iii,1,1))
8882               call matvec2(auxmat(1,1),Ub2(1,i),
8883      &          AEAb2derx(1,lll,kkk,iii,1,1))
8884               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8885      &          AEAb1derx(1,lll,kkk,iii,2,1))
8886               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8887      &          AEAb2derx(1,lll,kkk,iii,2,1))
8888               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8889               call matvec2(auxmat(1,1),b1(1,j),
8890      &          AEAb1derx(1,lll,kkk,iii,1,2))
8891               call matvec2(auxmat(1,1),Ub2(1,j),
8892      &          AEAb2derx(1,lll,kkk,iii,1,2))
8893               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8894      &          AEAb1derx(1,lll,kkk,iii,2,2))
8895               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8896      &          AEAb2derx(1,lll,kkk,iii,2,2))
8897             enddo
8898           enddo
8899         enddo
8900         ENDIF
8901 C End vectors
8902       else
8903 C Antiparallel orientation of the two CA-CA-CA frames.
8904         if (i.gt.1) then
8905           iti=itortyp(itype(i))
8906         else
8907           iti=ntortyp
8908         endif
8909         itk1=itortyp(itype(k+1))
8910         itl=itortyp(itype(l))
8911         itj=itortyp(itype(j))
8912         if (j.lt.nres-1) then
8913           itj1=itortyp(itype(j+1))
8914         else
8915           itj1=ntortyp
8916         endif
8917 C A2 kernel(j-1)T A1T
8918         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8919      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8920      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8921 C Following matrices are needed only for 6-th order cumulants
8922         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8923      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8925      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8926      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8927         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8928      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8929      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8930      &   ADtEAderx(1,1,1,1,1,1))
8931         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8932      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8933      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8934      &   ADtEA1derx(1,1,1,1,1,1))
8935         ENDIF
8936 C End 6-th order cumulants
8937         call transpose2(EUgder(1,1,k),auxmat(1,1))
8938         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8939         call transpose2(EUg(1,1,k),auxmat(1,1))
8940         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8941         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8942         do iii=1,2
8943           do kkk=1,5
8944             do lll=1,3
8945               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8946      &          EAEAderx(1,1,lll,kkk,iii,1))
8947             enddo
8948           enddo
8949         enddo
8950 C A2T kernel(i+1)T A1
8951         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8952      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8953      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8954 C Following matrices are needed only for 6-th order cumulants
8955         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8956      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8957         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8958      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8959      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8960         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8961      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8962      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8963      &   ADtEAderx(1,1,1,1,1,2))
8964         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8965      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8966      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8967      &   ADtEA1derx(1,1,1,1,1,2))
8968         ENDIF
8969 C End 6-th order cumulants
8970         call transpose2(EUgder(1,1,j),auxmat(1,1))
8971         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8972         call transpose2(EUg(1,1,j),auxmat(1,1))
8973         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8974         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8975         do iii=1,2
8976           do kkk=1,5
8977             do lll=1,3
8978               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8979      &          EAEAderx(1,1,lll,kkk,iii,2))
8980             enddo
8981           enddo
8982         enddo
8983 C AEAb1 and AEAb2
8984 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8985 C They are needed only when the fifth- or the sixth-order cumulants are
8986 C indluded.
8987         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8988      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8989         call transpose2(AEA(1,1,1),auxmat(1,1))
8990         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8991         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8992         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8993         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8994         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8995         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8996         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8997         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8998         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8999         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9000         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9001         call transpose2(AEA(1,1,2),auxmat(1,1))
9002         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9003         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9004         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9005         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9006         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9007         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9008         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9009         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9010         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9011         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9012         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9013 C Calculate the Cartesian derivatives of the vectors.
9014         do iii=1,2
9015           do kkk=1,5
9016             do lll=1,3
9017               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9018               call matvec2(auxmat(1,1),b1(1,i),
9019      &          AEAb1derx(1,lll,kkk,iii,1,1))
9020               call matvec2(auxmat(1,1),Ub2(1,i),
9021      &          AEAb2derx(1,lll,kkk,iii,1,1))
9022               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9023      &          AEAb1derx(1,lll,kkk,iii,2,1))
9024               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9025      &          AEAb2derx(1,lll,kkk,iii,2,1))
9026               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9027               call matvec2(auxmat(1,1),b1(1,l),
9028      &          AEAb1derx(1,lll,kkk,iii,1,2))
9029               call matvec2(auxmat(1,1),Ub2(1,l),
9030      &          AEAb2derx(1,lll,kkk,iii,1,2))
9031               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9032      &          AEAb1derx(1,lll,kkk,iii,2,2))
9033               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9034      &          AEAb2derx(1,lll,kkk,iii,2,2))
9035             enddo
9036           enddo
9037         enddo
9038         ENDIF
9039 C End vectors
9040       endif
9041       return
9042       end
9043 C---------------------------------------------------------------------------
9044       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9045      &  KK,KKderg,AKA,AKAderg,AKAderx)
9046       implicit none
9047       integer nderg
9048       logical transp
9049       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9050      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9051      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9052       integer iii,kkk,lll
9053       integer jjj,mmm
9054       logical lprn
9055       common /kutas/ lprn
9056       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9057       do iii=1,nderg
9058         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9059      &    AKAderg(1,1,iii))
9060       enddo
9061 cd      if (lprn) write (2,*) 'In kernel'
9062       do kkk=1,5
9063 cd        if (lprn) write (2,*) 'kkk=',kkk
9064         do lll=1,3
9065           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9066      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9067 cd          if (lprn) then
9068 cd            write (2,*) 'lll=',lll
9069 cd            write (2,*) 'iii=1'
9070 cd            do jjj=1,2
9071 cd              write (2,'(3(2f10.5),5x)')
9072 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9073 cd            enddo
9074 cd          endif
9075           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9076      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9077 cd          if (lprn) then
9078 cd            write (2,*) 'lll=',lll
9079 cd            write (2,*) 'iii=2'
9080 cd            do jjj=1,2
9081 cd              write (2,'(3(2f10.5),5x)')
9082 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9083 cd            enddo
9084 cd          endif
9085         enddo
9086       enddo
9087       return
9088       end
9089 C---------------------------------------------------------------------------
9090       double precision function eello4(i,j,k,l,jj,kk)
9091       implicit real*8 (a-h,o-z)
9092       include 'DIMENSIONS'
9093       include 'COMMON.IOUNITS'
9094       include 'COMMON.CHAIN'
9095       include 'COMMON.DERIV'
9096       include 'COMMON.INTERACT'
9097       include 'COMMON.CONTACTS'
9098       include 'COMMON.TORSION'
9099       include 'COMMON.VAR'
9100       include 'COMMON.GEO'
9101       double precision pizda(2,2),ggg1(3),ggg2(3)
9102 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9103 cd        eello4=0.0d0
9104 cd        return
9105 cd      endif
9106 cd      print *,'eello4:',i,j,k,l,jj,kk
9107 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9108 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9109 cold      eij=facont_hb(jj,i)
9110 cold      ekl=facont_hb(kk,k)
9111 cold      ekont=eij*ekl
9112       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9113 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9114       gcorr_loc(k-1)=gcorr_loc(k-1)
9115      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9116       if (l.eq.j+1) then
9117         gcorr_loc(l-1)=gcorr_loc(l-1)
9118      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9119       else
9120         gcorr_loc(j-1)=gcorr_loc(j-1)
9121      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9122       endif
9123       do iii=1,2
9124         do kkk=1,5
9125           do lll=1,3
9126             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9127      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9128 cd            derx(lll,kkk,iii)=0.0d0
9129           enddo
9130         enddo
9131       enddo
9132 cd      gcorr_loc(l-1)=0.0d0
9133 cd      gcorr_loc(j-1)=0.0d0
9134 cd      gcorr_loc(k-1)=0.0d0
9135 cd      eel4=1.0d0
9136 cd      write (iout,*)'Contacts have occurred for peptide groups',
9137 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9138 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9139       if (j.lt.nres-1) then
9140         j1=j+1
9141         j2=j-1
9142       else
9143         j1=j-1
9144         j2=j-2
9145       endif
9146       if (l.lt.nres-1) then
9147         l1=l+1
9148         l2=l-1
9149       else
9150         l1=l-1
9151         l2=l-2
9152       endif
9153       do ll=1,3
9154 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9155 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9156         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9157         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9158 cgrad        ghalf=0.5d0*ggg1(ll)
9159         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9160         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9161         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9162         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9163         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9164         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9165 cgrad        ghalf=0.5d0*ggg2(ll)
9166         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9167         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9168         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9169         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9170         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9171         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9172       enddo
9173 cgrad      do m=i+1,j-1
9174 cgrad        do ll=1,3
9175 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9176 cgrad        enddo
9177 cgrad      enddo
9178 cgrad      do m=k+1,l-1
9179 cgrad        do ll=1,3
9180 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9181 cgrad        enddo
9182 cgrad      enddo
9183 cgrad      do m=i+2,j2
9184 cgrad        do ll=1,3
9185 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9186 cgrad        enddo
9187 cgrad      enddo
9188 cgrad      do m=k+2,l2
9189 cgrad        do ll=1,3
9190 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9191 cgrad        enddo
9192 cgrad      enddo
9193 cd      do iii=1,nres-3
9194 cd        write (2,*) iii,gcorr_loc(iii)
9195 cd      enddo
9196       eello4=ekont*eel4
9197 cd      write (2,*) 'ekont',ekont
9198 cd      write (iout,*) 'eello4',ekont*eel4
9199       return
9200       end
9201 C---------------------------------------------------------------------------
9202       double precision function eello5(i,j,k,l,jj,kk)
9203       implicit real*8 (a-h,o-z)
9204       include 'DIMENSIONS'
9205       include 'COMMON.IOUNITS'
9206       include 'COMMON.CHAIN'
9207       include 'COMMON.DERIV'
9208       include 'COMMON.INTERACT'
9209       include 'COMMON.CONTACTS'
9210       include 'COMMON.TORSION'
9211       include 'COMMON.VAR'
9212       include 'COMMON.GEO'
9213       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9214       double precision ggg1(3),ggg2(3)
9215 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9216 C                                                                              C
9217 C                            Parallel chains                                   C
9218 C                                                                              C
9219 C          o             o                   o             o                   C
9220 C         /l\           / \             \   / \           / \   /              C
9221 C        /   \         /   \             \ /   \         /   \ /               C
9222 C       j| o |l1       | o |              o| o |         | o |o                C
9223 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9224 C      \i/   \         /   \ /             /   \         /   \                 C
9225 C       o    k1             o                                                  C
9226 C         (I)          (II)                (III)          (IV)                 C
9227 C                                                                              C
9228 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9229 C                                                                              C
9230 C                            Antiparallel chains                               C
9231 C                                                                              C
9232 C          o             o                   o             o                   C
9233 C         /j\           / \             \   / \           / \   /              C
9234 C        /   \         /   \             \ /   \         /   \ /               C
9235 C      j1| o |l        | o |              o| o |         | o |o                C
9236 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9237 C      \i/   \         /   \ /             /   \         /   \                 C
9238 C       o     k1            o                                                  C
9239 C         (I)          (II)                (III)          (IV)                 C
9240 C                                                                              C
9241 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9242 C                                                                              C
9243 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9244 C                                                                              C
9245 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9246 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9247 cd        eello5=0.0d0
9248 cd        return
9249 cd      endif
9250 cd      write (iout,*)
9251 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9252 cd     &   ' and',k,l
9253       itk=itortyp(itype(k))
9254       itl=itortyp(itype(l))
9255       itj=itortyp(itype(j))
9256       eello5_1=0.0d0
9257       eello5_2=0.0d0
9258       eello5_3=0.0d0
9259       eello5_4=0.0d0
9260 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9261 cd     &   eel5_3_num,eel5_4_num)
9262       do iii=1,2
9263         do kkk=1,5
9264           do lll=1,3
9265             derx(lll,kkk,iii)=0.0d0
9266           enddo
9267         enddo
9268       enddo
9269 cd      eij=facont_hb(jj,i)
9270 cd      ekl=facont_hb(kk,k)
9271 cd      ekont=eij*ekl
9272 cd      write (iout,*)'Contacts have occurred for peptide groups',
9273 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9274 cd      goto 1111
9275 C Contribution from the graph I.
9276 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9277 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9278       call transpose2(EUg(1,1,k),auxmat(1,1))
9279       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9280       vv(1)=pizda(1,1)-pizda(2,2)
9281       vv(2)=pizda(1,2)+pizda(2,1)
9282       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9283      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9284 C Explicit gradient in virtual-dihedral angles.
9285       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9286      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9287      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9288       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9289       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9290       vv(1)=pizda(1,1)-pizda(2,2)
9291       vv(2)=pizda(1,2)+pizda(2,1)
9292       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9293      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9294      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9295       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9296       vv(1)=pizda(1,1)-pizda(2,2)
9297       vv(2)=pizda(1,2)+pizda(2,1)
9298       if (l.eq.j+1) then
9299         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9300      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9301      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9302       else
9303         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9304      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9305      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9306       endif
9307 C Cartesian gradient
9308       do iii=1,2
9309         do kkk=1,5
9310           do lll=1,3
9311             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9312      &        pizda(1,1))
9313             vv(1)=pizda(1,1)-pizda(2,2)
9314             vv(2)=pizda(1,2)+pizda(2,1)
9315             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9316      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9317      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9318           enddo
9319         enddo
9320       enddo
9321 c      goto 1112
9322 c1111  continue
9323 C Contribution from graph II
9324       call transpose2(EE(1,1,itk),auxmat(1,1))
9325       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9326       vv(1)=pizda(1,1)+pizda(2,2)
9327       vv(2)=pizda(2,1)-pizda(1,2)
9328       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9329      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9330 C Explicit gradient in virtual-dihedral angles.
9331       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9332      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9333       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9334       vv(1)=pizda(1,1)+pizda(2,2)
9335       vv(2)=pizda(2,1)-pizda(1,2)
9336       if (l.eq.j+1) then
9337         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9338      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9339      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9340       else
9341         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9342      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9343      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9344       endif
9345 C Cartesian gradient
9346       do iii=1,2
9347         do kkk=1,5
9348           do lll=1,3
9349             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9350      &        pizda(1,1))
9351             vv(1)=pizda(1,1)+pizda(2,2)
9352             vv(2)=pizda(2,1)-pizda(1,2)
9353             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9354      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9355      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9356           enddo
9357         enddo
9358       enddo
9359 cd      goto 1112
9360 cd1111  continue
9361       if (l.eq.j+1) then
9362 cd        goto 1110
9363 C Parallel orientation
9364 C Contribution from graph III
9365         call transpose2(EUg(1,1,l),auxmat(1,1))
9366         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9367         vv(1)=pizda(1,1)-pizda(2,2)
9368         vv(2)=pizda(1,2)+pizda(2,1)
9369         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9370      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9371 C Explicit gradient in virtual-dihedral angles.
9372         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9373      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9374      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9375         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9376         vv(1)=pizda(1,1)-pizda(2,2)
9377         vv(2)=pizda(1,2)+pizda(2,1)
9378         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9379      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9380      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9381         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9382         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9383         vv(1)=pizda(1,1)-pizda(2,2)
9384         vv(2)=pizda(1,2)+pizda(2,1)
9385         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9386      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9387      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9388 C Cartesian gradient
9389         do iii=1,2
9390           do kkk=1,5
9391             do lll=1,3
9392               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9393      &          pizda(1,1))
9394               vv(1)=pizda(1,1)-pizda(2,2)
9395               vv(2)=pizda(1,2)+pizda(2,1)
9396               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9397      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9398      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9399             enddo
9400           enddo
9401         enddo
9402 cd        goto 1112
9403 C Contribution from graph IV
9404 cd1110    continue
9405         call transpose2(EE(1,1,itl),auxmat(1,1))
9406         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9407         vv(1)=pizda(1,1)+pizda(2,2)
9408         vv(2)=pizda(2,1)-pizda(1,2)
9409         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9410      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9411 C Explicit gradient in virtual-dihedral angles.
9412         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9413      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9414         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9415         vv(1)=pizda(1,1)+pizda(2,2)
9416         vv(2)=pizda(2,1)-pizda(1,2)
9417         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9418      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9419      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9420 C Cartesian gradient
9421         do iii=1,2
9422           do kkk=1,5
9423             do lll=1,3
9424               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9425      &          pizda(1,1))
9426               vv(1)=pizda(1,1)+pizda(2,2)
9427               vv(2)=pizda(2,1)-pizda(1,2)
9428               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9429      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9430      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9431             enddo
9432           enddo
9433         enddo
9434       else
9435 C Antiparallel orientation
9436 C Contribution from graph III
9437 c        goto 1110
9438         call transpose2(EUg(1,1,j),auxmat(1,1))
9439         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9440         vv(1)=pizda(1,1)-pizda(2,2)
9441         vv(2)=pizda(1,2)+pizda(2,1)
9442         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9443      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9444 C Explicit gradient in virtual-dihedral angles.
9445         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9446      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9447      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9448         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9449         vv(1)=pizda(1,1)-pizda(2,2)
9450         vv(2)=pizda(1,2)+pizda(2,1)
9451         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9452      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9453      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9454         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9455         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9456         vv(1)=pizda(1,1)-pizda(2,2)
9457         vv(2)=pizda(1,2)+pizda(2,1)
9458         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9459      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9460      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9461 C Cartesian gradient
9462         do iii=1,2
9463           do kkk=1,5
9464             do lll=1,3
9465               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9466      &          pizda(1,1))
9467               vv(1)=pizda(1,1)-pizda(2,2)
9468               vv(2)=pizda(1,2)+pizda(2,1)
9469               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9470      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9471      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9472             enddo
9473           enddo
9474         enddo
9475 cd        goto 1112
9476 C Contribution from graph IV
9477 1110    continue
9478         call transpose2(EE(1,1,itj),auxmat(1,1))
9479         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9480         vv(1)=pizda(1,1)+pizda(2,2)
9481         vv(2)=pizda(2,1)-pizda(1,2)
9482         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9483      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9484 C Explicit gradient in virtual-dihedral angles.
9485         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9486      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9487         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9488         vv(1)=pizda(1,1)+pizda(2,2)
9489         vv(2)=pizda(2,1)-pizda(1,2)
9490         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9491      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9492      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9493 C Cartesian gradient
9494         do iii=1,2
9495           do kkk=1,5
9496             do lll=1,3
9497               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9498      &          pizda(1,1))
9499               vv(1)=pizda(1,1)+pizda(2,2)
9500               vv(2)=pizda(2,1)-pizda(1,2)
9501               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9502      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9503      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9504             enddo
9505           enddo
9506         enddo
9507       endif
9508 1112  continue
9509       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9510 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9511 cd        write (2,*) 'ijkl',i,j,k,l
9512 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9513 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9514 cd      endif
9515 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9516 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9517 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9518 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9519       if (j.lt.nres-1) then
9520         j1=j+1
9521         j2=j-1
9522       else
9523         j1=j-1
9524         j2=j-2
9525       endif
9526       if (l.lt.nres-1) then
9527         l1=l+1
9528         l2=l-1
9529       else
9530         l1=l-1
9531         l2=l-2
9532       endif
9533 cd      eij=1.0d0
9534 cd      ekl=1.0d0
9535 cd      ekont=1.0d0
9536 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9537 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9538 C        summed up outside the subrouine as for the other subroutines
9539 C        handling long-range interactions. The old code is commented out
9540 C        with "cgrad" to keep track of changes.
9541       do ll=1,3
9542 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9543 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9544         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9545         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9546 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9547 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9548 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9549 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9550 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9551 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9552 c     &   gradcorr5ij,
9553 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9554 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9555 cgrad        ghalf=0.5d0*ggg1(ll)
9556 cd        ghalf=0.0d0
9557         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9558         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9559         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9560         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9561         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9562         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9563 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9564 cgrad        ghalf=0.5d0*ggg2(ll)
9565 cd        ghalf=0.0d0
9566         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9567         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9568         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9569         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9570         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9571         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9572       enddo
9573 cd      goto 1112
9574 cgrad      do m=i+1,j-1
9575 cgrad        do ll=1,3
9576 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9577 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9578 cgrad        enddo
9579 cgrad      enddo
9580 cgrad      do m=k+1,l-1
9581 cgrad        do ll=1,3
9582 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9583 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9584 cgrad        enddo
9585 cgrad      enddo
9586 c1112  continue
9587 cgrad      do m=i+2,j2
9588 cgrad        do ll=1,3
9589 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9590 cgrad        enddo
9591 cgrad      enddo
9592 cgrad      do m=k+2,l2
9593 cgrad        do ll=1,3
9594 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9595 cgrad        enddo
9596 cgrad      enddo
9597 cd      do iii=1,nres-3
9598 cd        write (2,*) iii,g_corr5_loc(iii)
9599 cd      enddo
9600       eello5=ekont*eel5
9601 cd      write (2,*) 'ekont',ekont
9602 cd      write (iout,*) 'eello5',ekont*eel5
9603       return
9604       end
9605 c--------------------------------------------------------------------------
9606       double precision function eello6(i,j,k,l,jj,kk)
9607       implicit real*8 (a-h,o-z)
9608       include 'DIMENSIONS'
9609       include 'COMMON.IOUNITS'
9610       include 'COMMON.CHAIN'
9611       include 'COMMON.DERIV'
9612       include 'COMMON.INTERACT'
9613       include 'COMMON.CONTACTS'
9614       include 'COMMON.TORSION'
9615       include 'COMMON.VAR'
9616       include 'COMMON.GEO'
9617       include 'COMMON.FFIELD'
9618       double precision ggg1(3),ggg2(3)
9619 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9620 cd        eello6=0.0d0
9621 cd        return
9622 cd      endif
9623 cd      write (iout,*)
9624 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9625 cd     &   ' and',k,l
9626       eello6_1=0.0d0
9627       eello6_2=0.0d0
9628       eello6_3=0.0d0
9629       eello6_4=0.0d0
9630       eello6_5=0.0d0
9631       eello6_6=0.0d0
9632 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9633 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9634       do iii=1,2
9635         do kkk=1,5
9636           do lll=1,3
9637             derx(lll,kkk,iii)=0.0d0
9638           enddo
9639         enddo
9640       enddo
9641 cd      eij=facont_hb(jj,i)
9642 cd      ekl=facont_hb(kk,k)
9643 cd      ekont=eij*ekl
9644 cd      eij=1.0d0
9645 cd      ekl=1.0d0
9646 cd      ekont=1.0d0
9647       if (l.eq.j+1) then
9648         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9649         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9650         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9651         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9652         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9653         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9654       else
9655         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9656         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9657         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9658         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9659         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9660           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9661         else
9662           eello6_5=0.0d0
9663         endif
9664         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9665       endif
9666 C If turn contributions are considered, they will be handled separately.
9667       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9668 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9669 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9670 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9671 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9672 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9673 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9674 cd      goto 1112
9675       if (j.lt.nres-1) then
9676         j1=j+1
9677         j2=j-1
9678       else
9679         j1=j-1
9680         j2=j-2
9681       endif
9682       if (l.lt.nres-1) then
9683         l1=l+1
9684         l2=l-1
9685       else
9686         l1=l-1
9687         l2=l-2
9688       endif
9689       do ll=1,3
9690 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9691 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9692 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9693 cgrad        ghalf=0.5d0*ggg1(ll)
9694 cd        ghalf=0.0d0
9695         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9696         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9697         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9698         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9699         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9700         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9701         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9702         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9703 cgrad        ghalf=0.5d0*ggg2(ll)
9704 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9705 cd        ghalf=0.0d0
9706         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9707         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9708         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9709         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9710         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9711         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9712       enddo
9713 cd      goto 1112
9714 cgrad      do m=i+1,j-1
9715 cgrad        do ll=1,3
9716 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9717 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9718 cgrad        enddo
9719 cgrad      enddo
9720 cgrad      do m=k+1,l-1
9721 cgrad        do ll=1,3
9722 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9723 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9724 cgrad        enddo
9725 cgrad      enddo
9726 cgrad1112  continue
9727 cgrad      do m=i+2,j2
9728 cgrad        do ll=1,3
9729 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9730 cgrad        enddo
9731 cgrad      enddo
9732 cgrad      do m=k+2,l2
9733 cgrad        do ll=1,3
9734 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9735 cgrad        enddo
9736 cgrad      enddo
9737 cd      do iii=1,nres-3
9738 cd        write (2,*) iii,g_corr6_loc(iii)
9739 cd      enddo
9740       eello6=ekont*eel6
9741 cd      write (2,*) 'ekont',ekont
9742 cd      write (iout,*) 'eello6',ekont*eel6
9743       return
9744       end
9745 c--------------------------------------------------------------------------
9746       double precision function eello6_graph1(i,j,k,l,imat,swap)
9747       implicit real*8 (a-h,o-z)
9748       include 'DIMENSIONS'
9749       include 'COMMON.IOUNITS'
9750       include 'COMMON.CHAIN'
9751       include 'COMMON.DERIV'
9752       include 'COMMON.INTERACT'
9753       include 'COMMON.CONTACTS'
9754       include 'COMMON.TORSION'
9755       include 'COMMON.VAR'
9756       include 'COMMON.GEO'
9757       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9758       logical swap
9759       logical lprn
9760       common /kutas/ lprn
9761 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9762 C                                                                              C
9763 C      Parallel       Antiparallel                                             C
9764 C                                                                              C
9765 C          o             o                                                     C
9766 C         /l\           /j\                                                    C
9767 C        /   \         /   \                                                   C
9768 C       /| o |         | o |\                                                  C
9769 C     \ j|/k\|  /   \  |/k\|l /                                                C
9770 C      \ /   \ /     \ /   \ /                                                 C
9771 C       o     o       o     o                                                  C
9772 C       i             i                                                        C
9773 C                                                                              C
9774 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9775       itk=itortyp(itype(k))
9776       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9777       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9778       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9779       call transpose2(EUgC(1,1,k),auxmat(1,1))
9780       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9781       vv1(1)=pizda1(1,1)-pizda1(2,2)
9782       vv1(2)=pizda1(1,2)+pizda1(2,1)
9783       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9784       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9785       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9786       s5=scalar2(vv(1),Dtobr2(1,i))
9787 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9788       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9789       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9790      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9791      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9792      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9793      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9794      & +scalar2(vv(1),Dtobr2der(1,i)))
9795       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9796       vv1(1)=pizda1(1,1)-pizda1(2,2)
9797       vv1(2)=pizda1(1,2)+pizda1(2,1)
9798       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9799       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9800       if (l.eq.j+1) then
9801         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9802      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9803      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9804      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9805      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9806       else
9807         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9808      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9809      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9810      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9811      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9812       endif
9813       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9814       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9815       vv1(1)=pizda1(1,1)-pizda1(2,2)
9816       vv1(2)=pizda1(1,2)+pizda1(2,1)
9817       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9818      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9819      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9820      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9821       do iii=1,2
9822         if (swap) then
9823           ind=3-iii
9824         else
9825           ind=iii
9826         endif
9827         do kkk=1,5
9828           do lll=1,3
9829             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9830             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9831             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9832             call transpose2(EUgC(1,1,k),auxmat(1,1))
9833             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9834      &        pizda1(1,1))
9835             vv1(1)=pizda1(1,1)-pizda1(2,2)
9836             vv1(2)=pizda1(1,2)+pizda1(2,1)
9837             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9838             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9839      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9840             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9841      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9842             s5=scalar2(vv(1),Dtobr2(1,i))
9843             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9844           enddo
9845         enddo
9846       enddo
9847       return
9848       end
9849 c----------------------------------------------------------------------------
9850       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9851       implicit real*8 (a-h,o-z)
9852       include 'DIMENSIONS'
9853       include 'COMMON.IOUNITS'
9854       include 'COMMON.CHAIN'
9855       include 'COMMON.DERIV'
9856       include 'COMMON.INTERACT'
9857       include 'COMMON.CONTACTS'
9858       include 'COMMON.TORSION'
9859       include 'COMMON.VAR'
9860       include 'COMMON.GEO'
9861       logical swap
9862       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9863      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9864       logical lprn
9865       common /kutas/ lprn
9866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9867 C                                                                              C
9868 C      Parallel       Antiparallel                                             C
9869 C                                                                              C
9870 C          o             o                                                     C
9871 C     \   /l\           /j\   /                                                C
9872 C      \ /   \         /   \ /                                                 C
9873 C       o| o |         | o |o                                                  C
9874 C     \ j|/k\|      \  |/k\|l                                                  C
9875 C      \ /   \       \ /   \                                                   C
9876 C       o             o                                                        C
9877 C       i             i                                                        C
9878 C                                                                              C
9879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9880 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9881 C AL 7/4/01 s1 would occur in the sixth-order moment,
9882 C           but not in a cluster cumulant
9883 #ifdef MOMENT
9884       s1=dip(1,jj,i)*dip(1,kk,k)
9885 #endif
9886       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9887       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9888       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9889       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9890       call transpose2(EUg(1,1,k),auxmat(1,1))
9891       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9892       vv(1)=pizda(1,1)-pizda(2,2)
9893       vv(2)=pizda(1,2)+pizda(2,1)
9894       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9895 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9896 #ifdef MOMENT
9897       eello6_graph2=-(s1+s2+s3+s4)
9898 #else
9899       eello6_graph2=-(s2+s3+s4)
9900 #endif
9901 c      eello6_graph2=-s3
9902 C Derivatives in gamma(i-1)
9903       if (i.gt.1) then
9904 #ifdef MOMENT
9905         s1=dipderg(1,jj,i)*dip(1,kk,k)
9906 #endif
9907         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9908         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9909         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9910         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9911 #ifdef MOMENT
9912         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9913 #else
9914         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9915 #endif
9916 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9917       endif
9918 C Derivatives in gamma(k-1)
9919 #ifdef MOMENT
9920       s1=dip(1,jj,i)*dipderg(1,kk,k)
9921 #endif
9922       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9923       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9924       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9925       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9926       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9927       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9928       vv(1)=pizda(1,1)-pizda(2,2)
9929       vv(2)=pizda(1,2)+pizda(2,1)
9930       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9931 #ifdef MOMENT
9932       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9933 #else
9934       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9935 #endif
9936 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9937 C Derivatives in gamma(j-1) or gamma(l-1)
9938       if (j.gt.1) then
9939 #ifdef MOMENT
9940         s1=dipderg(3,jj,i)*dip(1,kk,k)
9941 #endif
9942         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9943         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9944         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9945         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9946         vv(1)=pizda(1,1)-pizda(2,2)
9947         vv(2)=pizda(1,2)+pizda(2,1)
9948         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9949 #ifdef MOMENT
9950         if (swap) then
9951           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9952         else
9953           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9954         endif
9955 #endif
9956         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9957 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9958       endif
9959 C Derivatives in gamma(l-1) or gamma(j-1)
9960       if (l.gt.1) then
9961 #ifdef MOMENT
9962         s1=dip(1,jj,i)*dipderg(3,kk,k)
9963 #endif
9964         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9965         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9966         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9967         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9968         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9969         vv(1)=pizda(1,1)-pizda(2,2)
9970         vv(2)=pizda(1,2)+pizda(2,1)
9971         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9972 #ifdef MOMENT
9973         if (swap) then
9974           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9975         else
9976           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9977         endif
9978 #endif
9979         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9980 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9981       endif
9982 C Cartesian derivatives.
9983       if (lprn) then
9984         write (2,*) 'In eello6_graph2'
9985         do iii=1,2
9986           write (2,*) 'iii=',iii
9987           do kkk=1,5
9988             write (2,*) 'kkk=',kkk
9989             do jjj=1,2
9990               write (2,'(3(2f10.5),5x)')
9991      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9992             enddo
9993           enddo
9994         enddo
9995       endif
9996       do iii=1,2
9997         do kkk=1,5
9998           do lll=1,3
9999 #ifdef MOMENT
10000             if (iii.eq.1) then
10001               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10002             else
10003               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10004             endif
10005 #endif
10006             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10007      &        auxvec(1))
10008             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10009             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10010      &        auxvec(1))
10011             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10012             call transpose2(EUg(1,1,k),auxmat(1,1))
10013             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10014      &        pizda(1,1))
10015             vv(1)=pizda(1,1)-pizda(2,2)
10016             vv(2)=pizda(1,2)+pizda(2,1)
10017             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10018 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10019 #ifdef MOMENT
10020             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10021 #else
10022             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10023 #endif
10024             if (swap) then
10025               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10026             else
10027               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10028             endif
10029           enddo
10030         enddo
10031       enddo
10032       return
10033       end
10034 c----------------------------------------------------------------------------
10035       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10036       implicit real*8 (a-h,o-z)
10037       include 'DIMENSIONS'
10038       include 'COMMON.IOUNITS'
10039       include 'COMMON.CHAIN'
10040       include 'COMMON.DERIV'
10041       include 'COMMON.INTERACT'
10042       include 'COMMON.CONTACTS'
10043       include 'COMMON.TORSION'
10044       include 'COMMON.VAR'
10045       include 'COMMON.GEO'
10046       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10047       logical swap
10048 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10049 C                                                                              C
10050 C      Parallel       Antiparallel                                             C
10051 C                                                                              C
10052 C          o             o                                                     C
10053 C         /l\   /   \   /j\                                                    C
10054 C        /   \ /     \ /   \                                                   C
10055 C       /| o |o       o| o |\                                                  C
10056 C       j|/k\|  /      |/k\|l /                                                C
10057 C        /   \ /       /   \ /                                                 C
10058 C       /     o       /     o                                                  C
10059 C       i             i                                                        C
10060 C                                                                              C
10061 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10062 C
10063 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10064 C           energy moment and not to the cluster cumulant.
10065       iti=itortyp(itype(i))
10066       if (j.lt.nres-1) then
10067         itj1=itortyp(itype(j+1))
10068       else
10069         itj1=ntortyp
10070       endif
10071       itk=itortyp(itype(k))
10072       itk1=itortyp(itype(k+1))
10073       if (l.lt.nres-1) then
10074         itl1=itortyp(itype(l+1))
10075       else
10076         itl1=ntortyp
10077       endif
10078 #ifdef MOMENT
10079       s1=dip(4,jj,i)*dip(4,kk,k)
10080 #endif
10081       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10082       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10083       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10084       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10085       call transpose2(EE(1,1,itk),auxmat(1,1))
10086       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10087       vv(1)=pizda(1,1)+pizda(2,2)
10088       vv(2)=pizda(2,1)-pizda(1,2)
10089       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10090 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10091 cd     & "sum",-(s2+s3+s4)
10092 #ifdef MOMENT
10093       eello6_graph3=-(s1+s2+s3+s4)
10094 #else
10095       eello6_graph3=-(s2+s3+s4)
10096 #endif
10097 c      eello6_graph3=-s4
10098 C Derivatives in gamma(k-1)
10099       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10100       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10101       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10102       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10103 C Derivatives in gamma(l-1)
10104       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10105       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10106       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10107       vv(1)=pizda(1,1)+pizda(2,2)
10108       vv(2)=pizda(2,1)-pizda(1,2)
10109       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10110       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10111 C Cartesian derivatives.
10112       do iii=1,2
10113         do kkk=1,5
10114           do lll=1,3
10115 #ifdef MOMENT
10116             if (iii.eq.1) then
10117               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10118             else
10119               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10120             endif
10121 #endif
10122             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10123      &        auxvec(1))
10124             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10125             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10126      &        auxvec(1))
10127             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10128             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10129      &        pizda(1,1))
10130             vv(1)=pizda(1,1)+pizda(2,2)
10131             vv(2)=pizda(2,1)-pizda(1,2)
10132             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10133 #ifdef MOMENT
10134             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10135 #else
10136             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10137 #endif
10138             if (swap) then
10139               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10140             else
10141               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10142             endif
10143 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10144           enddo
10145         enddo
10146       enddo
10147       return
10148       end
10149 c----------------------------------------------------------------------------
10150       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10151       implicit real*8 (a-h,o-z)
10152       include 'DIMENSIONS'
10153       include 'COMMON.IOUNITS'
10154       include 'COMMON.CHAIN'
10155       include 'COMMON.DERIV'
10156       include 'COMMON.INTERACT'
10157       include 'COMMON.CONTACTS'
10158       include 'COMMON.TORSION'
10159       include 'COMMON.VAR'
10160       include 'COMMON.GEO'
10161       include 'COMMON.FFIELD'
10162       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10163      & auxvec1(2),auxmat1(2,2)
10164       logical swap
10165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10166 C                                                                              C
10167 C      Parallel       Antiparallel                                             C
10168 C                                                                              C
10169 C          o             o                                                     C
10170 C         /l\   /   \   /j\                                                    C
10171 C        /   \ /     \ /   \                                                   C
10172 C       /| o |o       o| o |\                                                  C
10173 C     \ j|/k\|      \  |/k\|l                                                  C
10174 C      \ /   \       \ /   \                                                   C
10175 C       o     \       o     \                                                  C
10176 C       i             i                                                        C
10177 C                                                                              C
10178 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10179 C
10180 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10181 C           energy moment and not to the cluster cumulant.
10182 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10183       iti=itortyp(itype(i))
10184       itj=itortyp(itype(j))
10185       if (j.lt.nres-1) then
10186         itj1=itortyp(itype(j+1))
10187       else
10188         itj1=ntortyp
10189       endif
10190       itk=itortyp(itype(k))
10191       if (k.lt.nres-1) then
10192         itk1=itortyp(itype(k+1))
10193       else
10194         itk1=ntortyp
10195       endif
10196       itl=itortyp(itype(l))
10197       if (l.lt.nres-1) then
10198         itl1=itortyp(itype(l+1))
10199       else
10200         itl1=ntortyp
10201       endif
10202 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10203 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10204 cd     & ' itl',itl,' itl1',itl1
10205 #ifdef MOMENT
10206       if (imat.eq.1) then
10207         s1=dip(3,jj,i)*dip(3,kk,k)
10208       else
10209         s1=dip(2,jj,j)*dip(2,kk,l)
10210       endif
10211 #endif
10212       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10213       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10214       if (j.eq.l+1) then
10215         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10216         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10217       else
10218         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10219         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10220       endif
10221       call transpose2(EUg(1,1,k),auxmat(1,1))
10222       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10223       vv(1)=pizda(1,1)-pizda(2,2)
10224       vv(2)=pizda(2,1)+pizda(1,2)
10225       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10226 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10227 #ifdef MOMENT
10228       eello6_graph4=-(s1+s2+s3+s4)
10229 #else
10230       eello6_graph4=-(s2+s3+s4)
10231 #endif
10232 C Derivatives in gamma(i-1)
10233       if (i.gt.1) then
10234 #ifdef MOMENT
10235         if (imat.eq.1) then
10236           s1=dipderg(2,jj,i)*dip(3,kk,k)
10237         else
10238           s1=dipderg(4,jj,j)*dip(2,kk,l)
10239         endif
10240 #endif
10241         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10242         if (j.eq.l+1) then
10243           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10244           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10245         else
10246           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10247           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10248         endif
10249         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10250         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10251 cd          write (2,*) 'turn6 derivatives'
10252 #ifdef MOMENT
10253           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10254 #else
10255           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10256 #endif
10257         else
10258 #ifdef MOMENT
10259           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10260 #else
10261           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10262 #endif
10263         endif
10264       endif
10265 C Derivatives in gamma(k-1)
10266 #ifdef MOMENT
10267       if (imat.eq.1) then
10268         s1=dip(3,jj,i)*dipderg(2,kk,k)
10269       else
10270         s1=dip(2,jj,j)*dipderg(4,kk,l)
10271       endif
10272 #endif
10273       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10274       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10275       if (j.eq.l+1) then
10276         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10277         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10278       else
10279         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10280         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10281       endif
10282       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10283       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10284       vv(1)=pizda(1,1)-pizda(2,2)
10285       vv(2)=pizda(2,1)+pizda(1,2)
10286       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10287       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10288 #ifdef MOMENT
10289         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10290 #else
10291         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10292 #endif
10293       else
10294 #ifdef MOMENT
10295         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10296 #else
10297         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10298 #endif
10299       endif
10300 C Derivatives in gamma(j-1) or gamma(l-1)
10301       if (l.eq.j+1 .and. l.gt.1) then
10302         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10303         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10304         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10305         vv(1)=pizda(1,1)-pizda(2,2)
10306         vv(2)=pizda(2,1)+pizda(1,2)
10307         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10308         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10309       else if (j.gt.1) then
10310         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10311         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10312         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10313         vv(1)=pizda(1,1)-pizda(2,2)
10314         vv(2)=pizda(2,1)+pizda(1,2)
10315         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10316         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10317           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10318         else
10319           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10320         endif
10321       endif
10322 C Cartesian derivatives.
10323       do iii=1,2
10324         do kkk=1,5
10325           do lll=1,3
10326 #ifdef MOMENT
10327             if (iii.eq.1) then
10328               if (imat.eq.1) then
10329                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10330               else
10331                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10332               endif
10333             else
10334               if (imat.eq.1) then
10335                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10336               else
10337                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10338               endif
10339             endif
10340 #endif
10341             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10342      &        auxvec(1))
10343             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10344             if (j.eq.l+1) then
10345               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10346      &          b1(1,j+1),auxvec(1))
10347               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10348             else
10349               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10350      &          b1(1,l+1),auxvec(1))
10351               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10352             endif
10353             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10354      &        pizda(1,1))
10355             vv(1)=pizda(1,1)-pizda(2,2)
10356             vv(2)=pizda(2,1)+pizda(1,2)
10357             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10358             if (swap) then
10359               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10360 #ifdef MOMENT
10361                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10362      &             -(s1+s2+s4)
10363 #else
10364                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10365      &             -(s2+s4)
10366 #endif
10367                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10368               else
10369 #ifdef MOMENT
10370                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10371 #else
10372                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10373 #endif
10374                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10375               endif
10376             else
10377 #ifdef MOMENT
10378               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10379 #else
10380               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10381 #endif
10382               if (l.eq.j+1) then
10383                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10384               else
10385                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10386               endif
10387             endif
10388           enddo
10389         enddo
10390       enddo
10391       return
10392       end
10393 c----------------------------------------------------------------------------
10394       double precision function eello_turn6(i,jj,kk)
10395       implicit real*8 (a-h,o-z)
10396       include 'DIMENSIONS'
10397       include 'COMMON.IOUNITS'
10398       include 'COMMON.CHAIN'
10399       include 'COMMON.DERIV'
10400       include 'COMMON.INTERACT'
10401       include 'COMMON.CONTACTS'
10402       include 'COMMON.TORSION'
10403       include 'COMMON.VAR'
10404       include 'COMMON.GEO'
10405       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10406      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10407      &  ggg1(3),ggg2(3)
10408       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10409      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10410 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10411 C           the respective energy moment and not to the cluster cumulant.
10412       s1=0.0d0
10413       s8=0.0d0
10414       s13=0.0d0
10415 c
10416       eello_turn6=0.0d0
10417       j=i+4
10418       k=i+1
10419       l=i+3
10420       iti=itortyp(itype(i))
10421       itk=itortyp(itype(k))
10422       itk1=itortyp(itype(k+1))
10423       itl=itortyp(itype(l))
10424       itj=itortyp(itype(j))
10425 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10426 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10427 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10428 cd        eello6=0.0d0
10429 cd        return
10430 cd      endif
10431 cd      write (iout,*)
10432 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10433 cd     &   ' and',k,l
10434 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10435       do iii=1,2
10436         do kkk=1,5
10437           do lll=1,3
10438             derx_turn(lll,kkk,iii)=0.0d0
10439           enddo
10440         enddo
10441       enddo
10442 cd      eij=1.0d0
10443 cd      ekl=1.0d0
10444 cd      ekont=1.0d0
10445       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10446 cd      eello6_5=0.0d0
10447 cd      write (2,*) 'eello6_5',eello6_5
10448 #ifdef MOMENT
10449       call transpose2(AEA(1,1,1),auxmat(1,1))
10450       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10451       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10452       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10453 #endif
10454       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10455       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10456       s2 = scalar2(b1(1,k),vtemp1(1))
10457 #ifdef MOMENT
10458       call transpose2(AEA(1,1,2),atemp(1,1))
10459       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10460       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10461       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10462 #endif
10463       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10464       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10465       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10466 #ifdef MOMENT
10467       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10468       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10469       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10470       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10471       ss13 = scalar2(b1(1,k),vtemp4(1))
10472       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10473 #endif
10474 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10475 c      s1=0.0d0
10476 c      s2=0.0d0
10477 c      s8=0.0d0
10478 c      s12=0.0d0
10479 c      s13=0.0d0
10480       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10481 C Derivatives in gamma(i+2)
10482       s1d =0.0d0
10483       s8d =0.0d0
10484 #ifdef MOMENT
10485       call transpose2(AEA(1,1,1),auxmatd(1,1))
10486       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10487       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10488       call transpose2(AEAderg(1,1,2),atempd(1,1))
10489       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10490       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10491 #endif
10492       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10493       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10494       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10495 c      s1d=0.0d0
10496 c      s2d=0.0d0
10497 c      s8d=0.0d0
10498 c      s12d=0.0d0
10499 c      s13d=0.0d0
10500       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10501 C Derivatives in gamma(i+3)
10502 #ifdef MOMENT
10503       call transpose2(AEA(1,1,1),auxmatd(1,1))
10504       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10505       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10506       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10507 #endif
10508       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10509       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10510       s2d = scalar2(b1(1,k),vtemp1d(1))
10511 #ifdef MOMENT
10512       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10513       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10514 #endif
10515       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10516 #ifdef MOMENT
10517       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10518       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10519       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10520 #endif
10521 c      s1d=0.0d0
10522 c      s2d=0.0d0
10523 c      s8d=0.0d0
10524 c      s12d=0.0d0
10525 c      s13d=0.0d0
10526 #ifdef MOMENT
10527       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10528      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10529 #else
10530       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10531      &               -0.5d0*ekont*(s2d+s12d)
10532 #endif
10533 C Derivatives in gamma(i+4)
10534       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10535       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10536       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10537 #ifdef MOMENT
10538       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10539       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10540       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10541 #endif
10542 c      s1d=0.0d0
10543 c      s2d=0.0d0
10544 c      s8d=0.0d0
10545 C      s12d=0.0d0
10546 c      s13d=0.0d0
10547 #ifdef MOMENT
10548       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10549 #else
10550       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10551 #endif
10552 C Derivatives in gamma(i+5)
10553 #ifdef MOMENT
10554       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10555       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10556       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10557 #endif
10558       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10559       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10560       s2d = scalar2(b1(1,k),vtemp1d(1))
10561 #ifdef MOMENT
10562       call transpose2(AEA(1,1,2),atempd(1,1))
10563       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10564       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10565 #endif
10566       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10567       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10568 #ifdef MOMENT
10569       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10570       ss13d = scalar2(b1(1,k),vtemp4d(1))
10571       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10572 #endif
10573 c      s1d=0.0d0
10574 c      s2d=0.0d0
10575 c      s8d=0.0d0
10576 c      s12d=0.0d0
10577 c      s13d=0.0d0
10578 #ifdef MOMENT
10579       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10580      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10581 #else
10582       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10583      &               -0.5d0*ekont*(s2d+s12d)
10584 #endif
10585 C Cartesian derivatives
10586       do iii=1,2
10587         do kkk=1,5
10588           do lll=1,3
10589 #ifdef MOMENT
10590             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10591             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10592             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10593 #endif
10594             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10595             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10596      &          vtemp1d(1))
10597             s2d = scalar2(b1(1,k),vtemp1d(1))
10598 #ifdef MOMENT
10599             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10600             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10601             s8d = -(atempd(1,1)+atempd(2,2))*
10602      &           scalar2(cc(1,1,itl),vtemp2(1))
10603 #endif
10604             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10605      &           auxmatd(1,1))
10606             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10607             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10608 c      s1d=0.0d0
10609 c      s2d=0.0d0
10610 c      s8d=0.0d0
10611 c      s12d=0.0d0
10612 c      s13d=0.0d0
10613 #ifdef MOMENT
10614             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10615      &        - 0.5d0*(s1d+s2d)
10616 #else
10617             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10618      &        - 0.5d0*s2d
10619 #endif
10620 #ifdef MOMENT
10621             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10622      &        - 0.5d0*(s8d+s12d)
10623 #else
10624             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10625      &        - 0.5d0*s12d
10626 #endif
10627           enddo
10628         enddo
10629       enddo
10630 #ifdef MOMENT
10631       do kkk=1,5
10632         do lll=1,3
10633           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10634      &      achuj_tempd(1,1))
10635           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10636           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10637           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10638           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10639           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10640      &      vtemp4d(1))
10641           ss13d = scalar2(b1(1,k),vtemp4d(1))
10642           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10643           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10644         enddo
10645       enddo
10646 #endif
10647 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10648 cd     &  16*eel_turn6_num
10649 cd      goto 1112
10650       if (j.lt.nres-1) then
10651         j1=j+1
10652         j2=j-1
10653       else
10654         j1=j-1
10655         j2=j-2
10656       endif
10657       if (l.lt.nres-1) then
10658         l1=l+1
10659         l2=l-1
10660       else
10661         l1=l-1
10662         l2=l-2
10663       endif
10664       do ll=1,3
10665 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10666 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10667 cgrad        ghalf=0.5d0*ggg1(ll)
10668 cd        ghalf=0.0d0
10669         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10670         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10671         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10672      &    +ekont*derx_turn(ll,2,1)
10673         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10674         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10675      &    +ekont*derx_turn(ll,4,1)
10676         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10677         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10678         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10679 cgrad        ghalf=0.5d0*ggg2(ll)
10680 cd        ghalf=0.0d0
10681         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10682      &    +ekont*derx_turn(ll,2,2)
10683         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10684         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10685      &    +ekont*derx_turn(ll,4,2)
10686         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10687         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10688         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10689       enddo
10690 cd      goto 1112
10691 cgrad      do m=i+1,j-1
10692 cgrad        do ll=1,3
10693 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10694 cgrad        enddo
10695 cgrad      enddo
10696 cgrad      do m=k+1,l-1
10697 cgrad        do ll=1,3
10698 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10699 cgrad        enddo
10700 cgrad      enddo
10701 cgrad1112  continue
10702 cgrad      do m=i+2,j2
10703 cgrad        do ll=1,3
10704 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10705 cgrad        enddo
10706 cgrad      enddo
10707 cgrad      do m=k+2,l2
10708 cgrad        do ll=1,3
10709 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10710 cgrad        enddo
10711 cgrad      enddo
10712 cd      do iii=1,nres-3
10713 cd        write (2,*) iii,g_corr6_loc(iii)
10714 cd      enddo
10715       eello_turn6=ekont*eel_turn6
10716 cd      write (2,*) 'ekont',ekont
10717 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10718       return
10719       end
10720
10721 C-----------------------------------------------------------------------------
10722       double precision function scalar(u,v)
10723 !DIR$ INLINEALWAYS scalar
10724 #ifndef OSF
10725 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10726 #endif
10727       implicit none
10728       double precision u(3),v(3)
10729 cd      double precision sc
10730 cd      integer i
10731 cd      sc=0.0d0
10732 cd      do i=1,3
10733 cd        sc=sc+u(i)*v(i)
10734 cd      enddo
10735 cd      scalar=sc
10736
10737       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10738       return
10739       end
10740 crc-------------------------------------------------
10741       SUBROUTINE MATVEC2(A1,V1,V2)
10742 !DIR$ INLINEALWAYS MATVEC2
10743 #ifndef OSF
10744 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10745 #endif
10746       implicit real*8 (a-h,o-z)
10747       include 'DIMENSIONS'
10748       DIMENSION A1(2,2),V1(2),V2(2)
10749 c      DO 1 I=1,2
10750 c        VI=0.0
10751 c        DO 3 K=1,2
10752 c    3     VI=VI+A1(I,K)*V1(K)
10753 c        Vaux(I)=VI
10754 c    1 CONTINUE
10755
10756       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10757       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10758
10759       v2(1)=vaux1
10760       v2(2)=vaux2
10761       END
10762 C---------------------------------------
10763       SUBROUTINE MATMAT2(A1,A2,A3)
10764 #ifndef OSF
10765 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10766 #endif
10767       implicit real*8 (a-h,o-z)
10768       include 'DIMENSIONS'
10769       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10770 c      DIMENSION AI3(2,2)
10771 c        DO  J=1,2
10772 c          A3IJ=0.0
10773 c          DO K=1,2
10774 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10775 c          enddo
10776 c          A3(I,J)=A3IJ
10777 c       enddo
10778 c      enddo
10779
10780       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10781       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10782       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10783       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10784
10785       A3(1,1)=AI3_11
10786       A3(2,1)=AI3_21
10787       A3(1,2)=AI3_12
10788       A3(2,2)=AI3_22
10789       END
10790
10791 c-------------------------------------------------------------------------
10792       double precision function scalar2(u,v)
10793 !DIR$ INLINEALWAYS scalar2
10794       implicit none
10795       double precision u(2),v(2)
10796       double precision sc
10797       integer i
10798       scalar2=u(1)*v(1)+u(2)*v(2)
10799       return
10800       end
10801
10802 C-----------------------------------------------------------------------------
10803
10804       subroutine transpose2(a,at)
10805 !DIR$ INLINEALWAYS transpose2
10806 #ifndef OSF
10807 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10808 #endif
10809       implicit none
10810       double precision a(2,2),at(2,2)
10811       at(1,1)=a(1,1)
10812       at(1,2)=a(2,1)
10813       at(2,1)=a(1,2)
10814       at(2,2)=a(2,2)
10815       return
10816       end
10817 c--------------------------------------------------------------------------
10818       subroutine transpose(n,a,at)
10819       implicit none
10820       integer n,i,j
10821       double precision a(n,n),at(n,n)
10822       do i=1,n
10823         do j=1,n
10824           at(j,i)=a(i,j)
10825         enddo
10826       enddo
10827       return
10828       end
10829 C---------------------------------------------------------------------------
10830       subroutine prodmat3(a1,a2,kk,transp,prod)
10831 !DIR$ INLINEALWAYS prodmat3
10832 #ifndef OSF
10833 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10834 #endif
10835       implicit none
10836       integer i,j
10837       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10838       logical transp
10839 crc      double precision auxmat(2,2),prod_(2,2)
10840
10841       if (transp) then
10842 crc        call transpose2(kk(1,1),auxmat(1,1))
10843 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10844 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10845
10846            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10847      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10848            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10849      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10850            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10851      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10852            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10853      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10854
10855       else
10856 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10857 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10858
10859            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10860      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10861            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10862      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10863            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10864      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10865            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10866      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10867
10868       endif
10869 c      call transpose2(a2(1,1),a2t(1,1))
10870
10871 crc      print *,transp
10872 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10873 crc      print *,((prod(i,j),i=1,2),j=1,2)
10874
10875       return
10876       end
10877 CCC----------------------------------------------
10878       subroutine Eliptransfer(eliptran)
10879       implicit real*8 (a-h,o-z)
10880       include 'DIMENSIONS'
10881       include 'COMMON.GEO'
10882       include 'COMMON.VAR'
10883       include 'COMMON.LOCAL'
10884       include 'COMMON.CHAIN'
10885       include 'COMMON.DERIV'
10886       include 'COMMON.NAMES'
10887       include 'COMMON.INTERACT'
10888       include 'COMMON.IOUNITS'
10889       include 'COMMON.CALC'
10890       include 'COMMON.CONTROL'
10891       include 'COMMON.SPLITELE'
10892       include 'COMMON.SBRIDGE'
10893 C this is done by Adasko
10894 C      print *,"wchodze"
10895 C structure of box:
10896 C      water
10897 C--bordliptop-- buffore starts
10898 C--bufliptop--- here true lipid starts
10899 C      lipid
10900 C--buflipbot--- lipid ends buffore starts
10901 C--bordlipbot--buffore ends
10902       eliptran=0.0
10903       do i=ilip_start,ilip_end
10904 C       do i=1,1
10905         if (itype(i).eq.ntyp1) cycle
10906
10907         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10908         if (positi.le.0) positi=positi+boxzsize
10909 C        print *,i
10910 C first for peptide groups
10911 c for each residue check if it is in lipid or lipid water border area
10912        if ((positi.gt.bordlipbot)
10913      &.and.(positi.lt.bordliptop)) then
10914 C the energy transfer exist
10915         if (positi.lt.buflipbot) then
10916 C what fraction I am in
10917          fracinbuf=1.0d0-
10918      &        ((positi-bordlipbot)/lipbufthick)
10919 C lipbufthick is thickenes of lipid buffore
10920          sslip=sscalelip(fracinbuf)
10921          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10922          eliptran=eliptran+sslip*pepliptran
10923          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10924          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10925 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10926
10927 C        print *,"doing sccale for lower part"
10928 C         print *,i,sslip,fracinbuf,ssgradlip
10929         elseif (positi.gt.bufliptop) then
10930          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10931          sslip=sscalelip(fracinbuf)
10932          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10933          eliptran=eliptran+sslip*pepliptran
10934          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10935          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10936 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10937 C          print *, "doing sscalefor top part"
10938 C         print *,i,sslip,fracinbuf,ssgradlip
10939         else
10940          eliptran=eliptran+pepliptran
10941 C         print *,"I am in true lipid"
10942         endif
10943 C       else
10944 C       eliptran=elpitran+0.0 ! I am in water
10945        endif
10946        enddo
10947 C       print *, "nic nie bylo w lipidzie?"
10948 C now multiply all by the peptide group transfer factor
10949 C       eliptran=eliptran*pepliptran
10950 C now the same for side chains
10951 CV       do i=1,1
10952        do i=ilip_start,ilip_end
10953         if (itype(i).eq.ntyp1) cycle
10954         positi=(mod(c(3,i+nres),boxzsize))
10955         if (positi.le.0) positi=positi+boxzsize
10956 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10957 c for each residue check if it is in lipid or lipid water border area
10958 C       respos=mod(c(3,i+nres),boxzsize)
10959 C       print *,positi,bordlipbot,buflipbot
10960        if ((positi.gt.bordlipbot)
10961      & .and.(positi.lt.bordliptop)) then
10962 C the energy transfer exist
10963         if (positi.lt.buflipbot) then
10964          fracinbuf=1.0d0-
10965      &     ((positi-bordlipbot)/lipbufthick)
10966 C lipbufthick is thickenes of lipid buffore
10967          sslip=sscalelip(fracinbuf)
10968          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10969          eliptran=eliptran+sslip*liptranene(itype(i))
10970          gliptranx(3,i)=gliptranx(3,i)
10971      &+ssgradlip*liptranene(itype(i))
10972          gliptranc(3,i-1)= gliptranc(3,i-1)
10973      &+ssgradlip*liptranene(itype(i))
10974 C         print *,"doing sccale for lower part"
10975         elseif (positi.gt.bufliptop) then
10976          fracinbuf=1.0d0-
10977      &((bordliptop-positi)/lipbufthick)
10978          sslip=sscalelip(fracinbuf)
10979          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10980          eliptran=eliptran+sslip*liptranene(itype(i))
10981          gliptranx(3,i)=gliptranx(3,i)
10982      &+ssgradlip*liptranene(itype(i))
10983          gliptranc(3,i-1)= gliptranc(3,i-1)
10984      &+ssgradlip*liptranene(itype(i))
10985 C          print *, "doing sscalefor top part",sslip,fracinbuf
10986         else
10987          eliptran=eliptran+liptranene(itype(i))
10988 C         print *,"I am in true lipid"
10989         endif
10990         endif ! if in lipid or buffor
10991 C       else
10992 C       eliptran=elpitran+0.0 ! I am in water
10993        enddo
10994        return
10995        end
10996 C---------------------------------------------------------
10997 C AFM soubroutine for constant force
10998        subroutine AFMforce(Eafmforce)
10999        implicit real*8 (a-h,o-z)
11000       include 'DIMENSIONS'
11001       include 'COMMON.GEO'
11002       include 'COMMON.VAR'
11003       include 'COMMON.LOCAL'
11004       include 'COMMON.CHAIN'
11005       include 'COMMON.DERIV'
11006       include 'COMMON.NAMES'
11007       include 'COMMON.INTERACT'
11008       include 'COMMON.IOUNITS'
11009       include 'COMMON.CALC'
11010       include 'COMMON.CONTROL'
11011       include 'COMMON.SPLITELE'
11012       include 'COMMON.SBRIDGE'
11013       real*8 diffafm(3)
11014       dist=0.0d0
11015       Eafmforce=0.0d0
11016       do i=1,3
11017       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11018       dist=dist+diffafm(i)**2
11019       enddo
11020       dist=dsqrt(dist)
11021       Eafmforce=-forceAFMconst*(dist-distafminit)
11022       do i=1,3
11023       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11024       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11025       enddo
11026 C      print *,'AFM',Eafmforce
11027       return
11028       end
11029 C---------------------------------------------------------
11030 C AFM subroutine with pseudoconstant velocity
11031        subroutine AFMvel(Eafmforce)
11032        implicit real*8 (a-h,o-z)
11033       include 'DIMENSIONS'
11034       include 'COMMON.GEO'
11035       include 'COMMON.VAR'
11036       include 'COMMON.LOCAL'
11037       include 'COMMON.CHAIN'
11038       include 'COMMON.DERIV'
11039       include 'COMMON.NAMES'
11040       include 'COMMON.INTERACT'
11041       include 'COMMON.IOUNITS'
11042       include 'COMMON.CALC'
11043       include 'COMMON.CONTROL'
11044       include 'COMMON.SPLITELE'
11045       include 'COMMON.SBRIDGE'
11046       real*8 diffafm(3)
11047 C Only for check grad COMMENT if not used for checkgrad
11048 C      totT=3.0d0
11049 C--------------------------------------------------------
11050 C      print *,"wchodze"
11051       dist=0.0d0
11052       Eafmforce=0.0d0
11053       do i=1,3
11054       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11055       dist=dist+diffafm(i)**2
11056       enddo
11057       dist=dsqrt(dist)
11058       Eafmforce=0.5d0*forceAFMconst
11059      & *(distafminit+totTafm*velAFMconst-dist)**2
11060 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11061       do i=1,3
11062       gradafm(i,afmend-1)=-forceAFMconst*
11063      &(distafminit+totTafm*velAFMconst-dist)
11064      &*diffafm(i)/dist
11065       gradafm(i,afmbeg-1)=forceAFMconst*
11066      &(distafminit+totTafm*velAFMconst-dist)
11067      &*diffafm(i)/dist
11068       enddo
11069 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11070       return
11071       end
11072
11073 c----------------------------------------------------------------------------
11074       double precision function sscale2(r,r_cut,r0,rlamb)
11075       implicit none
11076       double precision r,gamm,r_cut,r0,rlamb,rr
11077       rr = dabs(r-r0)
11078 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
11079 c      write (2,*) "rr",rr
11080       if(rr.lt.r_cut-rlamb) then
11081         sscale2=1.0d0
11082       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11083         gamm=(rr-(r_cut-rlamb))/rlamb
11084         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11085       else
11086         sscale2=0d0
11087       endif
11088       return
11089       end
11090 C-----------------------------------------------------------------------
11091       double precision function sscalgrad2(r,r_cut,r0,rlamb)
11092       implicit none
11093       double precision r,gamm,r_cut,r0,rlamb,rr
11094       rr = dabs(r-r0)
11095       if(rr.lt.r_cut-rlamb) then
11096         sscalgrad2=0.0d0
11097       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11098         gamm=(rr-(r_cut-rlamb))/rlamb
11099         if (r.ge.r0) then
11100           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
11101         else
11102           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
11103         endif
11104       else
11105         sscalgrad2=0.0d0
11106       endif
11107       return
11108       end
11109 c----------------------------------------------------------------------------
11110       subroutine e_saxs(Esaxs_constr)
11111       implicit none
11112       include 'DIMENSIONS'
11113 #ifdef MPI
11114       include "mpif.h"
11115       include "COMMON.SETUP"
11116       integer IERR
11117 #endif
11118       include 'COMMON.SBRIDGE'
11119       include 'COMMON.CHAIN'
11120       include 'COMMON.GEO'
11121       include 'COMMON.DERIV'
11122       include 'COMMON.LOCAL'
11123       include 'COMMON.INTERACT'
11124       include 'COMMON.VAR'
11125       include 'COMMON.IOUNITS'
11126       include 'COMMON.MD'
11127       include 'COMMON.CONTROL'
11128       include 'COMMON.NAMES'
11129       include 'COMMON.TIME1'
11130       include 'COMMON.FFIELD'
11131 c
11132       double precision Esaxs_constr
11133       integer i,iint,j,k,l
11134       double precision PgradC(maxSAXS,3,maxres),
11135      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
11136 #ifdef MPI
11137       double precision PgradC_(maxSAXS,3,maxres),
11138      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
11139 #endif
11140       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
11141      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
11142      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
11143      & auxX,auxX1,CACAgrad,Cnorm
11144       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
11145       double precision dist
11146       external dist
11147 c  SAXS restraint penalty function
11148 #ifdef DEBUG
11149       write(iout,*) "------- SAXS penalty function start -------"
11150       write (iout,*) "nsaxs",nsaxs
11151       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
11152       write (iout,*) "Psaxs"
11153       do i=1,nsaxs
11154         write (iout,'(i5,e15.5)') i, Psaxs(i)
11155       enddo
11156 #endif
11157       Esaxs_constr = 0.0d0
11158       do k=1,nsaxs
11159         Pcalc(k)=0.0d0
11160         do j=1,nres
11161           do l=1,3
11162             PgradC(k,l,j)=0.0d0
11163             PgradX(k,l,j)=0.0d0
11164           enddo
11165         enddo
11166       enddo
11167       do i=iatsc_s,iatsc_e
11168        if (itype(i).eq.ntyp1) cycle
11169        do iint=1,nint_gr(i)
11170          do j=istart(i,iint),iend(i,iint)
11171            if (itype(j).eq.ntyp1) cycle
11172 #ifdef ALLSAXS
11173            dijCACA=dist(i,j)
11174            dijCASC=dist(i,j+nres)
11175            dijSCCA=dist(i+nres,j)
11176            dijSCSC=dist(i+nres,j+nres)
11177            sigma2CACA=2.0d0/(pstok**2)
11178            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
11179            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
11180            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
11181            do k=1,nsaxs
11182              dk = distsaxs(k)
11183              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11184              if (itype(j).ne.10) then
11185              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
11186              else
11187              endif
11188              expCASC = 0.0d0
11189              if (itype(i).ne.10) then
11190              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
11191              else
11192              expSCCA = 0.0d0
11193              endif
11194              if (itype(i).ne.10 .and. itype(j).ne.10) then
11195              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
11196              else
11197              expSCSC = 0.0d0
11198              endif
11199              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
11200 #ifdef DEBUG
11201              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11202 #endif
11203              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11204              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
11205              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
11206              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
11207              do l=1,3
11208 c CA CA
11209                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11210                PgradC(k,l,i) = PgradC(k,l,i)-aux
11211                PgradC(k,l,j) = PgradC(k,l,j)+aux
11212 c CA SC
11213                if (itype(j).ne.10) then
11214                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
11215                PgradC(k,l,i) = PgradC(k,l,i)-aux
11216                PgradC(k,l,j) = PgradC(k,l,j)+aux
11217                PgradX(k,l,j) = PgradX(k,l,j)+aux
11218                endif
11219 c SC CA
11220                if (itype(i).ne.10) then
11221                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
11222                PgradX(k,l,i) = PgradX(k,l,i)-aux
11223                PgradC(k,l,i) = PgradC(k,l,i)-aux
11224                PgradC(k,l,j) = PgradC(k,l,j)+aux
11225                endif
11226 c SC SC
11227                if (itype(i).ne.10 .and. itype(j).ne.10) then
11228                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
11229                PgradC(k,l,i) = PgradC(k,l,i)-aux
11230                PgradC(k,l,j) = PgradC(k,l,j)+aux
11231                PgradX(k,l,i) = PgradX(k,l,i)-aux
11232                PgradX(k,l,j) = PgradX(k,l,j)+aux
11233                endif
11234              enddo ! l
11235            enddo ! k
11236 #else
11237            dijCACA=dist(i,j)
11238            sigma2CACA=scal_rad**2*0.25d0/
11239      &        (restok(itype(j))**2+restok(itype(i))**2)
11240
11241            IF (saxs_cutoff.eq.0) THEN
11242            do k=1,nsaxs
11243              dk = distsaxs(k)
11244              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11245              Pcalc(k) = Pcalc(k)+expCACA
11246              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11247              do l=1,3
11248                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11249                PgradC(k,l,i) = PgradC(k,l,i)-aux
11250                PgradC(k,l,j) = PgradC(k,l,j)+aux
11251              enddo ! l
11252            enddo ! k
11253            ELSE
11254            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
11255            do k=1,nsaxs
11256              dk = distsaxs(k)
11257 c             write (2,*) "ijk",i,j,k
11258              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
11259              if (sss2.eq.0.0d0) cycle
11260              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
11261              if (energy_dec) write(iout,'(a4,3i5,5f10.4)')
11262      &          'saxs',i,j,k,dijCACA,rrr,dk,sss2,ssgrad2
11263              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
11264              Pcalc(k) = Pcalc(k)+expCACA
11265 #ifdef DEBUG
11266              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11267 #endif
11268              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
11269      &             ssgrad2*expCACA/sss2
11270              do l=1,3
11271 c CA CA
11272                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11273                PgradC(k,l,i) = PgradC(k,l,i)+aux
11274                PgradC(k,l,j) = PgradC(k,l,j)-aux
11275              enddo ! l
11276            enddo ! k
11277            ENDIF
11278 #endif
11279          enddo ! j
11280        enddo ! iint
11281       enddo ! i
11282 #ifdef MPI
11283       if (nfgtasks.gt.1) then
11284         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
11285      &    MPI_SUM,king,FG_COMM,IERR)
11286         if (fg_rank.eq.king) then
11287           do k=1,nsaxs
11288             Pcalc(k) = Pcalc_(k)
11289           enddo
11290         endif
11291         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
11292      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11293         if (fg_rank.eq.king) then
11294           do i=1,nres
11295             do l=1,3
11296               do k=1,nsaxs
11297                 PgradC(k,l,i) = PgradC_(k,l,i)
11298               enddo
11299             enddo
11300           enddo
11301         endif
11302 #ifdef ALLSAXS
11303         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
11304      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11305         if (fg_rank.eq.king) then
11306           do i=1,nres
11307             do l=1,3
11308               do k=1,nsaxs
11309                 PgradX(k,l,i) = PgradX_(k,l,i)
11310               enddo
11311             enddo
11312           enddo
11313         endif
11314 #endif
11315       endif
11316 #endif
11317 #ifdef MPI
11318       if (fg_rank.eq.king) then
11319 #endif
11320       Cnorm = 0.0d0
11321       do k=1,nsaxs
11322         Cnorm = Cnorm + Pcalc(k)
11323       enddo
11324       Esaxs_constr = dlog(Cnorm)-wsaxs0
11325       do k=1,nsaxs
11326         if (Pcalc(k).gt.0.0d0)
11327      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
11328 #ifdef DEBUG
11329         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
11330 #endif
11331       enddo
11332 #ifdef DEBUG
11333       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
11334 #endif
11335       do i=nnt,nct
11336         do l=1,3
11337           auxC=0.0d0
11338           auxC1=0.0d0
11339           auxX=0.0d0
11340           auxX1=0.d0
11341           do k=1,nsaxs
11342             if (Pcalc(k).gt.0)
11343      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
11344             auxC1 = auxC1+PgradC(k,l,i)
11345 #ifdef ALLSAXS
11346             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
11347             auxX1 = auxX1+PgradX(k,l,i)
11348 #endif
11349           enddo
11350           gsaxsC(l,i) = auxC - auxC1/Cnorm
11351 #ifdef ALLSAXS
11352           gsaxsX(l,i) = auxX - auxX1/Cnorm
11353 #endif
11354 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
11355 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
11356         enddo
11357       enddo
11358 #ifdef MPI
11359       endif
11360 #endif
11361       return
11362       end
11363 c----------------------------------------------------------------------------
11364       subroutine e_saxsC(Esaxs_constr)
11365       implicit none
11366       include 'DIMENSIONS'
11367 #ifdef MPI
11368       include "mpif.h"
11369       include "COMMON.SETUP"
11370       integer IERR
11371 #endif
11372       include 'COMMON.SBRIDGE'
11373       include 'COMMON.CHAIN'
11374       include 'COMMON.GEO'
11375       include 'COMMON.DERIV'
11376       include 'COMMON.LOCAL'
11377       include 'COMMON.INTERACT'
11378       include 'COMMON.VAR'
11379       include 'COMMON.IOUNITS'
11380       include 'COMMON.MD'
11381       include 'COMMON.CONTROL'
11382       include 'COMMON.NAMES'
11383       include 'COMMON.TIME1'
11384       include 'COMMON.FFIELD'
11385 c
11386       double precision Esaxs_constr
11387       integer i,iint,j,k,l
11388       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
11389 #ifdef MPI
11390       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
11391 #endif
11392       double precision dk,dijCASPH,dijSCSPH,
11393      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
11394      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
11395      & auxX,auxX1,Cnorm
11396 c  SAXS restraint penalty function
11397 #ifdef DEBUG
11398       write(iout,*) "------- SAXS penalty function start -------"
11399       write (iout,*) "nsaxs",nsaxs
11400
11401       do i=nnt,nct
11402         print *,MyRank,"C",i,(C(j,i),j=1,3)
11403       enddo
11404       do i=nnt,nct
11405         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
11406       enddo
11407 #endif
11408       Esaxs_constr = 0.0d0
11409       logPtot=0.0d0
11410       do j=isaxs_start,isaxs_end
11411         Pcalc=0.0d0
11412         do i=1,nres
11413           do l=1,3
11414             PgradC(l,i)=0.0d0
11415             PgradX(l,i)=0.0d0
11416           enddo
11417         enddo
11418         do i=nnt,nct
11419           if (itype(i).eq.ntyp1) cycle
11420           dijCASPH=0.0d0
11421           dijSCSPH=0.0d0
11422           do l=1,3
11423             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
11424           enddo
11425           if (itype(i).ne.10) then
11426           do l=1,3
11427             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
11428           enddo
11429           endif
11430           sigma2CA=2.0d0/pstok**2
11431           sigma2SC=4.0d0/restok(itype(i))**2
11432           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
11433           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
11434           Pcalc = Pcalc+expCASPH+expSCSPH
11435 #ifdef DEBUG
11436           write(*,*) "processor i j Pcalc",
11437      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
11438 #endif
11439           CASPHgrad = sigma2CA*expCASPH
11440           SCSPHgrad = sigma2SC*expSCSPH
11441           do l=1,3
11442             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
11443             PgradX(l,i) = PgradX(l,i) + aux
11444             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
11445           enddo ! l
11446         enddo ! i
11447         do i=nnt,nct
11448           do l=1,3
11449             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
11450             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
11451           enddo
11452         enddo
11453         logPtot = logPtot - dlog(Pcalc)
11454 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
11455 c     &    " logPtot",logPtot
11456       enddo ! j
11457 #ifdef MPI
11458       if (nfgtasks.gt.1) then
11459 c        write (iout,*) "logPtot before reduction",logPtot
11460         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
11461      &    MPI_SUM,king,FG_COMM,IERR)
11462         logPtot = logPtot_
11463 c        write (iout,*) "logPtot after reduction",logPtot
11464         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
11465      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11466         if (fg_rank.eq.king) then
11467           do i=1,nres
11468             do l=1,3
11469               gsaxsC(l,i) = gsaxsC_(l,i)
11470             enddo
11471           enddo
11472         endif
11473         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
11474      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11475         if (fg_rank.eq.king) then
11476           do i=1,nres
11477             do l=1,3
11478               gsaxsX(l,i) = gsaxsX_(l,i)
11479             enddo
11480           enddo
11481         endif
11482       endif
11483 #endif
11484       Esaxs_constr = logPtot
11485       return
11486       end