source/unres/src-HCD-5D/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit none
   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       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  34      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  35      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  36      & eliptran,Eafmforce,Etube,
  37      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  38       integer n_corr,n_corr1
  39 #ifdef MPI
  40 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  41 c     & " nfgtasks",nfgtasks
  42       if (nfgtasks.gt.1) then
  43         time00=MPI_Wtime()
  44 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  45         if (fg_rank.eq.0) then
  46           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  47 c          print *,"Processor",myrank," BROADCAST iorder"
  48 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  49 C FG slaves as WEIGHTS array.
  50           weights_(1)=wsc
  51           weights_(2)=wscp
  52           weights_(3)=welec
  53           weights_(4)=wcorr
  54           weights_(5)=wcorr5
  55           weights_(6)=wcorr6
  56           weights_(7)=wel_loc
  57           weights_(8)=wturn3
  58           weights_(9)=wturn4
  59           weights_(10)=wturn6
  60           weights_(11)=wang
  61           weights_(12)=wscloc
  62           weights_(13)=wtor
  63           weights_(14)=wtor_d
  64           weights_(15)=wstrain
  65           weights_(16)=wvdwpp
  66           weights_(17)=wbond
  67           weights_(18)=scal14
  68           weights_(21)=wsccor
  69           weights_(22)=wtube
  70           weights_(26)=wsaxs
  71           weights_(28)=wdfa_dist
  72           weights_(29)=wdfa_tor
  73           weights_(30)=wdfa_nei
  74           weights_(31)=wdfa_beta
  75 C FG Master broadcasts the WEIGHTS_ array
  76           call MPI_Bcast(weights_(1),n_ene,
  77      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  78         else
  79 C FG slaves receive the WEIGHTS array
  80           call MPI_Bcast(weights(1),n_ene,
  81      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  82           wsc=weights(1)
  83           wscp=weights(2)
  84           welec=weights(3)
  85           wcorr=weights(4)
  86           wcorr5=weights(5)
  87           wcorr6=weights(6)
  88           wel_loc=weights(7)
  89           wturn3=weights(8)
  90           wturn4=weights(9)
  91           wturn6=weights(10)
  92           wang=weights(11)
  93           wscloc=weights(12)
  94           wtor=weights(13)
  95           wtor_d=weights(14)
  96           wstrain=weights(15)
  97           wvdwpp=weights(16)
  98           wbond=weights(17)
  99           scal14=weights(18)
 100           wsccor=weights(21)
 101           wtube=weights(22)
 102           wsaxs=weights(26)
 103           wdfa_dist=weights_(28)
 104           wdfa_tor=weights_(29)
 105           wdfa_nei=weights_(30)
 106           wdfa_beta=weights_(31)
 107         endif
 108         time_Bcast=time_Bcast+MPI_Wtime()-time00
 109         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 110 c        call chainbuild_cart
 111       endif
 112 #ifndef DFA
 113       edfadis=0.0d0
 114       edfator=0.0d0
 115       edfanei=0.0d0
 116       edfabet=0.0d0
 117 #endif
 118 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 119 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 120 #else
 121 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 122 c        call int_from_cart1(.false.)
 123 c      endif
 124 #endif
 125 #ifdef TIMING
 126       time00=MPI_Wtime()
 127 #endif
 128 C
 129 C Compute the side-chain and electrostatic interaction energy
 130 C
 131 C      print *,ipot
 132       goto (101,102,103,104,105,106) ipot
 133 C Lennard-Jones potential.
 134   101 call elj(evdw)
 135 cd    print '(a)','Exit ELJ'
 136       goto 107
 137 C Lennard-Jones-Kihara potential (shifted).
 138   102 call eljk(evdw)
 139       goto 107
 140 C Berne-Pechukas potential (dilated LJ, angular dependence).
 141   103 call ebp(evdw)
 142       goto 107
 143 C Gay-Berne potential (shifted LJ, angular dependence).
 144   104 call egb(evdw)
 145 C      print *,"bylem w egb"
 146       goto 107
 147 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 148   105 call egbv(evdw)
 149       goto 107
 150 C Soft-sphere potential
 151   106 call e_softsphere(evdw)
 152 C
 153 C Calculate electrostatic (H-bonding) energy of the main chain.
 154 C
 155   107 continue
 156 #ifdef DFA
 157 C     BARTEK for dfa test!
 158       if (wdfa_dist.gt.0) then
 159         call edfad(edfadis)
 160       else
 161         edfadis=0
 162       endif
 163 c      print*, 'edfad is finished!', edfadis
 164       if (wdfa_tor.gt.0) then
 165         call edfat(edfator)
 166       else
 167         edfator=0
 168       endif
 169 c      print*, 'edfat is finished!', edfator
 170       if (wdfa_nei.gt.0) then
 171         call edfan(edfanei)
 172       else
 173         edfanei=0
 174       endif
 175 c      print*, 'edfan is finished!', edfanei
 176       if (wdfa_beta.gt.0) then
 177         call edfab(edfabet)
 178       else
 179         edfabet=0
 180       endif
 181 #endif
 182 cmc
 183 cmc Sep-06: egb takes care of dynamic ss bonds too
 184 cmc
 185 c      if (dyn_ss) call dyn_set_nss
 186
 187 c      print *,"Processor",myrank," computed USCSC"
 188 #ifdef TIMING
 189       time01=MPI_Wtime()
 190 #endif
 191       call vec_and_deriv
 192 #ifdef TIMING
 193       time_vec=time_vec+MPI_Wtime()-time01
 194 #endif
 195 C Introduction of shielding effect first for each peptide group
 196 C the shielding factor is set this factor is describing how each
 197 C peptide group is shielded by side-chains
 198 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 199 C      write (iout,*) "shield_mode",shield_mode
 200       if (shield_mode.eq.1) then
 201        call set_shield_fac
 202       else if  (shield_mode.eq.2) then
 203        call set_shield_fac2
 204       endif
 205 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 206       if (ipot.lt.6) then
 207 #ifdef SPLITELE
 208          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 209      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 210      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 211      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 212 #else
 213          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 214      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 215      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 216      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 217 #endif
 218             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 219          else
 220             ees=0.0d0
 221             evdw1=0.0d0
 222             eel_loc=0.0d0
 223             eello_turn3=0.0d0
 224             eello_turn4=0.0d0
 225          endif
 226       else
 227         write (iout,*) "Soft-spheer ELEC potential"
 228 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 229 c     &   eello_turn4)
 230       endif
 231 c#ifdef TIMING
 232 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 233 c#endif
 234 c      print *,"Processor",myrank," computed UELEC"
 235 C
 236 C Calculate excluded-volume interaction energy between peptide groups
 237 C and side chains.
 238 C
 239       if (ipot.lt.6) then
 240        if(wscp.gt.0d0) then
 241         call escp(evdw2,evdw2_14)
 242        else
 243         evdw2=0
 244         evdw2_14=0
 245        endif
 246       else
 247 c        write (iout,*) "Soft-sphere SCP potential"
 248         call escp_soft_sphere(evdw2,evdw2_14)
 249       endif
 250 c
 251 c Calculate the bond-stretching energy
 252 c
 253       call ebond(estr)
 254 C
 255 C Calculate the disulfide-bridge and other energy and the contributions
 256 C from other distance constraints.
 257 cd      write (iout,*) 'Calling EHPB'
 258       call edis(ehpb)
 259 cd    print *,'EHPB exitted succesfully.'
 260 C
 261 C Calculate the virtual-bond-angle energy.
 262 C
 263       if (wang.gt.0d0) then
 264        if (tor_mode.eq.0) then
 265          call ebend(ebe)
 266        else
 267 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 268 C energy function
 269          call ebend_kcc(ebe)
 270        endif
 271       else
 272         ebe=0.0d0
 273       endif
 274       ethetacnstr=0.0d0
 275       if (with_theta_constr) call etheta_constr(ethetacnstr)
 276 c      print *,"Processor",myrank," computed UB"
 277 C
 278 C Calculate the SC local energy.
 279 C
 280 C      print *,"TU DOCHODZE?"
 281       call esc(escloc)
 282 c      print *,"Processor",myrank," computed USC"
 283 C
 284 C Calculate the virtual-bond torsional energy.
 285 C
 286 cd    print *,'nterm=',nterm
 287 C      print *,"tor",tor_mode
 288       if (wtor.gt.0.0d0) then
 289          if (tor_mode.eq.0) then
 290            call etor(etors)
 291          else
 292 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 293 C energy function
 294            call etor_kcc(etors)
 295          endif
 296       else
 297         etors=0.0d0
 298       endif
 299       edihcnstr=0.0d0
 300       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 301 c      print *,"Processor",myrank," computed Utor"
 302       if (constr_homology.ge.1) then
 303         call e_modeller(ehomology_constr)
 304 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 305 c     &  'Processor',fg_rank,' CG group',kolor,
 306 c     &  ' absolute rank',MyRank
 307       else
 308         ehomology_constr=0.0d0
 309       endif
 310 C
 311 C 6/23/01 Calculate double-torsional energy
 312 C
 313       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 314         call etor_d(etors_d)
 315       else
 316         etors_d=0
 317       endif
 318 c      print *,"Processor",myrank," computed Utord"
 319 C
 320 C 21/5/07 Calculate local sicdechain correlation energy
 321 C
 322       if (wsccor.gt.0.0d0) then
 323         call eback_sc_corr(esccor)
 324       else
 325         esccor=0.0d0
 326       endif
 327 C      print *,"PRZED MULIt"
 328 c      print *,"Processor",myrank," computed Usccorr"
 329 C
 330 C 12/1/95 Multi-body terms
 331 C
 332       n_corr=0
 333       n_corr1=0
 334       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 335      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 336          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 337 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 338 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 339 c        call flush(iout)
 340       else
 341          ecorr=0.0d0
 342          ecorr5=0.0d0
 343          ecorr6=0.0d0
 344          eturn6=0.0d0
 345       endif
 346       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 347 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 348 c     &     n_corr,n_corr1
 349 c         call flush(iout)
 350          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 351 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 352 c     &     n_corr1
 353 c         call flush(iout)
 354       endif
 355 c      print *,"Processor",myrank," computed Ucorr"
 356 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 357       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 358         call e_saxs(Esaxs_constr)
 359 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 360       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 361         call e_saxsC(Esaxs_constr)
 362 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 363       else
 364         Esaxs_constr = 0.0d0
 365       endif
 366 C
 367 C If performing constraint dynamics, call the constraint energy
 368 C  after the equilibration time
 369 c      if(usampl.and.totT.gt.eq_time) then
 370 c      write (iout,*) "usampl",usampl
 371       if(usampl) then
 372          call EconstrQ
 373          if (loc_qlike) then
 374            call Econstr_back_qlike
 375          else
 376            call Econstr_back
 377          endif
 378       else
 379          Uconst=0.0d0
 380          Uconst_back=0.0d0
 381       endif
 382 C 01/27/2015 added by adasko
 383 C the energy component below is energy transfer into lipid environment
 384 C based on partition function
 385 C      print *,"przed lipidami"
 386       if (wliptran.gt.0) then
 387         call Eliptransfer(eliptran)
 388       endif
 389 C      print *,"za lipidami"
 390       if (AFMlog.gt.0) then
 391         call AFMforce(Eafmforce)
 392       else if (selfguide.gt.0) then
 393         call AFMvel(Eafmforce)
 394       endif
 395       if (TUBElog.eq.1) then
 396 C      print *,"just before call"
 397         call calctube(Etube)
 398        elseif (TUBElog.eq.2) then
 399         call calctube2(Etube)
 400        else
 401        Etube=0.0d0
 402        endif
 403
 404 #ifdef TIMING
 405       time_enecalc=time_enecalc+MPI_Wtime()-time00
 406 #endif
 407 c      print *,"Processor",myrank," computed Uconstr"
 408 #ifdef TIMING
 409       time00=MPI_Wtime()
 410 #endif
 411 c
 412 C Sum the energies
 413 C
 414       energia(1)=evdw
 415 #ifdef SCP14
 416       energia(2)=evdw2-evdw2_14
 417       energia(18)=evdw2_14
 418 #else
 419       energia(2)=evdw2
 420       energia(18)=0.0d0
 421 #endif
 422 #ifdef SPLITELE
 423       energia(3)=ees
 424       energia(16)=evdw1
 425 #else
 426       energia(3)=ees+evdw1
 427       energia(16)=0.0d0
 428 #endif
 429       energia(4)=ecorr
 430       energia(5)=ecorr5
 431       energia(6)=ecorr6
 432       energia(7)=eel_loc
 433       energia(8)=eello_turn3
 434       energia(9)=eello_turn4
 435       energia(10)=eturn6
 436       energia(11)=ebe
 437       energia(12)=escloc
 438       energia(13)=etors
 439       energia(14)=etors_d
 440       energia(15)=ehpb
 441       energia(19)=edihcnstr
 442       energia(17)=estr
 443       energia(20)=Uconst+Uconst_back
 444       energia(21)=esccor
 445       energia(22)=eliptran
 446       energia(23)=Eafmforce
 447       energia(24)=ethetacnstr
 448       energia(25)=Etube
 449       energia(26)=Esaxs_constr
 450       energia(27)=ehomology_constr
 451       energia(28)=edfadis
 452       energia(29)=edfator
 453       energia(30)=edfanei
 454       energia(31)=edfabet
 455 c      write (iout,*) "esaxs_constr",energia(26)
 456 c    Here are the energies showed per procesor if the are more processors
 457 c    per molecule then we sum it up in sum_energy subroutine
 458 c      print *," Processor",myrank," calls SUM_ENERGY"
 459       call sum_energy(energia,.true.)
 460 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 461       if (dyn_ss) call dyn_set_nss
 462 c      print *," Processor",myrank," left SUM_ENERGY"
 463 #ifdef TIMING
 464       time_sumene=time_sumene+MPI_Wtime()-time00
 465 #endif
 466       return
 467       end
 468 c-------------------------------------------------------------------------------
 469       subroutine sum_energy(energia,reduce)
 470       implicit none
 471       include 'DIMENSIONS'
 472 #ifndef ISNAN
 473       external proc_proc
 474 #ifdef WINPGI
 475 cMS$ATTRIBUTES C ::  proc_proc
 476 #endif
 477 #endif
 478 #ifdef MPI
 479       include "mpif.h"
 480       integer ierr
 481       double precision time00
 482 #endif
 483       include 'COMMON.SETUP'
 484       include 'COMMON.IOUNITS'
 485       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 486       include 'COMMON.FFIELD'
 487       include 'COMMON.DERIV'
 488       include 'COMMON.INTERACT'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.CHAIN'
 491       include 'COMMON.VAR'
 492       include 'COMMON.CONTROL'
 493       include 'COMMON.TIME1'
 494       logical reduce
 495       integer i
 496       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 497      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 498      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 499      & eliptran,Eafmforce,Etube,
 500      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 501       double precision Uconst,etot
 502 #ifdef MPI
 503       if (nfgtasks.gt.1 .and. reduce) then
 504 #ifdef DEBUG
 505         write (iout,*) "energies before REDUCE"
 506         call enerprint(energia)
 507         call flush(iout)
 508 #endif
 509         do i=0,n_ene
 510           enebuff(i)=energia(i)
 511         enddo
 512         time00=MPI_Wtime()
 513         call MPI_Barrier(FG_COMM,IERR)
 514         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 515         time00=MPI_Wtime()
 516         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 517      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 518 #ifdef DEBUG
 519         write (iout,*) "energies after REDUCE"
 520         call enerprint(energia)
 521         call flush(iout)
 522 #endif
 523         time_Reduce=time_Reduce+MPI_Wtime()-time00
 524       endif
 525       if (fg_rank.eq.0) then
 526 #endif
 527       evdw=energia(1)
 528 #ifdef SCP14
 529       evdw2=energia(2)+energia(18)
 530       evdw2_14=energia(18)
 531 #else
 532       evdw2=energia(2)
 533 #endif
 534 #ifdef SPLITELE
 535       ees=energia(3)
 536       evdw1=energia(16)
 537 #else
 538       ees=energia(3)
 539       evdw1=0.0d0
 540 #endif
 541       ecorr=energia(4)
 542       ecorr5=energia(5)
 543       ecorr6=energia(6)
 544       eel_loc=energia(7)
 545       eello_turn3=energia(8)
 546       eello_turn4=energia(9)
 547       eturn6=energia(10)
 548       ebe=energia(11)
 549       escloc=energia(12)
 550       etors=energia(13)
 551       etors_d=energia(14)
 552       ehpb=energia(15)
 553       edihcnstr=energia(19)
 554       estr=energia(17)
 555       Uconst=energia(20)
 556       esccor=energia(21)
 557       eliptran=energia(22)
 558       Eafmforce=energia(23)
 559       ethetacnstr=energia(24)
 560       Etube=energia(25)
 561       esaxs_constr=energia(26)
 562       ehomology_constr=energia(27)
 563       edfadis=energia(28)
 564       edfator=energia(29)
 565       edfanei=energia(30)
 566       edfabet=energia(31)
 567 #ifdef SPLITELE
 568       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 569      & +wang*ebe+wtor*etors+wscloc*escloc
 570      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 571      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 572      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 573      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 574      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 575      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 576      & +wdfa_beta*edfabet
 577 #else
 578       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 579      & +wang*ebe+wtor*etors+wscloc*escloc
 580      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 581      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 582      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 583      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 584      & +Eafmforce
 585      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 586      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 587      & +wdfa_beta*edfabet
 588 #endif
 589       energia(0)=etot
 590 c detecting NaNQ
 591 #ifdef ISNAN
 592 #ifdef AIX
 593       if (isnan(etot).ne.0) energia(0)=1.0d+99
 594 #else
 595       if (isnan(etot)) energia(0)=1.0d+99
 596 #endif
 597 #else
 598       i=0
 599 #ifdef WINPGI
 600       idumm=proc_proc(etot,i)
 601 #else
 602       call proc_proc(etot,i)
 603 #endif
 604       if(i.eq.1)energia(0)=1.0d+99
 605 #endif
 606 #ifdef MPI
 607       endif
 608 #endif
 609       return
 610       end
 611 c-------------------------------------------------------------------------------
 612       subroutine sum_gradient
 613       implicit none
 614       include 'DIMENSIONS'
 615 #ifndef ISNAN
 616       external proc_proc
 617 #ifdef WINPGI
 618 cMS$ATTRIBUTES C ::  proc_proc
 619 #endif
 620 #endif
 621 #ifdef MPI
 622       include 'mpif.h'
 623       integer ierror,ierr
 624       double precision time00,time01
 625 #endif
 626       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 627      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 628      & ,gloc_scbuf(3,-1:maxres)
 629       include 'COMMON.SETUP'
 630       include 'COMMON.IOUNITS'
 631       include 'COMMON.FFIELD'
 632       include 'COMMON.DERIV'
 633       include 'COMMON.INTERACT'
 634       include 'COMMON.SBRIDGE'
 635       include 'COMMON.CHAIN'
 636       include 'COMMON.VAR'
 637       include 'COMMON.CONTROL'
 638       include 'COMMON.TIME1'
 639       include 'COMMON.MAXGRAD'
 640       include 'COMMON.SCCOR'
 641 c      include 'COMMON.MD'
 642       include 'COMMON.QRESTR'
 643       integer i,j,k
 644       double precision scalar
 645       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 646      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 647      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 648      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 649      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 650      &gsclocx_norm
 651 #ifdef TIMING
 652       time01=MPI_Wtime()
 653 #endif
 654 #ifdef DEBUG
 655       write (iout,*) "sum_gradient gvdwc, gvdwx"
 656       do i=1,nres
 657         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 658      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 659       enddo
 660       call flush(iout)
 661 #endif
 662 #ifdef DEBUG
 663       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 664       do i=0,nres
 665         write (iout,'(i3,3e15.5,5x,3e15.5)')
 666      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 667       enddo
 668       call flush(iout)
 669 #endif
 670 #ifdef MPI
 671 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 672         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 673      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 674 #endif
 675 C
 676 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 677 C            in virtual-bond-vector coordinates
 678 C
 679 #ifdef DEBUG
 680 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 681 c      do i=1,nres-1
 682 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 683 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 684 c      enddo
 685 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 686 c      do i=1,nres-1
 687 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 688 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 689 c      enddo
 690       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 691       do i=1,nres
 692         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 693      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 694      &   g_corr5_loc(i)
 695       enddo
 696       call flush(iout)
 697 #endif
 698 #ifdef DEBUG
 699       write (iout,*) "gsaxsc"
 700       do i=1,nres
 701         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 702       enddo
 703       call flush(iout)
 704 #endif
 705 #ifdef SPLITELE
 706       do i=0,nct
 707         do j=1,3
 708           gradbufc(j,i)=wsc*gvdwc(j,i)+
 709      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 710      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 711      &                wel_loc*gel_loc_long(j,i)+
 712      &                wcorr*gradcorr_long(j,i)+
 713      &                wcorr5*gradcorr5_long(j,i)+
 714      &                wcorr6*gradcorr6_long(j,i)+
 715      &                wturn6*gcorr6_turn_long(j,i)+
 716      &                wstrain*ghpbc(j,i)
 717      &                +wliptran*gliptranc(j,i)
 718      &                +gradafm(j,i)
 719      &                +welec*gshieldc(j,i)
 720      &                +wcorr*gshieldc_ec(j,i)
 721      &                +wturn3*gshieldc_t3(j,i)
 722      &                +wturn4*gshieldc_t4(j,i)
 723      &                +wel_loc*gshieldc_ll(j,i)
 724      &                +wtube*gg_tube(j,i)
 725      &                +wsaxs*gsaxsc(j,i)
 726         enddo
 727       enddo
 728 #else
 729       do i=0,nct
 730         do j=1,3
 731           gradbufc(j,i)=wsc*gvdwc(j,i)+
 732      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 733      &                welec*gelc_long(j,i)+
 734      &                wbond*gradb(j,i)+
 735      &                wel_loc*gel_loc_long(j,i)+
 736      &                wcorr*gradcorr_long(j,i)+
 737      &                wcorr5*gradcorr5_long(j,i)+
 738      &                wcorr6*gradcorr6_long(j,i)+
 739      &                wturn6*gcorr6_turn_long(j,i)+
 740      &                wstrain*ghpbc(j,i)
 741      &                +wliptran*gliptranc(j,i)
 742      &                +gradafm(j,i)
 743      &                 +welec*gshieldc(j,i)
 744      &                 +wcorr*gshieldc_ec(j,i)
 745      &                 +wturn4*gshieldc_t4(j,i)
 746      &                 +wel_loc*gshieldc_ll(j,i)
 747      &                +wtube*gg_tube(j,i)
 748      &                +wsaxs*gsaxsc(j,i)
 749         enddo
 750       enddo
 751 #endif
 752       do i=1,nct
 753         do j=1,3
 754           gradbufc(j,i)=gradbufc(j,i)+
 755      &                wdfa_dist*gdfad(j,i)+
 756      &                wdfa_tor*gdfat(j,i)+
 757      &                wdfa_nei*gdfan(j,i)+
 758      &                wdfa_beta*gdfab(j,i)
 759         enddo
 760       enddo
 761 #ifdef DEBUG
 762       write (iout,*) "gradc from gradbufc"
 763       do i=1,nres
 764         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 765       enddo
 766       call flush(iout)
 767 #endif
 768 #ifdef MPI
 769       if (nfgtasks.gt.1) then
 770       time00=MPI_Wtime()
 771 #ifdef DEBUG
 772       write (iout,*) "gradbufc before allreduce"
 773       do i=1,nres
 774         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 775       enddo
 776       call flush(iout)
 777 #endif
 778       do i=0,nres
 779         do j=1,3
 780           gradbufc_sum(j,i)=gradbufc(j,i)
 781         enddo
 782       enddo
 783 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 784 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 785 c      time_reduce=time_reduce+MPI_Wtime()-time00
 786 #ifdef DEBUG
 787 c      write (iout,*) "gradbufc_sum after allreduce"
 788 c      do i=1,nres
 789 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 790 c      enddo
 791 c      call flush(iout)
 792 #endif
 793 #ifdef TIMING
 794 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 795 #endif
 796       do i=nnt,nres
 797         do k=1,3
 798           gradbufc(k,i)=0.0d0
 799         enddo
 800       enddo
 801 #ifdef DEBUG
 802       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 803       write (iout,*) (i," jgrad_start",jgrad_start(i),
 804      &                  " jgrad_end  ",jgrad_end(i),
 805      &                  i=igrad_start,igrad_end)
 806 #endif
 807 c
 808 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 809 c do not parallelize this part.
 810 c
 811 c      do i=igrad_start,igrad_end
 812 c        do j=jgrad_start(i),jgrad_end(i)
 813 c          do k=1,3
 814 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 815 c          enddo
 816 c        enddo
 817 c      enddo
 818       do j=1,3
 819         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 820       enddo
 821       do i=nres-2,-1,-1
 822         do j=1,3
 823           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 824         enddo
 825       enddo
 826 #ifdef DEBUG
 827       write (iout,*) "gradbufc after summing"
 828       do i=1,nres
 829         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 830       enddo
 831       call flush(iout)
 832 #endif
 833       else
 834 #endif
 835 #ifdef DEBUG
 836       write (iout,*) "gradbufc"
 837       do i=1,nres
 838         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 839       enddo
 840       call flush(iout)
 841 #endif
 842       do i=-1,nres
 843         do j=1,3
 844           gradbufc_sum(j,i)=gradbufc(j,i)
 845           gradbufc(j,i)=0.0d0
 846         enddo
 847       enddo
 848       do j=1,3
 849         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 850       enddo
 851       do i=nres-2,-1,-1
 852         do j=1,3
 853           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 854         enddo
 855       enddo
 856 c      do i=nnt,nres-1
 857 c        do k=1,3
 858 c          gradbufc(k,i)=0.0d0
 859 c        enddo
 860 c        do j=i+1,nres
 861 c          do k=1,3
 862 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 863 c          enddo
 864 c        enddo
 865 c      enddo
 866 #ifdef DEBUG
 867       write (iout,*) "gradbufc after summing"
 868       do i=1,nres
 869         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 870       enddo
 871       call flush(iout)
 872 #endif
 873 #ifdef MPI
 874       endif
 875 #endif
 876       do k=1,3
 877         gradbufc(k,nres)=0.0d0
 878       enddo
 879       do i=-1,nct
 880         do j=1,3
 881 #ifdef SPLITELE
 882 C          print *,gradbufc(1,13)
 883 C          print *,welec*gelc(1,13)
 884 C          print *,wel_loc*gel_loc(1,13)
 885 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 886 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 887 C          print *,wel_loc*gel_loc_long(1,13)
 888 C          print *,gradafm(1,13),"AFM"
 889           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 890      &                wel_loc*gel_loc(j,i)+
 891      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 892      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 893      &                wel_loc*gel_loc_long(j,i)+
 894      &                wcorr*gradcorr_long(j,i)+
 895      &                wcorr5*gradcorr5_long(j,i)+
 896      &                wcorr6*gradcorr6_long(j,i)+
 897      &                wturn6*gcorr6_turn_long(j,i))+
 898      &                wbond*gradb(j,i)+
 899      &                wcorr*gradcorr(j,i)+
 900      &                wturn3*gcorr3_turn(j,i)+
 901      &                wturn4*gcorr4_turn(j,i)+
 902      &                wcorr5*gradcorr5(j,i)+
 903      &                wcorr6*gradcorr6(j,i)+
 904      &                wturn6*gcorr6_turn(j,i)+
 905      &                wsccor*gsccorc(j,i)
 906      &               +wscloc*gscloc(j,i)
 907      &               +wliptran*gliptranc(j,i)
 908      &                +gradafm(j,i)
 909      &                 +welec*gshieldc(j,i)
 910      &                 +welec*gshieldc_loc(j,i)
 911      &                 +wcorr*gshieldc_ec(j,i)
 912      &                 +wcorr*gshieldc_loc_ec(j,i)
 913      &                 +wturn3*gshieldc_t3(j,i)
 914      &                 +wturn3*gshieldc_loc_t3(j,i)
 915      &                 +wturn4*gshieldc_t4(j,i)
 916      &                 +wturn4*gshieldc_loc_t4(j,i)
 917      &                 +wel_loc*gshieldc_ll(j,i)
 918      &                 +wel_loc*gshieldc_loc_ll(j,i)
 919      &                +wtube*gg_tube(j,i)
 920
 921 #else
 922           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 923      &                wel_loc*gel_loc(j,i)+
 924      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 925      &                welec*gelc_long(j,i)+
 926      &                wel_loc*gel_loc_long(j,i)+
 927      &                wcorr*gcorr_long(j,i)+
 928      &                wcorr5*gradcorr5_long(j,i)+
 929      &                wcorr6*gradcorr6_long(j,i)+
 930      &                wturn6*gcorr6_turn_long(j,i))+
 931      &                wbond*gradb(j,i)+
 932      &                wcorr*gradcorr(j,i)+
 933      &                wturn3*gcorr3_turn(j,i)+
 934      &                wturn4*gcorr4_turn(j,i)+
 935      &                wcorr5*gradcorr5(j,i)+
 936      &                wcorr6*gradcorr6(j,i)+
 937      &                wturn6*gcorr6_turn(j,i)+
 938      &                wsccor*gsccorc(j,i)
 939      &               +wscloc*gscloc(j,i)
 940      &               +wliptran*gliptranc(j,i)
 941      &                +gradafm(j,i)
 942      &                 +welec*gshieldc(j,i)
 943      &                 +welec*gshieldc_loc(j,i)
 944      &                 +wcorr*gshieldc_ec(j,i)
 945      &                 +wcorr*gshieldc_loc_ec(j,i)
 946      &                 +wturn3*gshieldc_t3(j,i)
 947      &                 +wturn3*gshieldc_loc_t3(j,i)
 948      &                 +wturn4*gshieldc_t4(j,i)
 949      &                 +wturn4*gshieldc_loc_t4(j,i)
 950      &                 +wel_loc*gshieldc_ll(j,i)
 951      &                 +wel_loc*gshieldc_loc_ll(j,i)
 952      &                +wtube*gg_tube(j,i)
 953
 954
 955 #endif
 956           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 957      &                  wbond*gradbx(j,i)+
 958      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 959      &                  wsccor*gsccorx(j,i)
 960      &                 +wscloc*gsclocx(j,i)
 961      &                 +wliptran*gliptranx(j,i)
 962      &                 +welec*gshieldx(j,i)
 963      &                 +wcorr*gshieldx_ec(j,i)
 964      &                 +wturn3*gshieldx_t3(j,i)
 965      &                 +wturn4*gshieldx_t4(j,i)
 966      &                 +wel_loc*gshieldx_ll(j,i)
 967      &                 +wtube*gg_tube_sc(j,i)
 968      &                 +wsaxs*gsaxsx(j,i)
 969
 970
 971
 972         enddo
 973       enddo
 974       if (constr_homology.gt.0) then
 975         do i=1,nct
 976           do j=1,3
 977             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 978             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 979           enddo
 980         enddo
 981       endif
 982 #ifdef DEBUG
 983       write (iout,*) "gradc gradx gloc after adding"
 984       do i=1,nres
 985         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 986      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 987       enddo
 988 #endif
 989 #ifdef DEBUG
 990       write (iout,*) "gloc before adding corr"
 991       do i=1,4*nres
 992         write (iout,*) i,gloc(i,icg)
 993       enddo
 994 #endif
 995       do i=1,nres-3
 996         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 997      &   +wcorr5*g_corr5_loc(i)
 998      &   +wcorr6*g_corr6_loc(i)
 999      &   +wturn4*gel_loc_turn4(i)
1000      &   +wturn3*gel_loc_turn3(i)
1001      &   +wturn6*gel_loc_turn6(i)
1002      &   +wel_loc*gel_loc_loc(i)
1003       enddo
1004 #ifdef DEBUG
1005       write (iout,*) "gloc after adding corr"
1006       do i=1,4*nres
1007         write (iout,*) i,gloc(i,icg)
1008       enddo
1009 #endif
1010 #ifdef MPI
1011       if (nfgtasks.gt.1) then
1012         do j=1,3
1013           do i=1,nres
1014             gradbufc(j,i)=gradc(j,i,icg)
1015             gradbufx(j,i)=gradx(j,i,icg)
1016           enddo
1017         enddo
1018         do i=1,4*nres
1019           glocbuf(i)=gloc(i,icg)
1020         enddo
1021 c#define DEBUG
1022 #ifdef DEBUG
1023       write (iout,*) "gloc_sc before reduce"
1024       do i=1,nres
1025        do j=1,1
1026         write (iout,*) i,j,gloc_sc(j,i,icg)
1027        enddo
1028       enddo
1029 #endif
1030 c#undef DEBUG
1031         do i=1,nres
1032          do j=1,3
1033           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1034          enddo
1035         enddo
1036         time00=MPI_Wtime()
1037         call MPI_Barrier(FG_COMM,IERR)
1038         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1039         time00=MPI_Wtime()
1040         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1041      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1042         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1043      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1044         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1045      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1046         time_reduce=time_reduce+MPI_Wtime()-time00
1047         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1048      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1049         time_reduce=time_reduce+MPI_Wtime()-time00
1050 #ifdef DEBUG
1051       write (iout,*) "gradc after reduce"
1052       do i=1,nres
1053        do j=1,3
1054         write (iout,*) i,j,gradc(j,i,icg)
1055        enddo
1056       enddo
1057 #endif
1058 #ifdef DEBUG
1059       write (iout,*) "gloc_sc after reduce"
1060       do i=1,nres
1061        do j=1,1
1062         write (iout,*) i,j,gloc_sc(j,i,icg)
1063        enddo
1064       enddo
1065 #endif
1066 #ifdef DEBUG
1067       write (iout,*) "gloc after reduce"
1068       do i=1,4*nres
1069         write (iout,*) i,gloc(i,icg)
1070       enddo
1071 #endif
1072       endif
1073 #endif
1074       if (gnorm_check) then
1075 c
1076 c Compute the maximum elements of the gradient
1077 c
1078       gvdwc_max=0.0d0
1079       gvdwc_scp_max=0.0d0
1080       gelc_max=0.0d0
1081       gvdwpp_max=0.0d0
1082       gradb_max=0.0d0
1083       ghpbc_max=0.0d0
1084       gradcorr_max=0.0d0
1085       gel_loc_max=0.0d0
1086       gcorr3_turn_max=0.0d0
1087       gcorr4_turn_max=0.0d0
1088       gradcorr5_max=0.0d0
1089       gradcorr6_max=0.0d0
1090       gcorr6_turn_max=0.0d0
1091       gsccorrc_max=0.0d0
1092       gscloc_max=0.0d0
1093       gvdwx_max=0.0d0
1094       gradx_scp_max=0.0d0
1095       ghpbx_max=0.0d0
1096       gradxorr_max=0.0d0
1097       gsccorrx_max=0.0d0
1098       gsclocx_max=0.0d0
1099       do i=1,nct
1100         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1101         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1102         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1103         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1104      &   gvdwc_scp_max=gvdwc_scp_norm
1105         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1106         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1107         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1108         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1109         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1110         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1111         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1112         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1113         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1114         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1115         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1116         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1117         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1118      &    gcorr3_turn(1,i)))
1119         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1120      &    gcorr3_turn_max=gcorr3_turn_norm
1121         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1122      &    gcorr4_turn(1,i)))
1123         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1124      &    gcorr4_turn_max=gcorr4_turn_norm
1125         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1126         if (gradcorr5_norm.gt.gradcorr5_max)
1127      &    gradcorr5_max=gradcorr5_norm
1128         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1129         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1130         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1131      &    gcorr6_turn(1,i)))
1132         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1133      &    gcorr6_turn_max=gcorr6_turn_norm
1134         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1135         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1136         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1137         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1138         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1139         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1140         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1141         if (gradx_scp_norm.gt.gradx_scp_max)
1142      &    gradx_scp_max=gradx_scp_norm
1143         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1144         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1145         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1146         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1147         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1148         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1149         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1150         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1151       enddo
1152       if (gradout) then
1153 #if (defined AIX || defined CRAY)
1154         open(istat,file=statname,position="append")
1155 #else
1156         open(istat,file=statname,access="append")
1157 #endif
1158         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1159      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1160      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1161      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1162      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1163      &     gsccorrx_max,gsclocx_max
1164         close(istat)
1165         if (gvdwc_max.gt.1.0d4) then
1166           write (iout,*) "gvdwc gvdwx gradb gradbx"
1167           do i=nnt,nct
1168             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1169      &        gradb(j,i),gradbx(j,i),j=1,3)
1170           enddo
1171           call pdbout(0.0d0,'cipiszcze',iout)
1172           call flush(iout)
1173         endif
1174       endif
1175       endif
1176 #ifdef DEBUG
1177       write (iout,*) "gradc gradx gloc"
1178       do i=1,nres
1179         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1180      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1181       enddo
1182 #endif
1183 #ifdef TIMING
1184       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1185 #endif
1186       return
1187       end
1188 c-------------------------------------------------------------------------------
1189       subroutine rescale_weights(t_bath)
1190       implicit none
1191 #ifdef MPI
1192       include 'mpif.h'
1193       integer ierror
1194 #endif
1195       include 'DIMENSIONS'
1196       include 'COMMON.IOUNITS'
1197       include 'COMMON.FFIELD'
1198       include 'COMMON.SBRIDGE'
1199       include 'COMMON.CONTROL'
1200       double precision t_bath
1201       double precision facT,facT2,facT3,facT4,facT5
1202       double precision kfac /2.4d0/
1203       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1204 c      facT=temp0/t_bath
1205 c      facT=2*temp0/(t_bath+temp0)
1206       if (rescale_mode.eq.0) then
1207         facT=1.0d0
1208         facT2=1.0d0
1209         facT3=1.0d0
1210         facT4=1.0d0
1211         facT5=1.0d0
1212       else if (rescale_mode.eq.1) then
1213         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1214         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1215         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1216         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1217         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1218       else if (rescale_mode.eq.2) then
1219         x=t_bath/temp0
1220         x2=x*x
1221         x3=x2*x
1222         x4=x3*x
1223         x5=x4*x
1224         facT=licznik/dlog(dexp(x)+dexp(-x))
1225         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1226         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1227         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1228         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1229       else
1230         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1231         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1232 #ifdef MPI
1233        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1234 #endif
1235        stop 555
1236       endif
1237       if (shield_mode.gt.0) then
1238        wscp=weights(2)*fact
1239        wsc=weights(1)*fact
1240        wvdwpp=weights(16)*fact
1241       endif
1242       welec=weights(3)*fact
1243       wcorr=weights(4)*fact3
1244       wcorr5=weights(5)*fact4
1245       wcorr6=weights(6)*fact5
1246       wel_loc=weights(7)*fact2
1247       wturn3=weights(8)*fact2
1248       wturn4=weights(9)*fact3
1249       wturn6=weights(10)*fact5
1250       wtor=weights(13)*fact
1251       wtor_d=weights(14)*fact2
1252       wsccor=weights(21)*fact
1253       if (scale_umb) wumb=t_bath/temp0
1254 c      write (iout,*) "scale_umb",scale_umb
1255 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1256
1257       return
1258       end
1259 C------------------------------------------------------------------------
1260       subroutine enerprint(energia)
1261       implicit none
1262       include 'DIMENSIONS'
1263       include 'COMMON.IOUNITS'
1264       include 'COMMON.FFIELD'
1265       include 'COMMON.SBRIDGE'
1266       include 'COMMON.QRESTR'
1267       double precision energia(0:n_ene)
1268       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1269      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1270      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1271      & eello_turn6,
1272      & eliptran,Eafmforce,Etube,
1273      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1274       etot=energia(0)
1275       evdw=energia(1)
1276       evdw2=energia(2)
1277 #ifdef SCP14
1278       evdw2=energia(2)+energia(18)
1279 #else
1280       evdw2=energia(2)
1281 #endif
1282       ees=energia(3)
1283 #ifdef SPLITELE
1284       evdw1=energia(16)
1285 #endif
1286       ecorr=energia(4)
1287       ecorr5=energia(5)
1288       ecorr6=energia(6)
1289       eel_loc=energia(7)
1290       eello_turn3=energia(8)
1291       eello_turn4=energia(9)
1292       eello_turn6=energia(10)
1293       ebe=energia(11)
1294       escloc=energia(12)
1295       etors=energia(13)
1296       etors_d=energia(14)
1297       ehpb=energia(15)
1298       edihcnstr=energia(19)
1299       estr=energia(17)
1300       Uconst=energia(20)
1301       esccor=energia(21)
1302       eliptran=energia(22)
1303       Eafmforce=energia(23)
1304       ethetacnstr=energia(24)
1305       etube=energia(25)
1306       esaxs=energia(26)
1307       ehomology_constr=energia(27)
1308 C     Bartek
1309       edfadis = energia(28)
1310       edfator = energia(29)
1311       edfanei = energia(30)
1312       edfabet = energia(31)
1313 #ifdef SPLITELE
1314       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1315      &  estr,wbond,ebe,wang,
1316      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1317      &  ecorr,wcorr,
1318      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1319      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1320      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1321      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1322      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1323      &  edfabet,wdfa_beta,
1324      &  etot
1325    10 format (/'Virtual-chain energies:'//
1326      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1327      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1328      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1329      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1330      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1331      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1332      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1333      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1334      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1335      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1336      & ' (SS bridges & dist. cnstr.)'/
1337      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1338      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1339      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1340      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1341      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1342      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1343      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1344      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1345      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1346      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1347      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1348      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1349      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1350      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1351      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1352      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1353      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1354      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1355      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1356      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1357      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1358      & 'ETOT=  ',1pE16.6,' (total)')
1359
1360 #else
1361       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1362      &  estr,wbond,ebe,wang,
1363      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1364      &  ecorr,wcorr,
1365      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1366      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1367      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1368      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1369      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1370      &  edfabet,wdfa_beta,
1371      &  etot
1372    10 format (/'Virtual-chain energies:'//
1373      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1374      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1375      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1376      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1377      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1378      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1379      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1380      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1381      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1382      & ' (SS bridges & dist. restr.)'/
1383      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1384      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1385      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1386      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1387      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1388      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1389      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1390      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1391      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1392      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1393      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1394      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1395      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1396      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1397      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1398      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1399      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1400      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1401      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1402      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1403      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1404      & 'ETOT=  ',1pE16.6,' (total)')
1405 #endif
1406       return
1407       end
1408 C-----------------------------------------------------------------------
1409       subroutine elj(evdw)
1410 C
1411 C This subroutine calculates the interaction energy of nonbonded side chains
1412 C assuming the LJ potential of interaction.
1413 C
1414       implicit none
1415       double precision accur
1416       include 'DIMENSIONS'
1417       parameter (accur=1.0d-10)
1418       include 'COMMON.GEO'
1419       include 'COMMON.VAR'
1420       include 'COMMON.LOCAL'
1421       include 'COMMON.CHAIN'
1422       include 'COMMON.DERIV'
1423       include 'COMMON.INTERACT'
1424       include 'COMMON.TORSION'
1425       include 'COMMON.SBRIDGE'
1426       include 'COMMON.NAMES'
1427       include 'COMMON.IOUNITS'
1428       include 'COMMON.CONTACTS'
1429       double precision gg(3)
1430       double precision evdw,evdwij
1431       integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1432       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1433      & sigij,r0ij,rcut
1434       double precision fcont,fprimcont
1435 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1436       evdw=0.0D0
1437       do i=iatsc_s,iatsc_e
1438         itypi=iabs(itype(i))
1439         if (itypi.eq.ntyp1) cycle
1440         itypi1=iabs(itype(i+1))
1441         xi=c(1,nres+i)
1442         yi=c(2,nres+i)
1443         zi=c(3,nres+i)
1444 C Change 12/1/95
1445         num_conti=0
1446 C
1447 C Calculate SC interaction energy.
1448 C
1449         do iint=1,nint_gr(i)
1450 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1451 cd   &                  'iend=',iend(i,iint)
1452           do j=istart(i,iint),iend(i,iint)
1453             itypj=iabs(itype(j))
1454             if (itypj.eq.ntyp1) cycle
1455             xj=c(1,nres+j)-xi
1456             yj=c(2,nres+j)-yi
1457             zj=c(3,nres+j)-zi
1458 C Change 12/1/95 to calculate four-body interactions
1459             rij=xj*xj+yj*yj+zj*zj
1460             rrij=1.0D0/rij
1461 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1462             eps0ij=eps(itypi,itypj)
1463             fac=rrij**expon2
1464 C have you changed here?
1465             e1=fac*fac*aa
1466             e2=fac*bb
1467             evdwij=e1+e2
1468 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1469 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1470 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1471 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1472 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1473 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1474             evdw=evdw+evdwij
1475 C
1476 C Calculate the components of the gradient in DC and X
1477 C
1478             fac=-rrij*(e1+evdwij)
1479             gg(1)=xj*fac
1480             gg(2)=yj*fac
1481             gg(3)=zj*fac
1482             do k=1,3
1483               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1484               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1485               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1486               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1487             enddo
1488 cgrad            do k=i,j-1
1489 cgrad              do l=1,3
1490 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1491 cgrad              enddo
1492 cgrad            enddo
1493 C
1494 C 12/1/95, revised on 5/20/97
1495 C
1496 C Calculate the contact function. The ith column of the array JCONT will
1497 C contain the numbers of atoms that make contacts with the atom I (of numbers
1498 C greater than I). The arrays FACONT and GACONT will contain the values of
1499 C the contact function and its derivative.
1500 C
1501 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1502 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1503 C Uncomment next line, if the correlation interactions are contact function only
1504             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1505               rij=dsqrt(rij)
1506               sigij=sigma(itypi,itypj)
1507               r0ij=rs0(itypi,itypj)
1508 C
1509 C Check whether the SC's are not too far to make a contact.
1510 C
1511               rcut=1.5d0*r0ij
1512               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1513 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1514 C
1515               if (fcont.gt.0.0D0) then
1516 C If the SC-SC distance if close to sigma, apply spline.
1517 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1518 cAdam &             fcont1,fprimcont1)
1519 cAdam           fcont1=1.0d0-fcont1
1520 cAdam           if (fcont1.gt.0.0d0) then
1521 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1522 cAdam             fcont=fcont*fcont1
1523 cAdam           endif
1524 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1525 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1526 cga             do k=1,3
1527 cga               gg(k)=gg(k)*eps0ij
1528 cga             enddo
1529 cga             eps0ij=-evdwij*eps0ij
1530 C Uncomment for AL's type of SC correlation interactions.
1531 cadam           eps0ij=-evdwij
1532                 num_conti=num_conti+1
1533                 jcont(num_conti,i)=j
1534                 facont(num_conti,i)=fcont*eps0ij
1535                 fprimcont=eps0ij*fprimcont/rij
1536                 fcont=expon*fcont
1537 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1538 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1539 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1540 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1541                 gacont(1,num_conti,i)=-fprimcont*xj
1542                 gacont(2,num_conti,i)=-fprimcont*yj
1543                 gacont(3,num_conti,i)=-fprimcont*zj
1544 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1545 cd              write (iout,'(2i3,3f10.5)')
1546 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1547               endif
1548             endif
1549           enddo      ! j
1550         enddo        ! iint
1551 C Change 12/1/95
1552         num_cont(i)=num_conti
1553       enddo          ! i
1554       do i=1,nct
1555         do j=1,3
1556           gvdwc(j,i)=expon*gvdwc(j,i)
1557           gvdwx(j,i)=expon*gvdwx(j,i)
1558         enddo
1559       enddo
1560 C******************************************************************************
1561 C
1562 C                              N O T E !!!
1563 C
1564 C To save time, the factor of EXPON has been extracted from ALL components
1565 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1566 C use!
1567 C
1568 C******************************************************************************
1569       return
1570       end
1571 C-----------------------------------------------------------------------------
1572       subroutine eljk(evdw)
1573 C
1574 C This subroutine calculates the interaction energy of nonbonded side chains
1575 C assuming the LJK potential of interaction.
1576 C
1577       implicit none
1578       include 'DIMENSIONS'
1579       include 'COMMON.GEO'
1580       include 'COMMON.VAR'
1581       include 'COMMON.LOCAL'
1582       include 'COMMON.CHAIN'
1583       include 'COMMON.DERIV'
1584       include 'COMMON.INTERACT'
1585       include 'COMMON.IOUNITS'
1586       include 'COMMON.NAMES'
1587       double precision gg(3)
1588       double precision evdw,evdwij
1589       integer i,j,k,itypi,itypj,itypi1,iint
1590       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1591      & fac_augm,e_augm,r_inv_ij,r_shift_inv
1592       logical scheck
1593 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1594       evdw=0.0D0
1595       do i=iatsc_s,iatsc_e
1596         itypi=iabs(itype(i))
1597         if (itypi.eq.ntyp1) cycle
1598         itypi1=iabs(itype(i+1))
1599         xi=c(1,nres+i)
1600         yi=c(2,nres+i)
1601         zi=c(3,nres+i)
1602 C
1603 C Calculate SC interaction energy.
1604 C
1605         do iint=1,nint_gr(i)
1606           do j=istart(i,iint),iend(i,iint)
1607             itypj=iabs(itype(j))
1608             if (itypj.eq.ntyp1) cycle
1609             xj=c(1,nres+j)-xi
1610             yj=c(2,nres+j)-yi
1611             zj=c(3,nres+j)-zi
1612             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1613             fac_augm=rrij**expon
1614             e_augm=augm(itypi,itypj)*fac_augm
1615             r_inv_ij=dsqrt(rrij)
1616             rij=1.0D0/r_inv_ij
1617             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1618             fac=r_shift_inv**expon
1619 C have you changed here?
1620             e1=fac*fac*aa
1621             e2=fac*bb
1622             evdwij=e_augm+e1+e2
1623 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1624 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1625 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1626 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1627 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1628 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1629 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1630             evdw=evdw+evdwij
1631 C
1632 C Calculate the components of the gradient in DC and X
1633 C
1634             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1635             gg(1)=xj*fac
1636             gg(2)=yj*fac
1637             gg(3)=zj*fac
1638             do k=1,3
1639               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1640               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1641               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1642               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1643             enddo
1644 cgrad            do k=i,j-1
1645 cgrad              do l=1,3
1646 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1647 cgrad              enddo
1648 cgrad            enddo
1649           enddo      ! j
1650         enddo        ! iint
1651       enddo          ! i
1652       do i=1,nct
1653         do j=1,3
1654           gvdwc(j,i)=expon*gvdwc(j,i)
1655           gvdwx(j,i)=expon*gvdwx(j,i)
1656         enddo
1657       enddo
1658       return
1659       end
1660 C-----------------------------------------------------------------------------
1661       subroutine ebp(evdw)
1662 C
1663 C This subroutine calculates the interaction energy of nonbonded side chains
1664 C assuming the Berne-Pechukas potential of interaction.
1665 C
1666       implicit none
1667       include 'DIMENSIONS'
1668       include 'COMMON.GEO'
1669       include 'COMMON.VAR'
1670       include 'COMMON.LOCAL'
1671       include 'COMMON.CHAIN'
1672       include 'COMMON.DERIV'
1673       include 'COMMON.NAMES'
1674       include 'COMMON.INTERACT'
1675       include 'COMMON.IOUNITS'
1676       include 'COMMON.CALC'
1677       integer icall
1678       common /srutu/ icall
1679       double precision evdw
1680       integer itypi,itypj,itypi1,iint,ind
1681       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1682 c     double precision rrsave(maxdim)
1683       logical lprn
1684       evdw=0.0D0
1685 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1686       evdw=0.0D0
1687 c     if (icall.eq.0) then
1688 c       lprn=.true.
1689 c     else
1690         lprn=.false.
1691 c     endif
1692       ind=0
1693       do i=iatsc_s,iatsc_e
1694         itypi=iabs(itype(i))
1695         if (itypi.eq.ntyp1) cycle
1696         itypi1=iabs(itype(i+1))
1697         xi=c(1,nres+i)
1698         yi=c(2,nres+i)
1699         zi=c(3,nres+i)
1700         dxi=dc_norm(1,nres+i)
1701         dyi=dc_norm(2,nres+i)
1702         dzi=dc_norm(3,nres+i)
1703 c        dsci_inv=dsc_inv(itypi)
1704         dsci_inv=vbld_inv(i+nres)
1705 C
1706 C Calculate SC interaction energy.
1707 C
1708         do iint=1,nint_gr(i)
1709           do j=istart(i,iint),iend(i,iint)
1710             ind=ind+1
1711             itypj=iabs(itype(j))
1712             if (itypj.eq.ntyp1) cycle
1713 c            dscj_inv=dsc_inv(itypj)
1714             dscj_inv=vbld_inv(j+nres)
1715             chi1=chi(itypi,itypj)
1716             chi2=chi(itypj,itypi)
1717             chi12=chi1*chi2
1718             chip1=chip(itypi)
1719             chip2=chip(itypj)
1720             chip12=chip1*chip2
1721             alf1=alp(itypi)
1722             alf2=alp(itypj)
1723             alf12=0.5D0*(alf1+alf2)
1724 C For diagnostics only!!!
1725 c           chi1=0.0D0
1726 c           chi2=0.0D0
1727 c           chi12=0.0D0
1728 c           chip1=0.0D0
1729 c           chip2=0.0D0
1730 c           chip12=0.0D0
1731 c           alf1=0.0D0
1732 c           alf2=0.0D0
1733 c           alf12=0.0D0
1734             xj=c(1,nres+j)-xi
1735             yj=c(2,nres+j)-yi
1736             zj=c(3,nres+j)-zi
1737             dxj=dc_norm(1,nres+j)
1738             dyj=dc_norm(2,nres+j)
1739             dzj=dc_norm(3,nres+j)
1740             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1741 cd          if (icall.eq.0) then
1742 cd            rrsave(ind)=rrij
1743 cd          else
1744 cd            rrij=rrsave(ind)
1745 cd          endif
1746             rij=dsqrt(rrij)
1747 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1748             call sc_angular
1749 C Calculate whole angle-dependent part of epsilon and contributions
1750 C to its derivatives
1751 C have you changed here?
1752             fac=(rrij*sigsq)**expon2
1753             e1=fac*fac*aa
1754             e2=fac*bb
1755             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1756             eps2der=evdwij*eps3rt
1757             eps3der=evdwij*eps2rt
1758             evdwij=evdwij*eps2rt*eps3rt
1759             evdw=evdw+evdwij
1760             if (lprn) then
1761             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1762             epsi=bb**2/aa
1763 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1764 cd     &        restyp(itypi),i,restyp(itypj),j,
1765 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1766 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1767 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1768 cd     &        evdwij
1769             endif
1770 C Calculate gradient components.
1771             e1=e1*eps1*eps2rt**2*eps3rt**2
1772             fac=-expon*(e1+evdwij)
1773             sigder=fac/sigsq
1774             fac=rrij*fac
1775 C Calculate radial part of the gradient
1776             gg(1)=xj*fac
1777             gg(2)=yj*fac
1778             gg(3)=zj*fac
1779 C Calculate the angular part of the gradient and sum add the contributions
1780 C to the appropriate components of the Cartesian gradient.
1781             call sc_grad
1782           enddo      ! j
1783         enddo        ! iint
1784       enddo          ! i
1785 c     stop
1786       return
1787       end
1788 C-----------------------------------------------------------------------------
1789       subroutine egb(evdw)
1790 C
1791 C This subroutine calculates the interaction energy of nonbonded side chains
1792 C assuming the Gay-Berne potential of interaction.
1793 C
1794       implicit none
1795       include 'DIMENSIONS'
1796       include 'COMMON.GEO'
1797       include 'COMMON.VAR'
1798       include 'COMMON.LOCAL'
1799       include 'COMMON.CHAIN'
1800       include 'COMMON.DERIV'
1801       include 'COMMON.NAMES'
1802       include 'COMMON.INTERACT'
1803       include 'COMMON.IOUNITS'
1804       include 'COMMON.CALC'
1805       include 'COMMON.CONTROL'
1806       include 'COMMON.SPLITELE'
1807       include 'COMMON.SBRIDGE'
1808       logical lprn
1809       integer xshift,yshift,zshift,subchap
1810       double precision evdw
1811       integer itypi,itypj,itypi1,iint,ind
1812       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1813       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1814      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1815      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1816       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1817       evdw=0.0D0
1818 ccccc      energy_dec=.false.
1819 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1820       evdw=0.0D0
1821       lprn=.false.
1822 c     if (icall.eq.0) lprn=.false.
1823       ind=0
1824 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1825 C we have the original box)
1826 C      do xshift=-1,1
1827 C      do yshift=-1,1
1828 C      do zshift=-1,1
1829       do i=iatsc_s,iatsc_e
1830         itypi=iabs(itype(i))
1831         if (itypi.eq.ntyp1) cycle
1832         itypi1=iabs(itype(i+1))
1833         xi=c(1,nres+i)
1834         yi=c(2,nres+i)
1835         zi=c(3,nres+i)
1836 C Return atom into box, boxxsize is size of box in x dimension
1837 c  134   continue
1838 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1839 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1840 C Condition for being inside the proper box
1841 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1842 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1843 c        go to 134
1844 c        endif
1845 c  135   continue
1846 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1847 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1848 C Condition for being inside the proper box
1849 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1850 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1851 c        go to 135
1852 c        endif
1853 c  136   continue
1854 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1855 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1856 C Condition for being inside the proper box
1857 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1858 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1859 c        go to 136
1860 c        endif
1861           xi=mod(xi,boxxsize)
1862           if (xi.lt.0) xi=xi+boxxsize
1863           yi=mod(yi,boxysize)
1864           if (yi.lt.0) yi=yi+boxysize
1865           zi=mod(zi,boxzsize)
1866           if (zi.lt.0) zi=zi+boxzsize
1867 C define scaling factor for lipids
1868
1869 C        if (positi.le.0) positi=positi+boxzsize
1870 C        print *,i
1871 C first for peptide groups
1872 c for each residue check if it is in lipid or lipid water border area
1873        if ((zi.gt.bordlipbot)
1874      &.and.(zi.lt.bordliptop)) then
1875 C the energy transfer exist
1876         if (zi.lt.buflipbot) then
1877 C what fraction I am in
1878          fracinbuf=1.0d0-
1879      &        ((zi-bordlipbot)/lipbufthick)
1880 C lipbufthick is thickenes of lipid buffore
1881          sslipi=sscalelip(fracinbuf)
1882          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1883         elseif (zi.gt.bufliptop) then
1884          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1885          sslipi=sscalelip(fracinbuf)
1886          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1887         else
1888          sslipi=1.0d0
1889          ssgradlipi=0.0
1890         endif
1891        else
1892          sslipi=0.0d0
1893          ssgradlipi=0.0
1894        endif
1895
1896 C          xi=xi+xshift*boxxsize
1897 C          yi=yi+yshift*boxysize
1898 C          zi=zi+zshift*boxzsize
1899
1900         dxi=dc_norm(1,nres+i)
1901         dyi=dc_norm(2,nres+i)
1902         dzi=dc_norm(3,nres+i)
1903 c        dsci_inv=dsc_inv(itypi)
1904         dsci_inv=vbld_inv(i+nres)
1905 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1906 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1907 C
1908 C Calculate SC interaction energy.
1909 C
1910         do iint=1,nint_gr(i)
1911           do j=istart(i,iint),iend(i,iint)
1912             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1913
1914 c              write(iout,*) "PRZED ZWYKLE", evdwij
1915               call dyn_ssbond_ene(i,j,evdwij)
1916 c              write(iout,*) "PO ZWYKLE", evdwij
1917
1918               evdw=evdw+evdwij
1919               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1920      &                        'evdw',i,j,evdwij,' ss'
1921 C triple bond artifac removal
1922              do k=j+1,iend(i,iint)
1923 C search over all next residues
1924               if (dyn_ss_mask(k)) then
1925 C check if they are cysteins
1926 C              write(iout,*) 'k=',k
1927
1928 c              write(iout,*) "PRZED TRI", evdwij
1929                evdwij_przed_tri=evdwij
1930               call triple_ssbond_ene(i,j,k,evdwij)
1931 c               if(evdwij_przed_tri.ne.evdwij) then
1932 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1933 c               endif
1934
1935 c              write(iout,*) "PO TRI", evdwij
1936 C call the energy function that removes the artifical triple disulfide
1937 C bond the soubroutine is located in ssMD.F
1938               evdw=evdw+evdwij
1939               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1940      &                        'evdw',i,j,evdwij,'tss'
1941               endif!dyn_ss_mask(k)
1942              enddo! k
1943             ELSE
1944             ind=ind+1
1945             itypj=iabs(itype(j))
1946             if (itypj.eq.ntyp1) cycle
1947 c            dscj_inv=dsc_inv(itypj)
1948             dscj_inv=vbld_inv(j+nres)
1949 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1950 c     &       1.0d0/vbld(j+nres)
1951 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1952             sig0ij=sigma(itypi,itypj)
1953             chi1=chi(itypi,itypj)
1954             chi2=chi(itypj,itypi)
1955             chi12=chi1*chi2
1956             chip1=chip(itypi)
1957             chip2=chip(itypj)
1958             chip12=chip1*chip2
1959             alf1=alp(itypi)
1960             alf2=alp(itypj)
1961             alf12=0.5D0*(alf1+alf2)
1962 C For diagnostics only!!!
1963 c           chi1=0.0D0
1964 c           chi2=0.0D0
1965 c           chi12=0.0D0
1966 c           chip1=0.0D0
1967 c           chip2=0.0D0
1968 c           chip12=0.0D0
1969 c           alf1=0.0D0
1970 c           alf2=0.0D0
1971 c           alf12=0.0D0
1972             xj=c(1,nres+j)
1973             yj=c(2,nres+j)
1974             zj=c(3,nres+j)
1975 C Return atom J into box the original box
1976 c  137   continue
1977 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1978 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1979 C Condition for being inside the proper box
1980 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1981 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1982 c        go to 137
1983 c        endif
1984 c  138   continue
1985 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1986 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1987 C Condition for being inside the proper box
1988 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1989 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1990 c        go to 138
1991 c        endif
1992 c  139   continue
1993 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1994 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1995 C Condition for being inside the proper box
1996 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1997 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1998 c        go to 139
1999 c        endif
2000           xj=mod(xj,boxxsize)
2001           if (xj.lt.0) xj=xj+boxxsize
2002           yj=mod(yj,boxysize)
2003           if (yj.lt.0) yj=yj+boxysize
2004           zj=mod(zj,boxzsize)
2005           if (zj.lt.0) zj=zj+boxzsize
2006        if ((zj.gt.bordlipbot)
2007      &.and.(zj.lt.bordliptop)) then
2008 C the energy transfer exist
2009         if (zj.lt.buflipbot) then
2010 C what fraction I am in
2011          fracinbuf=1.0d0-
2012      &        ((zj-bordlipbot)/lipbufthick)
2013 C lipbufthick is thickenes of lipid buffore
2014          sslipj=sscalelip(fracinbuf)
2015          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2016         elseif (zj.gt.bufliptop) then
2017          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2018          sslipj=sscalelip(fracinbuf)
2019          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2020         else
2021          sslipj=1.0d0
2022          ssgradlipj=0.0
2023         endif
2024        else
2025          sslipj=0.0d0
2026          ssgradlipj=0.0
2027        endif
2028       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2029      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2030       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2031      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2032 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2033 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2034 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2035 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2036 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2037       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2038       xj_safe=xj
2039       yj_safe=yj
2040       zj_safe=zj
2041       subchap=0
2042       do xshift=-1,1
2043       do yshift=-1,1
2044       do zshift=-1,1
2045           xj=xj_safe+xshift*boxxsize
2046           yj=yj_safe+yshift*boxysize
2047           zj=zj_safe+zshift*boxzsize
2048           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2049           if(dist_temp.lt.dist_init) then
2050             dist_init=dist_temp
2051             xj_temp=xj
2052             yj_temp=yj
2053             zj_temp=zj
2054             subchap=1
2055           endif
2056        enddo
2057        enddo
2058        enddo
2059        if (subchap.eq.1) then
2060           xj=xj_temp-xi
2061           yj=yj_temp-yi
2062           zj=zj_temp-zi
2063        else
2064           xj=xj_safe-xi
2065           yj=yj_safe-yi
2066           zj=zj_safe-zi
2067        endif
2068             dxj=dc_norm(1,nres+j)
2069             dyj=dc_norm(2,nres+j)
2070             dzj=dc_norm(3,nres+j)
2071 C            xj=xj-xi
2072 C            yj=yj-yi
2073 C            zj=zj-zi
2074 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2075 c            write (iout,*) "j",j," dc_norm",
2076 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2077             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2078             rij=dsqrt(rrij)
2079             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2080             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2081
2082 c            write (iout,'(a7,4f8.3)')
2083 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2084             if (sss.gt.0.0d0) then
2085 C Calculate angle-dependent terms of energy and contributions to their
2086 C derivatives.
2087             call sc_angular
2088             sigsq=1.0D0/sigsq
2089             sig=sig0ij*dsqrt(sigsq)
2090             rij_shift=1.0D0/rij-sig+sig0ij
2091 c for diagnostics; uncomment
2092 c            rij_shift=1.2*sig0ij
2093 C I hate to put IF's in the loops, but here don't have another choice!!!!
2094             if (rij_shift.le.0.0D0) then
2095               evdw=1.0D20
2096 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2097 cd     &        restyp(itypi),i,restyp(itypj),j,
2098 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2099               return
2100             endif
2101             sigder=-sig*sigsq
2102 c---------------------------------------------------------------
2103             rij_shift=1.0D0/rij_shift
2104             fac=rij_shift**expon
2105 C here to start with
2106 C            if (c(i,3).gt.
2107             faclip=fac
2108             e1=fac*fac*aa
2109             e2=fac*bb
2110             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2111             eps2der=evdwij*eps3rt
2112             eps3der=evdwij*eps2rt
2113 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2114 C     &((sslipi+sslipj)/2.0d0+
2115 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2116 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2117 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2118             evdwij=evdwij*eps2rt*eps3rt
2119             evdw=evdw+evdwij*sss
2120             if (lprn) then
2121             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2122             epsi=bb**2/aa
2123             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2124      &        restyp(itypi),i,restyp(itypj),j,
2125      &        epsi,sigm,chi1,chi2,chip1,chip2,
2126      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2127      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2128      &        evdwij
2129             endif
2130
2131             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2132      &                        'evdw',i,j,evdwij
2133
2134 C Calculate gradient components.
2135             e1=e1*eps1*eps2rt**2*eps3rt**2
2136             fac=-expon*(e1+evdwij)*rij_shift
2137             sigder=fac*sigder
2138             fac=rij*fac
2139 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2140 c     &      evdwij,fac,sigma(itypi,itypj),expon
2141             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2142 c            fac=0.0d0
2143 C Calculate the radial part of the gradient
2144             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2145      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2146      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2147      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2148             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2149             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2150 C            gg_lipi(3)=0.0d0
2151 C            gg_lipj(3)=0.0d0
2152             gg(1)=xj*fac
2153             gg(2)=yj*fac
2154             gg(3)=zj*fac
2155 C Calculate angular part of the gradient.
2156             call sc_grad
2157             endif
2158             ENDIF    ! dyn_ss
2159           enddo      ! j
2160         enddo        ! iint
2161       enddo          ! i
2162 C      enddo          ! zshift
2163 C      enddo          ! yshift
2164 C      enddo          ! xshift
2165 c      write (iout,*) "Number of loop steps in EGB:",ind
2166 cccc      energy_dec=.false.
2167       return
2168       end
2169 C-----------------------------------------------------------------------------
2170       subroutine egbv(evdw)
2171 C
2172 C This subroutine calculates the interaction energy of nonbonded side chains
2173 C assuming the Gay-Berne-Vorobjev potential of interaction.
2174 C
2175       implicit none
2176       include 'DIMENSIONS'
2177       include 'COMMON.GEO'
2178       include 'COMMON.VAR'
2179       include 'COMMON.LOCAL'
2180       include 'COMMON.CHAIN'
2181       include 'COMMON.DERIV'
2182       include 'COMMON.NAMES'
2183       include 'COMMON.INTERACT'
2184       include 'COMMON.IOUNITS'
2185       include 'COMMON.CALC'
2186       integer xshift,yshift,zshift,subchap
2187       integer icall
2188       common /srutu/ icall
2189       logical lprn
2190       double precision evdw
2191       integer itypi,itypj,itypi1,iint,ind
2192       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2193      & xi,yi,zi,fac_augm,e_augm
2194       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2195      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2196      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
2197       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2198       evdw=0.0D0
2199 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2200       evdw=0.0D0
2201       lprn=.false.
2202 c     if (icall.eq.0) lprn=.true.
2203       ind=0
2204       do i=iatsc_s,iatsc_e
2205         itypi=iabs(itype(i))
2206         if (itypi.eq.ntyp1) cycle
2207         itypi1=iabs(itype(i+1))
2208         xi=c(1,nres+i)
2209         yi=c(2,nres+i)
2210         zi=c(3,nres+i)
2211           xi=mod(xi,boxxsize)
2212           if (xi.lt.0) xi=xi+boxxsize
2213           yi=mod(yi,boxysize)
2214           if (yi.lt.0) yi=yi+boxysize
2215           zi=mod(zi,boxzsize)
2216           if (zi.lt.0) zi=zi+boxzsize
2217 C define scaling factor for lipids
2218
2219 C        if (positi.le.0) positi=positi+boxzsize
2220 C        print *,i
2221 C first for peptide groups
2222 c for each residue check if it is in lipid or lipid water border area
2223        if ((zi.gt.bordlipbot)
2224      &.and.(zi.lt.bordliptop)) then
2225 C the energy transfer exist
2226         if (zi.lt.buflipbot) then
2227 C what fraction I am in
2228          fracinbuf=1.0d0-
2229      &        ((zi-bordlipbot)/lipbufthick)
2230 C lipbufthick is thickenes of lipid buffore
2231          sslipi=sscalelip(fracinbuf)
2232          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2233         elseif (zi.gt.bufliptop) then
2234          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2235          sslipi=sscalelip(fracinbuf)
2236          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2237         else
2238          sslipi=1.0d0
2239          ssgradlipi=0.0
2240         endif
2241        else
2242          sslipi=0.0d0
2243          ssgradlipi=0.0
2244        endif
2245
2246         dxi=dc_norm(1,nres+i)
2247         dyi=dc_norm(2,nres+i)
2248         dzi=dc_norm(3,nres+i)
2249 c        dsci_inv=dsc_inv(itypi)
2250         dsci_inv=vbld_inv(i+nres)
2251 C
2252 C Calculate SC interaction energy.
2253 C
2254         do iint=1,nint_gr(i)
2255           do j=istart(i,iint),iend(i,iint)
2256             ind=ind+1
2257             itypj=iabs(itype(j))
2258             if (itypj.eq.ntyp1) cycle
2259 c            dscj_inv=dsc_inv(itypj)
2260             dscj_inv=vbld_inv(j+nres)
2261             sig0ij=sigma(itypi,itypj)
2262             r0ij=r0(itypi,itypj)
2263             chi1=chi(itypi,itypj)
2264             chi2=chi(itypj,itypi)
2265             chi12=chi1*chi2
2266             chip1=chip(itypi)
2267             chip2=chip(itypj)
2268             chip12=chip1*chip2
2269             alf1=alp(itypi)
2270             alf2=alp(itypj)
2271             alf12=0.5D0*(alf1+alf2)
2272 C For diagnostics only!!!
2273 c           chi1=0.0D0
2274 c           chi2=0.0D0
2275 c           chi12=0.0D0
2276 c           chip1=0.0D0
2277 c           chip2=0.0D0
2278 c           chip12=0.0D0
2279 c           alf1=0.0D0
2280 c           alf2=0.0D0
2281 c           alf12=0.0D0
2282 C            xj=c(1,nres+j)-xi
2283 C            yj=c(2,nres+j)-yi
2284 C            zj=c(3,nres+j)-zi
2285           xj=mod(xj,boxxsize)
2286           if (xj.lt.0) xj=xj+boxxsize
2287           yj=mod(yj,boxysize)
2288           if (yj.lt.0) yj=yj+boxysize
2289           zj=mod(zj,boxzsize)
2290           if (zj.lt.0) zj=zj+boxzsize
2291        if ((zj.gt.bordlipbot)
2292      &.and.(zj.lt.bordliptop)) then
2293 C the energy transfer exist
2294         if (zj.lt.buflipbot) then
2295 C what fraction I am in
2296          fracinbuf=1.0d0-
2297      &        ((zj-bordlipbot)/lipbufthick)
2298 C lipbufthick is thickenes of lipid buffore
2299          sslipj=sscalelip(fracinbuf)
2300          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2301         elseif (zj.gt.bufliptop) then
2302          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2303          sslipj=sscalelip(fracinbuf)
2304          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2305         else
2306          sslipj=1.0d0
2307          ssgradlipj=0.0
2308         endif
2309        else
2310          sslipj=0.0d0
2311          ssgradlipj=0.0
2312        endif
2313       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2314      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2315       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2316      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2317 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2318 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2319 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2320       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2321       xj_safe=xj
2322       yj_safe=yj
2323       zj_safe=zj
2324       subchap=0
2325       do xshift=-1,1
2326       do yshift=-1,1
2327       do zshift=-1,1
2328           xj=xj_safe+xshift*boxxsize
2329           yj=yj_safe+yshift*boxysize
2330           zj=zj_safe+zshift*boxzsize
2331           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2332           if(dist_temp.lt.dist_init) then
2333             dist_init=dist_temp
2334             xj_temp=xj
2335             yj_temp=yj
2336             zj_temp=zj
2337             subchap=1
2338           endif
2339        enddo
2340        enddo
2341        enddo
2342        if (subchap.eq.1) then
2343           xj=xj_temp-xi
2344           yj=yj_temp-yi
2345           zj=zj_temp-zi
2346        else
2347           xj=xj_safe-xi
2348           yj=yj_safe-yi
2349           zj=zj_safe-zi
2350        endif
2351             dxj=dc_norm(1,nres+j)
2352             dyj=dc_norm(2,nres+j)
2353             dzj=dc_norm(3,nres+j)
2354             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2355             rij=dsqrt(rrij)
2356 C Calculate angle-dependent terms of energy and contributions to their
2357 C derivatives.
2358             call sc_angular
2359             sigsq=1.0D0/sigsq
2360             sig=sig0ij*dsqrt(sigsq)
2361             rij_shift=1.0D0/rij-sig+r0ij
2362 C I hate to put IF's in the loops, but here don't have another choice!!!!
2363             if (rij_shift.le.0.0D0) then
2364               evdw=1.0D20
2365               return
2366             endif
2367             sigder=-sig*sigsq
2368 c---------------------------------------------------------------
2369             rij_shift=1.0D0/rij_shift
2370             fac=rij_shift**expon
2371             e1=fac*fac*aa
2372             e2=fac*bb
2373             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2374             eps2der=evdwij*eps3rt
2375             eps3der=evdwij*eps2rt
2376             fac_augm=rrij**expon
2377             e_augm=augm(itypi,itypj)*fac_augm
2378             evdwij=evdwij*eps2rt*eps3rt
2379             evdw=evdw+evdwij+e_augm
2380             if (lprn) then
2381             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2382             epsi=bb**2/aa
2383             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2384      &        restyp(itypi),i,restyp(itypj),j,
2385      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2386      &        chi1,chi2,chip1,chip2,
2387      &        eps1,eps2rt**2,eps3rt**2,
2388      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2389      &        evdwij+e_augm
2390             endif
2391 C Calculate gradient components.
2392             e1=e1*eps1*eps2rt**2*eps3rt**2
2393             fac=-expon*(e1+evdwij)*rij_shift
2394             sigder=fac*sigder
2395             fac=rij*fac-2*expon*rrij*e_augm
2396             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2397 C Calculate the radial part of the gradient
2398             gg(1)=xj*fac
2399             gg(2)=yj*fac
2400             gg(3)=zj*fac
2401 C Calculate angular part of the gradient.
2402             call sc_grad
2403           enddo      ! j
2404         enddo        ! iint
2405       enddo          ! i
2406       end
2407 C-----------------------------------------------------------------------------
2408       subroutine sc_angular
2409 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2410 C om12. Called by ebp, egb, and egbv.
2411       implicit none
2412       include 'COMMON.CALC'
2413       include 'COMMON.IOUNITS'
2414       erij(1)=xj*rij
2415       erij(2)=yj*rij
2416       erij(3)=zj*rij
2417       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2418       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2419       om12=dxi*dxj+dyi*dyj+dzi*dzj
2420       chiom12=chi12*om12
2421 C Calculate eps1(om12) and its derivative in om12
2422       faceps1=1.0D0-om12*chiom12
2423       faceps1_inv=1.0D0/faceps1
2424       eps1=dsqrt(faceps1_inv)
2425 C Following variable is eps1*deps1/dom12
2426       eps1_om12=faceps1_inv*chiom12
2427 c diagnostics only
2428 c      faceps1_inv=om12
2429 c      eps1=om12
2430 c      eps1_om12=1.0d0
2431 c      write (iout,*) "om12",om12," eps1",eps1
2432 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2433 C and om12.
2434       om1om2=om1*om2
2435       chiom1=chi1*om1
2436       chiom2=chi2*om2
2437       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2438       sigsq=1.0D0-facsig*faceps1_inv
2439       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2440       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2441       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2442 c diagnostics only
2443 c      sigsq=1.0d0
2444 c      sigsq_om1=0.0d0
2445 c      sigsq_om2=0.0d0
2446 c      sigsq_om12=0.0d0
2447 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2448 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2449 c     &    " eps1",eps1
2450 C Calculate eps2 and its derivatives in om1, om2, and om12.
2451       chipom1=chip1*om1
2452       chipom2=chip2*om2
2453       chipom12=chip12*om12
2454       facp=1.0D0-om12*chipom12
2455       facp_inv=1.0D0/facp
2456       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2457 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2458 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2459 C Following variable is the square root of eps2
2460       eps2rt=1.0D0-facp1*facp_inv
2461 C Following three variables are the derivatives of the square root of eps
2462 C in om1, om2, and om12.
2463       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2464       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2465       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2466 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2467       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2468 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2469 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2470 c     &  " eps2rt_om12",eps2rt_om12
2471 C Calculate whole angle-dependent part of epsilon and contributions
2472 C to its derivatives
2473       return
2474       end
2475 C----------------------------------------------------------------------------
2476       subroutine sc_grad
2477       implicit real*8 (a-h,o-z)
2478       include 'DIMENSIONS'
2479       include 'COMMON.CHAIN'
2480       include 'COMMON.DERIV'
2481       include 'COMMON.CALC'
2482       include 'COMMON.IOUNITS'
2483       double precision dcosom1(3),dcosom2(3)
2484 cc      print *,'sss=',sss
2485       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2486       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2487       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2488      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2489 c diagnostics only
2490 c      eom1=0.0d0
2491 c      eom2=0.0d0
2492 c      eom12=evdwij*eps1_om12
2493 c end diagnostics
2494 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2495 c     &  " sigder",sigder
2496 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2497 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2498       do k=1,3
2499         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2500         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2501       enddo
2502       do k=1,3
2503         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2504       enddo
2505 c      write (iout,*) "gg",(gg(k),k=1,3)
2506       do k=1,3
2507         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2508      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2509      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2510         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2511      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2512      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2513 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2514 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2515 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2516 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2517       enddo
2518 C
2519 C Calculate the components of the gradient in DC and X
2520 C
2521 cgrad      do k=i,j-1
2522 cgrad        do l=1,3
2523 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2524 cgrad        enddo
2525 cgrad      enddo
2526       do l=1,3
2527         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2528         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2529       enddo
2530       return
2531       end
2532 C-----------------------------------------------------------------------
2533       subroutine e_softsphere(evdw)
2534 C
2535 C This subroutine calculates the interaction energy of nonbonded side chains
2536 C assuming the LJ potential of interaction.
2537 C
2538       implicit real*8 (a-h,o-z)
2539       include 'DIMENSIONS'
2540       parameter (accur=1.0d-10)
2541       include 'COMMON.GEO'
2542       include 'COMMON.VAR'
2543       include 'COMMON.LOCAL'
2544       include 'COMMON.CHAIN'
2545       include 'COMMON.DERIV'
2546       include 'COMMON.INTERACT'
2547       include 'COMMON.TORSION'
2548       include 'COMMON.SBRIDGE'
2549       include 'COMMON.NAMES'
2550       include 'COMMON.IOUNITS'
2551       include 'COMMON.CONTACTS'
2552       dimension gg(3)
2553 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2554       evdw=0.0D0
2555       do i=iatsc_s,iatsc_e
2556         itypi=iabs(itype(i))
2557         if (itypi.eq.ntyp1) cycle
2558         itypi1=iabs(itype(i+1))
2559         xi=c(1,nres+i)
2560         yi=c(2,nres+i)
2561         zi=c(3,nres+i)
2562 C
2563 C Calculate SC interaction energy.
2564 C
2565         do iint=1,nint_gr(i)
2566 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2567 cd   &                  'iend=',iend(i,iint)
2568           do j=istart(i,iint),iend(i,iint)
2569             itypj=iabs(itype(j))
2570             if (itypj.eq.ntyp1) cycle
2571             xj=c(1,nres+j)-xi
2572             yj=c(2,nres+j)-yi
2573             zj=c(3,nres+j)-zi
2574             rij=xj*xj+yj*yj+zj*zj
2575 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2576             r0ij=r0(itypi,itypj)
2577             r0ijsq=r0ij*r0ij
2578 c            print *,i,j,r0ij,dsqrt(rij)
2579             if (rij.lt.r0ijsq) then
2580               evdwij=0.25d0*(rij-r0ijsq)**2
2581               fac=rij-r0ijsq
2582             else
2583               evdwij=0.0d0
2584               fac=0.0d0
2585             endif
2586             evdw=evdw+evdwij
2587 C
2588 C Calculate the components of the gradient in DC and X
2589 C
2590             gg(1)=xj*fac
2591             gg(2)=yj*fac
2592             gg(3)=zj*fac
2593             do k=1,3
2594               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2595               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2596               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2597               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2598             enddo
2599 cgrad            do k=i,j-1
2600 cgrad              do l=1,3
2601 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2602 cgrad              enddo
2603 cgrad            enddo
2604           enddo ! j
2605         enddo ! iint
2606       enddo ! i
2607       return
2608       end
2609 C--------------------------------------------------------------------------
2610       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2611      &              eello_turn4)
2612 C
2613 C Soft-sphere potential of p-p interaction
2614 C
2615       implicit real*8 (a-h,o-z)
2616       include 'DIMENSIONS'
2617       include 'COMMON.CONTROL'
2618       include 'COMMON.IOUNITS'
2619       include 'COMMON.GEO'
2620       include 'COMMON.VAR'
2621       include 'COMMON.LOCAL'
2622       include 'COMMON.CHAIN'
2623       include 'COMMON.DERIV'
2624       include 'COMMON.INTERACT'
2625       include 'COMMON.CONTACTS'
2626       include 'COMMON.TORSION'
2627       include 'COMMON.VECTORS'
2628       include 'COMMON.FFIELD'
2629       dimension ggg(3)
2630       integer xshift,yshift,zshift
2631 C      write(iout,*) 'In EELEC_soft_sphere'
2632       ees=0.0D0
2633       evdw1=0.0D0
2634       eel_loc=0.0d0
2635       eello_turn3=0.0d0
2636       eello_turn4=0.0d0
2637       ind=0
2638       do i=iatel_s,iatel_e
2639         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2640         dxi=dc(1,i)
2641         dyi=dc(2,i)
2642         dzi=dc(3,i)
2643         xmedi=c(1,i)+0.5d0*dxi
2644         ymedi=c(2,i)+0.5d0*dyi
2645         zmedi=c(3,i)+0.5d0*dzi
2646           xmedi=mod(xmedi,boxxsize)
2647           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2648           ymedi=mod(ymedi,boxysize)
2649           if (ymedi.lt.0) ymedi=ymedi+boxysize
2650           zmedi=mod(zmedi,boxzsize)
2651           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2652         num_conti=0
2653 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2654         do j=ielstart(i),ielend(i)
2655           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2656           ind=ind+1
2657           iteli=itel(i)
2658           itelj=itel(j)
2659           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2660           r0ij=rpp(iteli,itelj)
2661           r0ijsq=r0ij*r0ij
2662           dxj=dc(1,j)
2663           dyj=dc(2,j)
2664           dzj=dc(3,j)
2665           xj=c(1,j)+0.5D0*dxj
2666           yj=c(2,j)+0.5D0*dyj
2667           zj=c(3,j)+0.5D0*dzj
2668           xj=mod(xj,boxxsize)
2669           if (xj.lt.0) xj=xj+boxxsize
2670           yj=mod(yj,boxysize)
2671           if (yj.lt.0) yj=yj+boxysize
2672           zj=mod(zj,boxzsize)
2673           if (zj.lt.0) zj=zj+boxzsize
2674       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2675       xj_safe=xj
2676       yj_safe=yj
2677       zj_safe=zj
2678       isubchap=0
2679       do xshift=-1,1
2680       do yshift=-1,1
2681       do zshift=-1,1
2682           xj=xj_safe+xshift*boxxsize
2683           yj=yj_safe+yshift*boxysize
2684           zj=zj_safe+zshift*boxzsize
2685           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2686           if(dist_temp.lt.dist_init) then
2687             dist_init=dist_temp
2688             xj_temp=xj
2689             yj_temp=yj
2690             zj_temp=zj
2691             isubchap=1
2692           endif
2693        enddo
2694        enddo
2695        enddo
2696        if (isubchap.eq.1) then
2697           xj=xj_temp-xmedi
2698           yj=yj_temp-ymedi
2699           zj=zj_temp-zmedi
2700        else
2701           xj=xj_safe-xmedi
2702           yj=yj_safe-ymedi
2703           zj=zj_safe-zmedi
2704        endif
2705           rij=xj*xj+yj*yj+zj*zj
2706             sss=sscale(sqrt(rij))
2707             sssgrad=sscagrad(sqrt(rij))
2708           if (rij.lt.r0ijsq) then
2709             evdw1ij=0.25d0*(rij-r0ijsq)**2
2710             fac=rij-r0ijsq
2711           else
2712             evdw1ij=0.0d0
2713             fac=0.0d0
2714           endif
2715           evdw1=evdw1+evdw1ij*sss
2716 C
2717 C Calculate contributions to the Cartesian gradient.
2718 C
2719           ggg(1)=fac*xj*sssgrad
2720           ggg(2)=fac*yj*sssgrad
2721           ggg(3)=fac*zj*sssgrad
2722           do k=1,3
2723             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2724             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2725           enddo
2726 *
2727 * Loop over residues i+1 thru j-1.
2728 *
2729 cgrad          do k=i+1,j-1
2730 cgrad            do l=1,3
2731 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2732 cgrad            enddo
2733 cgrad          enddo
2734         enddo ! j
2735       enddo   ! i
2736 cgrad      do i=nnt,nct-1
2737 cgrad        do k=1,3
2738 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2739 cgrad        enddo
2740 cgrad        do j=i+1,nct-1
2741 cgrad          do k=1,3
2742 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2743 cgrad          enddo
2744 cgrad        enddo
2745 cgrad      enddo
2746       return
2747       end
2748 c------------------------------------------------------------------------------
2749       subroutine vec_and_deriv
2750       implicit real*8 (a-h,o-z)
2751       include 'DIMENSIONS'
2752 #ifdef MPI
2753       include 'mpif.h'
2754 #endif
2755       include 'COMMON.IOUNITS'
2756       include 'COMMON.GEO'
2757       include 'COMMON.VAR'
2758       include 'COMMON.LOCAL'
2759       include 'COMMON.CHAIN'
2760       include 'COMMON.VECTORS'
2761       include 'COMMON.SETUP'
2762       include 'COMMON.TIME1'
2763       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2764 C Compute the local reference systems. For reference system (i), the
2765 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2766 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2767 #ifdef PARVEC
2768       do i=ivec_start,ivec_end
2769 #else
2770       do i=1,nres-1
2771 #endif
2772           if (i.eq.nres-1) then
2773 C Case of the last full residue
2774 C Compute the Z-axis
2775             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2776             costh=dcos(pi-theta(nres))
2777             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2778             do k=1,3
2779               uz(k,i)=fac*uz(k,i)
2780             enddo
2781 C Compute the derivatives of uz
2782             uzder(1,1,1)= 0.0d0
2783             uzder(2,1,1)=-dc_norm(3,i-1)
2784             uzder(3,1,1)= dc_norm(2,i-1)
2785             uzder(1,2,1)= dc_norm(3,i-1)
2786             uzder(2,2,1)= 0.0d0
2787             uzder(3,2,1)=-dc_norm(1,i-1)
2788             uzder(1,3,1)=-dc_norm(2,i-1)
2789             uzder(2,3,1)= dc_norm(1,i-1)
2790             uzder(3,3,1)= 0.0d0
2791             uzder(1,1,2)= 0.0d0
2792             uzder(2,1,2)= dc_norm(3,i)
2793             uzder(3,1,2)=-dc_norm(2,i)
2794             uzder(1,2,2)=-dc_norm(3,i)
2795             uzder(2,2,2)= 0.0d0
2796             uzder(3,2,2)= dc_norm(1,i)
2797             uzder(1,3,2)= dc_norm(2,i)
2798             uzder(2,3,2)=-dc_norm(1,i)
2799             uzder(3,3,2)= 0.0d0
2800 C Compute the Y-axis
2801             facy=fac
2802             do k=1,3
2803               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2804             enddo
2805 C Compute the derivatives of uy
2806             do j=1,3
2807               do k=1,3
2808                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2809      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2810                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2811               enddo
2812               uyder(j,j,1)=uyder(j,j,1)-costh
2813               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2814             enddo
2815             do j=1,2
2816               do k=1,3
2817                 do l=1,3
2818                   uygrad(l,k,j,i)=uyder(l,k,j)
2819                   uzgrad(l,k,j,i)=uzder(l,k,j)
2820                 enddo
2821               enddo
2822             enddo
2823             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2824             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2825             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2826             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2827           else
2828 C Other residues
2829 C Compute the Z-axis
2830             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2831             costh=dcos(pi-theta(i+2))
2832             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2833             do k=1,3
2834               uz(k,i)=fac*uz(k,i)
2835             enddo
2836 C Compute the derivatives of uz
2837             uzder(1,1,1)= 0.0d0
2838             uzder(2,1,1)=-dc_norm(3,i+1)
2839             uzder(3,1,1)= dc_norm(2,i+1)
2840             uzder(1,2,1)= dc_norm(3,i+1)
2841             uzder(2,2,1)= 0.0d0
2842             uzder(3,2,1)=-dc_norm(1,i+1)
2843             uzder(1,3,1)=-dc_norm(2,i+1)
2844             uzder(2,3,1)= dc_norm(1,i+1)
2845             uzder(3,3,1)= 0.0d0
2846             uzder(1,1,2)= 0.0d0
2847             uzder(2,1,2)= dc_norm(3,i)
2848             uzder(3,1,2)=-dc_norm(2,i)
2849             uzder(1,2,2)=-dc_norm(3,i)
2850             uzder(2,2,2)= 0.0d0
2851             uzder(3,2,2)= dc_norm(1,i)
2852             uzder(1,3,2)= dc_norm(2,i)
2853             uzder(2,3,2)=-dc_norm(1,i)
2854             uzder(3,3,2)= 0.0d0
2855 C Compute the Y-axis
2856             facy=fac
2857             do k=1,3
2858               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2859             enddo
2860 C Compute the derivatives of uy
2861             do j=1,3
2862               do k=1,3
2863                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2864      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2865                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2866               enddo
2867               uyder(j,j,1)=uyder(j,j,1)-costh
2868               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2869             enddo
2870             do j=1,2
2871               do k=1,3
2872                 do l=1,3
2873                   uygrad(l,k,j,i)=uyder(l,k,j)
2874                   uzgrad(l,k,j,i)=uzder(l,k,j)
2875                 enddo
2876               enddo
2877             enddo
2878             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2879             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2880             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2881             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2882           endif
2883       enddo
2884       do i=1,nres-1
2885         vbld_inv_temp(1)=vbld_inv(i+1)
2886         if (i.lt.nres-1) then
2887           vbld_inv_temp(2)=vbld_inv(i+2)
2888           else
2889           vbld_inv_temp(2)=vbld_inv(i)
2890           endif
2891         do j=1,2
2892           do k=1,3
2893             do l=1,3
2894               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2895               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2896             enddo
2897           enddo
2898         enddo
2899       enddo
2900 #if defined(PARVEC) && defined(MPI)
2901       if (nfgtasks1.gt.1) then
2902         time00=MPI_Wtime()
2903 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2904 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2905 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2906         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2907      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2908      &   FG_COMM1,IERR)
2909         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2910      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2911      &   FG_COMM1,IERR)
2912         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2913      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2914      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2915         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2916      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2917      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2918         time_gather=time_gather+MPI_Wtime()-time00
2919       endif
2920 #endif
2921 #ifdef DEBUG
2922       if (fg_rank.eq.0) then
2923         write (iout,*) "Arrays UY and UZ"
2924         do i=1,nres-1
2925           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2926      &     (uz(k,i),k=1,3)
2927         enddo
2928       endif
2929 #endif
2930       return
2931       end
2932 C--------------------------------------------------------------------------
2933       subroutine set_matrices
2934       implicit real*8 (a-h,o-z)
2935       include 'DIMENSIONS'
2936 #ifdef MPI
2937       include "mpif.h"
2938       include "COMMON.SETUP"
2939       integer IERR
2940       integer status(MPI_STATUS_SIZE)
2941 #endif
2942       include 'COMMON.IOUNITS'
2943       include 'COMMON.GEO'
2944       include 'COMMON.VAR'
2945       include 'COMMON.LOCAL'
2946       include 'COMMON.CHAIN'
2947       include 'COMMON.DERIV'
2948       include 'COMMON.INTERACT'
2949       include 'COMMON.CONTACTS'
2950       include 'COMMON.TORSION'
2951       include 'COMMON.VECTORS'
2952       include 'COMMON.FFIELD'
2953       double precision auxvec(2),auxmat(2,2)
2954 C
2955 C Compute the virtual-bond-torsional-angle dependent quantities needed
2956 C to calculate the el-loc multibody terms of various order.
2957 C
2958 c      write(iout,*) 'nphi=',nphi,nres
2959 c      write(iout,*) "itype2loc",itype2loc
2960 #ifdef PARMAT
2961       do i=ivec_start+2,ivec_end+2
2962 #else
2963       do i=3,nres+1
2964 #endif
2965         ii=ireschain(i-2)
2966 c        write (iout,*) "i",i,i-2," ii",ii
2967         if (ii.eq.0) cycle
2968         innt=chain_border(1,ii)
2969         inct=chain_border(2,ii)
2970 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2971 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2972         if (i.gt. innt+2 .and. i.lt.inct+2) then
2973           iti = itype2loc(itype(i-2))
2974         else
2975           iti=nloctyp
2976         endif
2977 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2978         if (i.gt. innt+1 .and. i.lt.inct+1) then
2979           iti1 = itype2loc(itype(i-1))
2980         else
2981           iti1=nloctyp
2982         endif
2983 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2984 c     &  " iti1",itype(i-1),iti1
2985 #ifdef NEWCORR
2986         cost1=dcos(theta(i-1))
2987         sint1=dsin(theta(i-1))
2988         sint1sq=sint1*sint1
2989         sint1cub=sint1sq*sint1
2990         sint1cost1=2*sint1*cost1
2991 c        write (iout,*) "bnew1",i,iti
2992 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2993 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2994 c        write (iout,*) "bnew2",i,iti
2995 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2996 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2997         do k=1,2
2998           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2999           b1(k,i-2)=sint1*b1k
3000           gtb1(k,i-2)=cost1*b1k-sint1sq*
3001      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3002           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3003           b2(k,i-2)=sint1*b2k
3004           gtb2(k,i-2)=cost1*b2k-sint1sq*
3005      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3006         enddo
3007         do k=1,2
3008           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3009           cc(1,k,i-2)=sint1sq*aux
3010           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3011      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3012           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3013           dd(1,k,i-2)=sint1sq*aux
3014           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3015      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3016         enddo
3017         cc(2,1,i-2)=cc(1,2,i-2)
3018         cc(2,2,i-2)=-cc(1,1,i-2)
3019         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3020         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3021         dd(2,1,i-2)=dd(1,2,i-2)
3022         dd(2,2,i-2)=-dd(1,1,i-2)
3023         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3024         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3025         do k=1,2
3026           do l=1,2
3027             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3028             EE(l,k,i-2)=sint1sq*aux
3029             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3030           enddo
3031         enddo
3032         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3033         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3034         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3035         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3036         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3037         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3038         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3039 c        b1tilde(1,i-2)=b1(1,i-2)
3040 c        b1tilde(2,i-2)=-b1(2,i-2)
3041 c        b2tilde(1,i-2)=b2(1,i-2)
3042 c        b2tilde(2,i-2)=-b2(2,i-2)
3043 #ifdef DEBUG
3044         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3045         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3046         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3047         write (iout,*) 'theta=', theta(i-1)
3048 #endif
3049 #else
3050         if (i.gt. innt+2 .and. i.lt.inct+2) then
3051 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3052           iti = itype2loc(itype(i-2))
3053         else
3054           iti=nloctyp
3055         endif
3056 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3057 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3058         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3059           iti1 = itype2loc(itype(i-1))
3060         else
3061           iti1=nloctyp
3062         endif
3063         b1(1,i-2)=b(3,iti)
3064         b1(2,i-2)=b(5,iti)
3065         b2(1,i-2)=b(2,iti)
3066         b2(2,i-2)=b(4,iti)
3067         do k=1,2
3068           do l=1,2
3069            CC(k,l,i-2)=ccold(k,l,iti)
3070            DD(k,l,i-2)=ddold(k,l,iti)
3071            EE(k,l,i-2)=eeold(k,l,iti)
3072            gtEE(k,l,i-2)=0.0d0
3073           enddo
3074         enddo
3075 #endif
3076         b1tilde(1,i-2)= b1(1,i-2)
3077         b1tilde(2,i-2)=-b1(2,i-2)
3078         b2tilde(1,i-2)= b2(1,i-2)
3079         b2tilde(2,i-2)=-b2(2,i-2)
3080 c
3081         Ctilde(1,1,i-2)= CC(1,1,i-2)
3082         Ctilde(1,2,i-2)= CC(1,2,i-2)
3083         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3084         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3085 c
3086         Dtilde(1,1,i-2)= DD(1,1,i-2)
3087         Dtilde(1,2,i-2)= DD(1,2,i-2)
3088         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3089         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3090 #ifdef DEBUG
3091         write(iout,*) "i",i," iti",iti
3092         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3093         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3094 #endif
3095       enddo
3096       mu=0.0d0
3097 #ifdef PARMAT
3098       do i=ivec_start+2,ivec_end+2
3099 #else
3100       do i=3,nres+1
3101 #endif
3102 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3103         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3104           sin1=dsin(phi(i))
3105           cos1=dcos(phi(i))
3106           sintab(i-2)=sin1
3107           costab(i-2)=cos1
3108           obrot(1,i-2)=cos1
3109           obrot(2,i-2)=sin1
3110           sin2=dsin(2*phi(i))
3111           cos2=dcos(2*phi(i))
3112           sintab2(i-2)=sin2
3113           costab2(i-2)=cos2
3114           obrot2(1,i-2)=cos2
3115           obrot2(2,i-2)=sin2
3116           Ug(1,1,i-2)=-cos1
3117           Ug(1,2,i-2)=-sin1
3118           Ug(2,1,i-2)=-sin1
3119           Ug(2,2,i-2)= cos1
3120           Ug2(1,1,i-2)=-cos2
3121           Ug2(1,2,i-2)=-sin2
3122           Ug2(2,1,i-2)=-sin2
3123           Ug2(2,2,i-2)= cos2
3124         else
3125           costab(i-2)=1.0d0
3126           sintab(i-2)=0.0d0
3127           obrot(1,i-2)=1.0d0
3128           obrot(2,i-2)=0.0d0
3129           obrot2(1,i-2)=0.0d0
3130           obrot2(2,i-2)=0.0d0
3131           Ug(1,1,i-2)=1.0d0
3132           Ug(1,2,i-2)=0.0d0
3133           Ug(2,1,i-2)=0.0d0
3134           Ug(2,2,i-2)=1.0d0
3135           Ug2(1,1,i-2)=0.0d0
3136           Ug2(1,2,i-2)=0.0d0
3137           Ug2(2,1,i-2)=0.0d0
3138           Ug2(2,2,i-2)=0.0d0
3139         endif
3140         if (i .gt. 3) then
3141           obrot_der(1,i-2)=-sin1
3142           obrot_der(2,i-2)= cos1
3143           Ugder(1,1,i-2)= sin1
3144           Ugder(1,2,i-2)=-cos1
3145           Ugder(2,1,i-2)=-cos1
3146           Ugder(2,2,i-2)=-sin1
3147           dwacos2=cos2+cos2
3148           dwasin2=sin2+sin2
3149           obrot2_der(1,i-2)=-dwasin2
3150           obrot2_der(2,i-2)= dwacos2
3151           Ug2der(1,1,i-2)= dwasin2
3152           Ug2der(1,2,i-2)=-dwacos2
3153           Ug2der(2,1,i-2)=-dwacos2
3154           Ug2der(2,2,i-2)=-dwasin2
3155         else
3156           obrot_der(1,i-2)=0.0d0
3157           obrot_der(2,i-2)=0.0d0
3158           Ugder(1,1,i-2)=0.0d0
3159           Ugder(1,2,i-2)=0.0d0
3160           Ugder(2,1,i-2)=0.0d0
3161           Ugder(2,2,i-2)=0.0d0
3162           obrot2_der(1,i-2)=0.0d0
3163           obrot2_der(2,i-2)=0.0d0
3164           Ug2der(1,1,i-2)=0.0d0
3165           Ug2der(1,2,i-2)=0.0d0
3166           Ug2der(2,1,i-2)=0.0d0
3167           Ug2der(2,2,i-2)=0.0d0
3168         endif
3169 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3170 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3171         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3172           iti = itype2loc(itype(i-2))
3173         else
3174           iti=nloctyp
3175         endif
3176 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3177         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3178           iti1 = itype2loc(itype(i-1))
3179         else
3180           iti1=nloctyp
3181         endif
3182 cd        write (iout,*) '*******i',i,' iti1',iti
3183 cd        write (iout,*) 'b1',b1(:,iti)
3184 cd        write (iout,*) 'b2',b2(:,iti)
3185 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3186 c        if (i .gt. iatel_s+2) then
3187         if (i .gt. nnt+2) then
3188           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3189 #ifdef NEWCORR
3190           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3191 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3192 #endif
3193 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3194 c     &    EE(1,2,iti),EE(2,2,i)
3195           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3196           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3197 c          write(iout,*) "Macierz EUG",
3198 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3199 c     &    eug(2,2,i-2)
3200           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3201      &    then
3202           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3203           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3204           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3205           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3206           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3207           endif
3208         else
3209           do k=1,2
3210             Ub2(k,i-2)=0.0d0
3211             Ctobr(k,i-2)=0.0d0
3212             Dtobr2(k,i-2)=0.0d0
3213             do l=1,2
3214               EUg(l,k,i-2)=0.0d0
3215               CUg(l,k,i-2)=0.0d0
3216               DUg(l,k,i-2)=0.0d0
3217               DtUg2(l,k,i-2)=0.0d0
3218             enddo
3219           enddo
3220         endif
3221         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3222         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3223         do k=1,2
3224           muder(k,i-2)=Ub2der(k,i-2)
3225         enddo
3226 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3227         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3228           if (itype(i-1).le.ntyp) then
3229             iti1 = itype2loc(itype(i-1))
3230           else
3231             iti1=nloctyp
3232           endif
3233         else
3234           iti1=nloctyp
3235         endif
3236         do k=1,2
3237           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3238 c          mu(k,i-2)=b1(k,i-1)
3239 c          mu(k,i-2)=Ub2(k,i-2)
3240         enddo
3241 #ifdef MUOUT
3242         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3243      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3244      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3245      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3246      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3247      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3248 #endif
3249 cd        write (iout,*) 'mu1',mu1(:,i-2)
3250 cd        write (iout,*) 'mu2',mu2(:,i-2)
3251 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3252         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3253      &  then
3254         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3255         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3256         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3257         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3258         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3259 C Vectors and matrices dependent on a single virtual-bond dihedral.
3260         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3261         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3262         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3263         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3264         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3265         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3266         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3267         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3268         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3269         endif
3270       enddo
3271 C Matrices dependent on two consecutive virtual-bond dihedrals.
3272 C The order of matrices is from left to right.
3273       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3274      &then
3275 c      do i=max0(ivec_start,2),ivec_end
3276       do i=2,nres-1
3277         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3278         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3279         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3280         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3281         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3282         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3283         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3284         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3285       enddo
3286       endif
3287 #if defined(MPI) && defined(PARMAT)
3288 #ifdef DEBUG
3289 c      if (fg_rank.eq.0) then
3290         write (iout,*) "Arrays UG and UGDER before GATHER"
3291         do i=1,nres-1
3292           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3293      &     ((ug(l,k,i),l=1,2),k=1,2),
3294      &     ((ugder(l,k,i),l=1,2),k=1,2)
3295         enddo
3296         write (iout,*) "Arrays UG2 and UG2DER"
3297         do i=1,nres-1
3298           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3299      &     ((ug2(l,k,i),l=1,2),k=1,2),
3300      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3301         enddo
3302         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3303         do i=1,nres-1
3304           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3305      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3306      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3307         enddo
3308         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3309         do i=1,nres-1
3310           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3311      &     costab(i),sintab(i),costab2(i),sintab2(i)
3312         enddo
3313         write (iout,*) "Array MUDER"
3314         do i=1,nres-1
3315           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3316         enddo
3317 c      endif
3318 #endif
3319       if (nfgtasks.gt.1) then
3320         time00=MPI_Wtime()
3321 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3322 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3323 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3324 #ifdef MATGATHER
3325         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3326      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3327      &   FG_COMM1,IERR)
3328         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3329      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3330      &   FG_COMM1,IERR)
3331         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3332      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3333      &   FG_COMM1,IERR)
3334         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3335      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3336      &   FG_COMM1,IERR)
3337         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3338      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3339      &   FG_COMM1,IERR)
3340         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3341      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3342      &   FG_COMM1,IERR)
3343         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3344      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3345      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3346         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3347      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3348      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3349         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3350      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3351      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3352         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3353      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3354      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3355         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3356      &  then
3357         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3358      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3359      &   FG_COMM1,IERR)
3360         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3361      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3362      &   FG_COMM1,IERR)
3363         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3364      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3365      &   FG_COMM1,IERR)
3366        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3367      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3368      &   FG_COMM1,IERR)
3369         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3370      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3371      &   FG_COMM1,IERR)
3372         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3373      &   ivec_count(fg_rank1),
3374      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3375      &   FG_COMM1,IERR)
3376         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3377      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3378      &   FG_COMM1,IERR)
3379         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3380      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3381      &   FG_COMM1,IERR)
3382         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3383      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3384      &   FG_COMM1,IERR)
3385         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3386      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3387      &   FG_COMM1,IERR)
3388         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3389      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3390      &   FG_COMM1,IERR)
3391         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3392      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3393      &   FG_COMM1,IERR)
3394         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3395      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3396      &   FG_COMM1,IERR)
3397         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3398      &   ivec_count(fg_rank1),
3399      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3400      &   FG_COMM1,IERR)
3401         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3402      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3403      &   FG_COMM1,IERR)
3404        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3405      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3406      &   FG_COMM1,IERR)
3407         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3408      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3409      &   FG_COMM1,IERR)
3410        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3411      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3412      &   FG_COMM1,IERR)
3413         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3414      &   ivec_count(fg_rank1),
3415      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3416      &   FG_COMM1,IERR)
3417         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3418      &   ivec_count(fg_rank1),
3419      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3420      &   FG_COMM1,IERR)
3421         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3422      &   ivec_count(fg_rank1),
3423      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3424      &   MPI_MAT2,FG_COMM1,IERR)
3425         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3426      &   ivec_count(fg_rank1),
3427      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3428      &   MPI_MAT2,FG_COMM1,IERR)
3429         endif
3430 #else
3431 c Passes matrix info through the ring
3432       isend=fg_rank1
3433       irecv=fg_rank1-1
3434       if (irecv.lt.0) irecv=nfgtasks1-1
3435       iprev=irecv
3436       inext=fg_rank1+1
3437       if (inext.ge.nfgtasks1) inext=0
3438       do i=1,nfgtasks1-1
3439 c        write (iout,*) "isend",isend," irecv",irecv
3440 c        call flush(iout)
3441         lensend=lentyp(isend)
3442         lenrecv=lentyp(irecv)
3443 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3444 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3445 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3446 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3447 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3448 c        write (iout,*) "Gather ROTAT1"
3449 c        call flush(iout)
3450 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3451 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3452 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3453 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3454 c        write (iout,*) "Gather ROTAT2"
3455 c        call flush(iout)
3456         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3457      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3458      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3459      &   iprev,4400+irecv,FG_COMM,status,IERR)
3460 c        write (iout,*) "Gather ROTAT_OLD"
3461 c        call flush(iout)
3462         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3463      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3464      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3465      &   iprev,5500+irecv,FG_COMM,status,IERR)
3466 c        write (iout,*) "Gather PRECOMP11"
3467 c        call flush(iout)
3468         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3469      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3470      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3471      &   iprev,6600+irecv,FG_COMM,status,IERR)
3472 c        write (iout,*) "Gather PRECOMP12"
3473 c        call flush(iout)
3474         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3475      &  then
3476         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3477      &   MPI_ROTAT2(lensend),inext,7700+isend,
3478      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3479      &   iprev,7700+irecv,FG_COMM,status,IERR)
3480 c        write (iout,*) "Gather PRECOMP21"
3481 c        call flush(iout)
3482         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3483      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3484      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3485      &   iprev,8800+irecv,FG_COMM,status,IERR)
3486 c        write (iout,*) "Gather PRECOMP22"
3487 c        call flush(iout)
3488         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3489      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3490      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3491      &   MPI_PRECOMP23(lenrecv),
3492      &   iprev,9900+irecv,FG_COMM,status,IERR)
3493 c        write (iout,*) "Gather PRECOMP23"
3494 c        call flush(iout)
3495         endif
3496         isend=irecv
3497         irecv=irecv-1
3498         if (irecv.lt.0) irecv=nfgtasks1-1
3499       enddo
3500 #endif
3501         time_gather=time_gather+MPI_Wtime()-time00
3502       endif
3503 #ifdef DEBUG
3504 c      if (fg_rank.eq.0) then
3505         write (iout,*) "Arrays UG and UGDER"
3506         do i=1,nres-1
3507           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3508      &     ((ug(l,k,i),l=1,2),k=1,2),
3509      &     ((ugder(l,k,i),l=1,2),k=1,2)
3510         enddo
3511         write (iout,*) "Arrays UG2 and UG2DER"
3512         do i=1,nres-1
3513           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3514      &     ((ug2(l,k,i),l=1,2),k=1,2),
3515      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3516         enddo
3517         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3518         do i=1,nres-1
3519           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3520      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3521      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3522         enddo
3523         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3524         do i=1,nres-1
3525           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3526      &     costab(i),sintab(i),costab2(i),sintab2(i)
3527         enddo
3528         write (iout,*) "Array MUDER"
3529         do i=1,nres-1
3530           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3531         enddo
3532 c      endif
3533 #endif
3534 #endif
3535 cd      do i=1,nres
3536 cd        iti = itype2loc(itype(i))
3537 cd        write (iout,*) i
3538 cd        do j=1,2
3539 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3540 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3541 cd        enddo
3542 cd      enddo
3543       return
3544       end
3545 C-----------------------------------------------------------------------------
3546       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3547 C
3548 C This subroutine calculates the average interaction energy and its gradient
3549 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3550 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3551 C The potential depends both on the distance of peptide-group centers and on
3552 C the orientation of the CA-CA virtual bonds.
3553 C
3554       implicit real*8 (a-h,o-z)
3555 #ifdef MPI
3556       include 'mpif.h'
3557 #endif
3558       include 'DIMENSIONS'
3559       include 'COMMON.CONTROL'
3560       include 'COMMON.SETUP'
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),gmuij(4)
3578       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3579      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3580      &    num_conti,j1,j2
3581 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3582 #ifdef MOMENT
3583       double precision scal_el /1.0d0/
3584 #else
3585       double precision scal_el /0.5d0/
3586 #endif
3587 C 12/13/98
3588 C 13-go grudnia roku pamietnego...
3589       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3590      &                   0.0d0,1.0d0,0.0d0,
3591      &                   0.0d0,0.0d0,1.0d0/
3592 cd      write(iout,*) 'In EELEC'
3593 cd      do i=1,nloctyp
3594 cd        write(iout,*) 'Type',i
3595 cd        write(iout,*) 'B1',B1(:,i)
3596 cd        write(iout,*) 'B2',B2(:,i)
3597 cd        write(iout,*) 'CC',CC(:,:,i)
3598 cd        write(iout,*) 'DD',DD(:,:,i)
3599 cd        write(iout,*) 'EE',EE(:,:,i)
3600 cd      enddo
3601 cd      call check_vecgrad
3602 cd      stop
3603       if (icheckgrad.eq.1) then
3604         do i=1,nres-1
3605           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3606           do k=1,3
3607             dc_norm(k,i)=dc(k,i)*fac
3608           enddo
3609 c          write (iout,*) 'i',i,' fac',fac
3610         enddo
3611       endif
3612       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3613      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3614      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3615 c        call vec_and_deriv
3616 #ifdef TIMING
3617         time01=MPI_Wtime()
3618 #endif
3619         call set_matrices
3620 #ifdef TIMING
3621         time_mat=time_mat+MPI_Wtime()-time01
3622 #endif
3623       endif
3624 cd      do i=1,nres-1
3625 cd        write (iout,*) 'i=',i
3626 cd        do k=1,3
3627 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3628 cd        enddo
3629 cd        do k=1,3
3630 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3631 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3632 cd        enddo
3633 cd      enddo
3634       t_eelecij=0.0d0
3635       ees=0.0D0
3636       evdw1=0.0D0
3637       eel_loc=0.0d0
3638       eello_turn3=0.0d0
3639       eello_turn4=0.0d0
3640       ind=0
3641       do i=1,nres
3642         num_cont_hb(i)=0
3643       enddo
3644 cd      print '(a)','Enter EELEC'
3645 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3646       do i=1,nres
3647         gel_loc_loc(i)=0.0d0
3648         gcorr_loc(i)=0.0d0
3649       enddo
3650 c
3651 c
3652 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3653 C
3654 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3655 C
3656 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3657       do i=iturn3_start,iturn3_end
3658 c        if (i.le.1) cycle
3659 C        write(iout,*) "tu jest i",i
3660         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3661 C changes suggested by Ana to avoid out of bounds
3662 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3663 c     & .or.((i+4).gt.nres)
3664 c     & .or.((i-1).le.0)
3665 C end of changes by Ana
3666      &  .or. itype(i+2).eq.ntyp1
3667      &  .or. itype(i+3).eq.ntyp1) cycle
3668 C Adam: Instructions below will switch off existing interactions
3669 c        if(i.gt.1)then
3670 c          if(itype(i-1).eq.ntyp1)cycle
3671 c        end if
3672 c        if(i.LT.nres-3)then
3673 c          if (itype(i+4).eq.ntyp1) cycle
3674 c        end if
3675         dxi=dc(1,i)
3676         dyi=dc(2,i)
3677         dzi=dc(3,i)
3678         dx_normi=dc_norm(1,i)
3679         dy_normi=dc_norm(2,i)
3680         dz_normi=dc_norm(3,i)
3681         xmedi=c(1,i)+0.5d0*dxi
3682         ymedi=c(2,i)+0.5d0*dyi
3683         zmedi=c(3,i)+0.5d0*dzi
3684           xmedi=mod(xmedi,boxxsize)
3685           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3686           ymedi=mod(ymedi,boxysize)
3687           if (ymedi.lt.0) ymedi=ymedi+boxysize
3688           zmedi=mod(zmedi,boxzsize)
3689           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3690         num_conti=0
3691         call eelecij(i,i+2,ees,evdw1,eel_loc)
3692         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3693         num_cont_hb(i)=num_conti
3694       enddo
3695       do i=iturn4_start,iturn4_end
3696         if (i.lt.1) cycle
3697         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3698 C changes suggested by Ana to avoid out of bounds
3699 c     & .or.((i+5).gt.nres)
3700 c     & .or.((i-1).le.0)
3701 C end of changes suggested by Ana
3702      &    .or. itype(i+3).eq.ntyp1
3703      &    .or. itype(i+4).eq.ntyp1
3704 c     &    .or. itype(i+5).eq.ntyp1
3705 c     &    .or. itype(i).eq.ntyp1
3706 c     &    .or. itype(i-1).eq.ntyp1
3707      &                             ) cycle
3708         dxi=dc(1,i)
3709         dyi=dc(2,i)
3710         dzi=dc(3,i)
3711         dx_normi=dc_norm(1,i)
3712         dy_normi=dc_norm(2,i)
3713         dz_normi=dc_norm(3,i)
3714         xmedi=c(1,i)+0.5d0*dxi
3715         ymedi=c(2,i)+0.5d0*dyi
3716         zmedi=c(3,i)+0.5d0*dzi
3717 C Return atom into box, boxxsize is size of box in x dimension
3718 c  194   continue
3719 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3720 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3721 C Condition for being inside the proper box
3722 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3723 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3724 c        go to 194
3725 c        endif
3726 c  195   continue
3727 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3728 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3729 C Condition for being inside the proper box
3730 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3731 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3732 c        go to 195
3733 c        endif
3734 c  196   continue
3735 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3736 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3737 C Condition for being inside the proper box
3738 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3739 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3740 c        go to 196
3741 c        endif
3742           xmedi=mod(xmedi,boxxsize)
3743           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3744           ymedi=mod(ymedi,boxysize)
3745           if (ymedi.lt.0) ymedi=ymedi+boxysize
3746           zmedi=mod(zmedi,boxzsize)
3747           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3748
3749         num_conti=num_cont_hb(i)
3750 c        write(iout,*) "JESTEM W PETLI"
3751         call eelecij(i,i+3,ees,evdw1,eel_loc)
3752         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3753      &   call eturn4(i,eello_turn4)
3754         num_cont_hb(i)=num_conti
3755       enddo   ! i
3756 C Loop over all neighbouring boxes
3757 C      do xshift=-1,1
3758 C      do yshift=-1,1
3759 C      do zshift=-1,1
3760 c
3761 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3762 c
3763 CTU KURWA
3764       do i=iatel_s,iatel_e
3765 C        do i=75,75
3766 c        if (i.le.1) cycle
3767         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3768 C changes suggested by Ana to avoid out of bounds
3769 c     & .or.((i+2).gt.nres)
3770 c     & .or.((i-1).le.0)
3771 C end of changes by Ana
3772 c     &  .or. itype(i+2).eq.ntyp1
3773 c     &  .or. itype(i-1).eq.ntyp1
3774      &                ) cycle
3775         dxi=dc(1,i)
3776         dyi=dc(2,i)
3777         dzi=dc(3,i)
3778         dx_normi=dc_norm(1,i)
3779         dy_normi=dc_norm(2,i)
3780         dz_normi=dc_norm(3,i)
3781         xmedi=c(1,i)+0.5d0*dxi
3782         ymedi=c(2,i)+0.5d0*dyi
3783         zmedi=c(3,i)+0.5d0*dzi
3784           xmedi=mod(xmedi,boxxsize)
3785           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3786           ymedi=mod(ymedi,boxysize)
3787           if (ymedi.lt.0) ymedi=ymedi+boxysize
3788           zmedi=mod(zmedi,boxzsize)
3789           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3790 C          xmedi=xmedi+xshift*boxxsize
3791 C          ymedi=ymedi+yshift*boxysize
3792 C          zmedi=zmedi+zshift*boxzsize
3793
3794 C Return tom into box, boxxsize is size of box in x dimension
3795 c  164   continue
3796 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3797 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3798 C Condition for being inside the proper box
3799 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3800 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3801 c        go to 164
3802 c        endif
3803 c  165   continue
3804 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3805 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3806 C Condition for being inside the proper box
3807 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3808 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3809 c        go to 165
3810 c        endif
3811 c  166   continue
3812 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3813 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3814 cC Condition for being inside the proper box
3815 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3816 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3817 c        go to 166
3818 c        endif
3819
3820 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3821         num_conti=num_cont_hb(i)
3822 C I TU KURWA
3823         do j=ielstart(i),ielend(i)
3824 C          do j=16,17
3825 C          write (iout,*) i,j
3826 C         if (j.le.1) cycle
3827           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3828 C changes suggested by Ana to avoid out of bounds
3829 c     & .or.((j+2).gt.nres)
3830 c     & .or.((j-1).le.0)
3831 C end of changes by Ana
3832 c     & .or.itype(j+2).eq.ntyp1
3833 c     & .or.itype(j-1).eq.ntyp1
3834      &) cycle
3835           call eelecij(i,j,ees,evdw1,eel_loc)
3836         enddo ! j
3837         num_cont_hb(i)=num_conti
3838       enddo   ! i
3839 C     enddo   ! zshift
3840 C      enddo   ! yshift
3841 C      enddo   ! xshift
3842
3843 c      write (iout,*) "Number of loop steps in EELEC:",ind
3844 cd      do i=1,nres
3845 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3846 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3847 cd      enddo
3848 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3849 ccc      eel_loc=eel_loc+eello_turn3
3850 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3851       return
3852       end
3853 C-------------------------------------------------------------------------------
3854       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3855       implicit real*8 (a-h,o-z)
3856       include 'DIMENSIONS'
3857 #ifdef MPI
3858       include "mpif.h"
3859 #endif
3860       include 'COMMON.CONTROL'
3861       include 'COMMON.IOUNITS'
3862       include 'COMMON.GEO'
3863       include 'COMMON.VAR'
3864       include 'COMMON.LOCAL'
3865       include 'COMMON.CHAIN'
3866       include 'COMMON.DERIV'
3867       include 'COMMON.INTERACT'
3868       include 'COMMON.CONTACTS'
3869       include 'COMMON.TORSION'
3870       include 'COMMON.VECTORS'
3871       include 'COMMON.FFIELD'
3872       include 'COMMON.TIME1'
3873       include 'COMMON.SPLITELE'
3874       include 'COMMON.SHIELD'
3875       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3876      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3877       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3878      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3879      &    gmuij2(4),gmuji2(4)
3880       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3881      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3882      &    num_conti,j1,j2
3883 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3884 #ifdef MOMENT
3885       double precision scal_el /1.0d0/
3886 #else
3887       double precision scal_el /0.5d0/
3888 #endif
3889 C 12/13/98
3890 C 13-go grudnia roku pamietnego...
3891       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3892      &                   0.0d0,1.0d0,0.0d0,
3893      &                   0.0d0,0.0d0,1.0d0/
3894        integer xshift,yshift,zshift
3895 c          time00=MPI_Wtime()
3896 cd      write (iout,*) "eelecij",i,j
3897 c          ind=ind+1
3898           iteli=itel(i)
3899           itelj=itel(j)
3900           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3901           aaa=app(iteli,itelj)
3902           bbb=bpp(iteli,itelj)
3903           ael6i=ael6(iteli,itelj)
3904           ael3i=ael3(iteli,itelj)
3905           dxj=dc(1,j)
3906           dyj=dc(2,j)
3907           dzj=dc(3,j)
3908           dx_normj=dc_norm(1,j)
3909           dy_normj=dc_norm(2,j)
3910           dz_normj=dc_norm(3,j)
3911 C          xj=c(1,j)+0.5D0*dxj-xmedi
3912 C          yj=c(2,j)+0.5D0*dyj-ymedi
3913 C          zj=c(3,j)+0.5D0*dzj-zmedi
3914           xj=c(1,j)+0.5D0*dxj
3915           yj=c(2,j)+0.5D0*dyj
3916           zj=c(3,j)+0.5D0*dzj
3917           xj=mod(xj,boxxsize)
3918           if (xj.lt.0) xj=xj+boxxsize
3919           yj=mod(yj,boxysize)
3920           if (yj.lt.0) yj=yj+boxysize
3921           zj=mod(zj,boxzsize)
3922           if (zj.lt.0) zj=zj+boxzsize
3923           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3924       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3925       xj_safe=xj
3926       yj_safe=yj
3927       zj_safe=zj
3928       isubchap=0
3929       do xshift=-1,1
3930       do yshift=-1,1
3931       do zshift=-1,1
3932           xj=xj_safe+xshift*boxxsize
3933           yj=yj_safe+yshift*boxysize
3934           zj=zj_safe+zshift*boxzsize
3935           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3936           if(dist_temp.lt.dist_init) then
3937             dist_init=dist_temp
3938             xj_temp=xj
3939             yj_temp=yj
3940             zj_temp=zj
3941             isubchap=1
3942           endif
3943        enddo
3944        enddo
3945        enddo
3946        if (isubchap.eq.1) then
3947           xj=xj_temp-xmedi
3948           yj=yj_temp-ymedi
3949           zj=zj_temp-zmedi
3950        else
3951           xj=xj_safe-xmedi
3952           yj=yj_safe-ymedi
3953           zj=zj_safe-zmedi
3954        endif
3955 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3956 c  174   continue
3957 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3958 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3959 C Condition for being inside the proper box
3960 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3961 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3962 c        go to 174
3963 c        endif
3964 c  175   continue
3965 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3966 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3967 C Condition for being inside the proper box
3968 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3969 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3970 c        go to 175
3971 c        endif
3972 c  176   continue
3973 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3974 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3975 C Condition for being inside the proper box
3976 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3977 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3978 c        go to 176
3979 c        endif
3980 C        endif !endPBC condintion
3981 C        xj=xj-xmedi
3982 C        yj=yj-ymedi
3983 C        zj=zj-zmedi
3984           rij=xj*xj+yj*yj+zj*zj
3985
3986             sss=sscale(sqrt(rij))
3987             sssgrad=sscagrad(sqrt(rij))
3988 c            if (sss.gt.0.0d0) then
3989           rrmij=1.0D0/rij
3990           rij=dsqrt(rij)
3991           rmij=1.0D0/rij
3992           r3ij=rrmij*rmij
3993           r6ij=r3ij*r3ij
3994           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3995           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3996           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3997           fac=cosa-3.0D0*cosb*cosg
3998           ev1=aaa*r6ij*r6ij
3999 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4000           if (j.eq.i+2) ev1=scal_el*ev1
4001           ev2=bbb*r6ij
4002           fac3=ael6i*r6ij
4003           fac4=ael3i*r3ij
4004           evdwij=(ev1+ev2)
4005           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4006           el2=fac4*fac
4007 C MARYSIA
4008 C          eesij=(el1+el2)
4009 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4010           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4011           if (shield_mode.gt.0) then
4012 C          fac_shield(i)=0.4
4013 C          fac_shield(j)=0.6
4014           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4015           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4016           eesij=(el1+el2)
4017           ees=ees+eesij
4018           else
4019           fac_shield(i)=1.0
4020           fac_shield(j)=1.0
4021           eesij=(el1+el2)
4022           ees=ees+eesij
4023           endif
4024           evdw1=evdw1+evdwij*sss
4025 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4026 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4027 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4028 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4029
4030           if (energy_dec) then
4031               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4032      &'evdw1',i,j,evdwij
4033      &,iteli,itelj,aaa,evdw1,sss
4034               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4035      &fac_shield(i),fac_shield(j)
4036           endif
4037
4038 C
4039 C Calculate contributions to the Cartesian gradient.
4040 C
4041 #ifdef SPLITELE
4042           facvdw=-6*rrmij*(ev1+evdwij)*sss
4043           facel=-3*rrmij*(el1+eesij)
4044           fac1=fac
4045           erij(1)=xj*rmij
4046           erij(2)=yj*rmij
4047           erij(3)=zj*rmij
4048
4049 *
4050 * Radial derivatives. First process both termini of the fragment (i,j)
4051 *
4052           ggg(1)=facel*xj
4053           ggg(2)=facel*yj
4054           ggg(3)=facel*zj
4055           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4056      &  (shield_mode.gt.0)) then
4057 C          print *,i,j
4058           do ilist=1,ishield_list(i)
4059            iresshield=shield_list(ilist,i)
4060            do k=1,3
4061            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4062      &      *2.0
4063            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4064      &              rlocshield
4065      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4066             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4067 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4068 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4069 C             if (iresshield.gt.i) then
4070 C               do ishi=i+1,iresshield-1
4071 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4072 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4073 C
4074 C              enddo
4075 C             else
4076 C               do ishi=iresshield,i
4077 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4078 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4079 C
4080 C               enddo
4081 C              endif
4082            enddo
4083           enddo
4084           do ilist=1,ishield_list(j)
4085            iresshield=shield_list(ilist,j)
4086            do k=1,3
4087            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4088      &     *2.0
4089            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4090      &              rlocshield
4091      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4092            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4093
4094 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4095 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4096 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4097 C             if (iresshield.gt.j) then
4098 C               do ishi=j+1,iresshield-1
4099 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4100 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4101 C
4102 C               enddo
4103 C            else
4104 C               do ishi=iresshield,j
4105 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4106 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4107 C               enddo
4108 C              endif
4109            enddo
4110           enddo
4111
4112           do k=1,3
4113             gshieldc(k,i)=gshieldc(k,i)+
4114      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4115             gshieldc(k,j)=gshieldc(k,j)+
4116      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4117             gshieldc(k,i-1)=gshieldc(k,i-1)+
4118      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4119             gshieldc(k,j-1)=gshieldc(k,j-1)+
4120      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4121
4122            enddo
4123            endif
4124 c          do k=1,3
4125 c            ghalf=0.5D0*ggg(k)
4126 c            gelc(k,i)=gelc(k,i)+ghalf
4127 c            gelc(k,j)=gelc(k,j)+ghalf
4128 c          enddo
4129 c 9/28/08 AL Gradient compotents will be summed only at the end
4130 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4131           do k=1,3
4132             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4133 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4134             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4135 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4136 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4137 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4138 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4139 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4140           enddo
4141 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4142
4143 *
4144 * Loop over residues i+1 thru j-1.
4145 *
4146 cgrad          do k=i+1,j-1
4147 cgrad            do l=1,3
4148 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4149 cgrad            enddo
4150 cgrad          enddo
4151           if (sss.gt.0.0) then
4152           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4153           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4154           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4155           else
4156           ggg(1)=0.0
4157           ggg(2)=0.0
4158           ggg(3)=0.0
4159           endif
4160 c          do k=1,3
4161 c            ghalf=0.5D0*ggg(k)
4162 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4163 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4164 c          enddo
4165 c 9/28/08 AL Gradient compotents will be summed only at the end
4166           do k=1,3
4167             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4168             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4169           enddo
4170 *
4171 * Loop over residues i+1 thru j-1.
4172 *
4173 cgrad          do k=i+1,j-1
4174 cgrad            do l=1,3
4175 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4176 cgrad            enddo
4177 cgrad          enddo
4178 #else
4179 C MARYSIA
4180           facvdw=(ev1+evdwij)*sss
4181           facel=(el1+eesij)
4182           fac1=fac
4183           fac=-3*rrmij*(facvdw+facvdw+facel)
4184           erij(1)=xj*rmij
4185           erij(2)=yj*rmij
4186           erij(3)=zj*rmij
4187 *
4188 * Radial derivatives. First process both termini of the fragment (i,j)
4189 *
4190           ggg(1)=fac*xj
4191 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4192           ggg(2)=fac*yj
4193 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4194           ggg(3)=fac*zj
4195 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4196 c          do k=1,3
4197 c            ghalf=0.5D0*ggg(k)
4198 c            gelc(k,i)=gelc(k,i)+ghalf
4199 c            gelc(k,j)=gelc(k,j)+ghalf
4200 c          enddo
4201 c 9/28/08 AL Gradient compotents will be summed only at the end
4202           do k=1,3
4203             gelc_long(k,j)=gelc(k,j)+ggg(k)
4204             gelc_long(k,i)=gelc(k,i)-ggg(k)
4205           enddo
4206 *
4207 * Loop over residues i+1 thru j-1.
4208 *
4209 cgrad          do k=i+1,j-1
4210 cgrad            do l=1,3
4211 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4212 cgrad            enddo
4213 cgrad          enddo
4214 c 9/28/08 AL Gradient compotents will be summed only at the end
4215           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4216           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4217           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4218           do k=1,3
4219             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4220             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4221           enddo
4222 #endif
4223 *
4224 * Angular part
4225 *
4226           ecosa=2.0D0*fac3*fac1+fac4
4227           fac4=-3.0D0*fac4
4228           fac3=-6.0D0*fac3
4229           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4230           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4231           do k=1,3
4232             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4233             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4234           enddo
4235 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4236 cd   &          (dcosg(k),k=1,3)
4237           do k=1,3
4238             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4239      &      fac_shield(i)**2*fac_shield(j)**2
4240           enddo
4241 c          do k=1,3
4242 c            ghalf=0.5D0*ggg(k)
4243 c            gelc(k,i)=gelc(k,i)+ghalf
4244 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4245 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4246 c            gelc(k,j)=gelc(k,j)+ghalf
4247 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4248 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4249 c          enddo
4250 cgrad          do k=i+1,j-1
4251 cgrad            do l=1,3
4252 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4253 cgrad            enddo
4254 cgrad          enddo
4255 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4256           do k=1,3
4257             gelc(k,i)=gelc(k,i)
4258      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4259      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4260      &           *fac_shield(i)**2*fac_shield(j)**2
4261             gelc(k,j)=gelc(k,j)
4262      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4263      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4264      &           *fac_shield(i)**2*fac_shield(j)**2
4265             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4266             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4267           enddo
4268 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4269
4270 C MARYSIA
4271 c          endif !sscale
4272           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4273      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4274      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4275 C
4276 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4277 C   energy of a peptide unit is assumed in the form of a second-order
4278 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4279 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4280 C   are computed for EVERY pair of non-contiguous peptide groups.
4281 C
4282
4283           if (j.lt.nres-1) then
4284             j1=j+1
4285             j2=j-1
4286           else
4287             j1=j-1
4288             j2=j-2
4289           endif
4290           kkk=0
4291           lll=0
4292           do k=1,2
4293             do l=1,2
4294               kkk=kkk+1
4295               muij(kkk)=mu(k,i)*mu(l,j)
4296 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4297 #ifdef NEWCORR
4298              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4299 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4300              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4301              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4302 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4303              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4304 #endif
4305             enddo
4306           enddo
4307 #ifdef DEBUG
4308           write (iout,*) 'EELEC: i',i,' j',j
4309           write (iout,*) 'j',j,' j1',j1,' j2',j2
4310           write(iout,*) 'muij',muij
4311 #endif
4312           ury=scalar(uy(1,i),erij)
4313           urz=scalar(uz(1,i),erij)
4314           vry=scalar(uy(1,j),erij)
4315           vrz=scalar(uz(1,j),erij)
4316           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4317           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4318           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4319           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4320           fac=dsqrt(-ael6i)*r3ij
4321 #ifdef DEBUG
4322           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4323           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4324      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4325      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4326      &      "uzvz",scalar(uz(1,i),uz(1,j))
4327           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4328           write (iout,*) "fac",fac
4329 #endif
4330           a22=a22*fac
4331           a23=a23*fac
4332           a32=a32*fac
4333           a33=a33*fac
4334 #ifdef DEBUG
4335           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4336 #endif
4337 #undef DEBUG
4338 cd          write (iout,'(4i5,4f10.5)')
4339 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4340 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4341 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4342 cd     &      uy(:,j),uz(:,j)
4343 cd          write (iout,'(4f10.5)')
4344 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4345 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4346 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4347 cd           write (iout,'(9f10.5/)')
4348 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4349 C Derivatives of the elements of A in virtual-bond vectors
4350           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4351           do k=1,3
4352             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4353             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4354             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4355             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4356             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4357             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4358             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4359             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4360             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4361             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4362             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4363             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4364           enddo
4365 C Compute radial contributions to the gradient
4366           facr=-3.0d0*rrmij
4367           a22der=a22*facr
4368           a23der=a23*facr
4369           a32der=a32*facr
4370           a33der=a33*facr
4371           agg(1,1)=a22der*xj
4372           agg(2,1)=a22der*yj
4373           agg(3,1)=a22der*zj
4374           agg(1,2)=a23der*xj
4375           agg(2,2)=a23der*yj
4376           agg(3,2)=a23der*zj
4377           agg(1,3)=a32der*xj
4378           agg(2,3)=a32der*yj
4379           agg(3,3)=a32der*zj
4380           agg(1,4)=a33der*xj
4381           agg(2,4)=a33der*yj
4382           agg(3,4)=a33der*zj
4383 C Add the contributions coming from er
4384           fac3=-3.0d0*fac
4385           do k=1,3
4386             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4387             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4388             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4389             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4390           enddo
4391           do k=1,3
4392 C Derivatives in DC(i)
4393 cgrad            ghalf1=0.5d0*agg(k,1)
4394 cgrad            ghalf2=0.5d0*agg(k,2)
4395 cgrad            ghalf3=0.5d0*agg(k,3)
4396 cgrad            ghalf4=0.5d0*agg(k,4)
4397             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4398      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4399             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4400      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4401             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4402      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4403             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4404      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4405 C Derivatives in DC(i+1)
4406             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4407      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4408             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4409      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4410             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4411      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4412             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4413      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4414 C Derivatives in DC(j)
4415             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4416      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4417             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4418      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4419             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4420      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4421             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4422      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4423 C Derivatives in DC(j+1) or DC(nres-1)
4424             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4425      &      -3.0d0*vryg(k,3)*ury)
4426             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4427      &      -3.0d0*vrzg(k,3)*ury)
4428             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4429      &      -3.0d0*vryg(k,3)*urz)
4430             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4431      &      -3.0d0*vrzg(k,3)*urz)
4432 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4433 cgrad              do l=1,4
4434 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4435 cgrad              enddo
4436 cgrad            endif
4437           enddo
4438           acipa(1,1)=a22
4439           acipa(1,2)=a23
4440           acipa(2,1)=a32
4441           acipa(2,2)=a33
4442           a22=-a22
4443           a23=-a23
4444           do l=1,2
4445             do k=1,3
4446               agg(k,l)=-agg(k,l)
4447               aggi(k,l)=-aggi(k,l)
4448               aggi1(k,l)=-aggi1(k,l)
4449               aggj(k,l)=-aggj(k,l)
4450               aggj1(k,l)=-aggj1(k,l)
4451             enddo
4452           enddo
4453           if (j.lt.nres-1) then
4454             a22=-a22
4455             a32=-a32
4456             do l=1,3,2
4457               do k=1,3
4458                 agg(k,l)=-agg(k,l)
4459                 aggi(k,l)=-aggi(k,l)
4460                 aggi1(k,l)=-aggi1(k,l)
4461                 aggj(k,l)=-aggj(k,l)
4462                 aggj1(k,l)=-aggj1(k,l)
4463               enddo
4464             enddo
4465           else
4466             a22=-a22
4467             a23=-a23
4468             a32=-a32
4469             a33=-a33
4470             do l=1,4
4471               do k=1,3
4472                 agg(k,l)=-agg(k,l)
4473                 aggi(k,l)=-aggi(k,l)
4474                 aggi1(k,l)=-aggi1(k,l)
4475                 aggj(k,l)=-aggj(k,l)
4476                 aggj1(k,l)=-aggj1(k,l)
4477               enddo
4478             enddo
4479           endif
4480           ENDIF ! WCORR
4481           IF (wel_loc.gt.0.0d0) THEN
4482 C Contribution to the local-electrostatic energy coming from the i-j pair
4483           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4484      &     +a33*muij(4)
4485 #ifdef DEBUG
4486           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4487      &     " a33",a33
4488           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4489      &     " wel_loc",wel_loc
4490 #endif
4491           if (shield_mode.eq.0) then
4492            fac_shield(i)=1.0
4493            fac_shield(j)=1.0
4494 C          else
4495 C           fac_shield(i)=0.4
4496 C           fac_shield(j)=0.6
4497           endif
4498           eel_loc_ij=eel_loc_ij
4499      &    *fac_shield(i)*fac_shield(j)
4500 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4501 c     &            'eelloc',i,j,eel_loc_ij
4502 C Now derivative over eel_loc
4503           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4504      &  (shield_mode.gt.0)) then
4505 C          print *,i,j
4506
4507           do ilist=1,ishield_list(i)
4508            iresshield=shield_list(ilist,i)
4509            do k=1,3
4510            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4511      &                                          /fac_shield(i)
4512 C     &      *2.0
4513            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4514      &              rlocshield
4515      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4516             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4517      &      +rlocshield
4518            enddo
4519           enddo
4520           do ilist=1,ishield_list(j)
4521            iresshield=shield_list(ilist,j)
4522            do k=1,3
4523            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4524      &                                       /fac_shield(j)
4525 C     &     *2.0
4526            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4527      &              rlocshield
4528      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4529            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4530      &             +rlocshield
4531
4532            enddo
4533           enddo
4534
4535           do k=1,3
4536             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4537      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4538             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4539      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4540             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4541      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4542             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4543      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4544            enddo
4545            endif
4546
4547
4548 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4549 c     &                     ' eel_loc_ij',eel_loc_ij
4550 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4551 C Calculate patrial derivative for theta angle
4552 #ifdef NEWCORR
4553          geel_loc_ij=(a22*gmuij1(1)
4554      &     +a23*gmuij1(2)
4555      &     +a32*gmuij1(3)
4556      &     +a33*gmuij1(4))
4557      &    *fac_shield(i)*fac_shield(j)
4558 c         write(iout,*) "derivative over thatai"
4559 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4560 c     &   a33*gmuij1(4)
4561          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4562      &      geel_loc_ij*wel_loc
4563 c         write(iout,*) "derivative over thatai-1"
4564 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4565 c     &   a33*gmuij2(4)
4566          geel_loc_ij=
4567      &     a22*gmuij2(1)
4568      &     +a23*gmuij2(2)
4569      &     +a32*gmuij2(3)
4570      &     +a33*gmuij2(4)
4571          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4572      &      geel_loc_ij*wel_loc
4573      &    *fac_shield(i)*fac_shield(j)
4574
4575 c  Derivative over j residue
4576          geel_loc_ji=a22*gmuji1(1)
4577      &     +a23*gmuji1(2)
4578      &     +a32*gmuji1(3)
4579      &     +a33*gmuji1(4)
4580 c         write(iout,*) "derivative over thataj"
4581 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4582 c     &   a33*gmuji1(4)
4583
4584         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4585      &      geel_loc_ji*wel_loc
4586      &    *fac_shield(i)*fac_shield(j)
4587
4588          geel_loc_ji=
4589      &     +a22*gmuji2(1)
4590      &     +a23*gmuji2(2)
4591      &     +a32*gmuji2(3)
4592      &     +a33*gmuji2(4)
4593 c         write(iout,*) "derivative over thataj-1"
4594 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4595 c     &   a33*gmuji2(4)
4596          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4597      &      geel_loc_ji*wel_loc
4598      &    *fac_shield(i)*fac_shield(j)
4599 #endif
4600 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4601
4602           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4603      &            'eelloc',i,j,eel_loc_ij
4604 c           if (eel_loc_ij.ne.0)
4605 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4606 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4607
4608           eel_loc=eel_loc+eel_loc_ij
4609 C Partial derivatives in virtual-bond dihedral angles gamma
4610           if (i.gt.1)
4611      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4612      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4613      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4614      &    *fac_shield(i)*fac_shield(j)
4615
4616           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4617      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4618      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4619      &    *fac_shield(i)*fac_shield(j)
4620 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4621           do l=1,3
4622             ggg(l)=(agg(l,1)*muij(1)+
4623      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4624      &    *fac_shield(i)*fac_shield(j)
4625             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4626             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4627 cgrad            ghalf=0.5d0*ggg(l)
4628 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4629 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4630           enddo
4631 cgrad          do k=i+1,j2
4632 cgrad            do l=1,3
4633 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4634 cgrad            enddo
4635 cgrad          enddo
4636 C Remaining derivatives of eello
4637           do l=1,3
4638             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4639      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4640      &    *fac_shield(i)*fac_shield(j)
4641
4642             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4643      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4644      &    *fac_shield(i)*fac_shield(j)
4645
4646             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4647      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4648      &    *fac_shield(i)*fac_shield(j)
4649
4650             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4651      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4652      &    *fac_shield(i)*fac_shield(j)
4653
4654           enddo
4655           ENDIF
4656 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4657 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4658           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4659      &       .and. num_conti.le.maxconts) then
4660 c            write (iout,*) i,j," entered corr"
4661 C
4662 C Calculate the contact function. The ith column of the array JCONT will
4663 C contain the numbers of atoms that make contacts with the atom I (of numbers
4664 C greater than I). The arrays FACONT and GACONT will contain the values of
4665 C the contact function and its derivative.
4666 c           r0ij=1.02D0*rpp(iteli,itelj)
4667 c           r0ij=1.11D0*rpp(iteli,itelj)
4668             r0ij=2.20D0*rpp(iteli,itelj)
4669 c           r0ij=1.55D0*rpp(iteli,itelj)
4670             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4671             if (fcont.gt.0.0D0) then
4672               num_conti=num_conti+1
4673               if (num_conti.gt.maxconts) then
4674                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4675      &                         ' will skip next contacts for this conf.'
4676               else
4677                 jcont_hb(num_conti,i)=j
4678 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4679 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4680                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4681      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4682 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4683 C  terms.
4684                 d_cont(num_conti,i)=rij
4685 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4686 C     --- Electrostatic-interaction matrix ---
4687                 a_chuj(1,1,num_conti,i)=a22
4688                 a_chuj(1,2,num_conti,i)=a23
4689                 a_chuj(2,1,num_conti,i)=a32
4690                 a_chuj(2,2,num_conti,i)=a33
4691 C     --- Gradient of rij
4692                 do kkk=1,3
4693                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4694                 enddo
4695                 kkll=0
4696                 do k=1,2
4697                   do l=1,2
4698                     kkll=kkll+1
4699                     do m=1,3
4700                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4701                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4702                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4703                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4704                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4705                     enddo
4706                   enddo
4707                 enddo
4708                 ENDIF
4709                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4710 C Calculate contact energies
4711                 cosa4=4.0D0*cosa
4712                 wij=cosa-3.0D0*cosb*cosg
4713                 cosbg1=cosb+cosg
4714                 cosbg2=cosb-cosg
4715 c               fac3=dsqrt(-ael6i)/r0ij**3
4716                 fac3=dsqrt(-ael6i)*r3ij
4717 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4718                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4719                 if (ees0tmp.gt.0) then
4720                   ees0pij=dsqrt(ees0tmp)
4721                 else
4722                   ees0pij=0
4723                 endif
4724 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4725                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4726                 if (ees0tmp.gt.0) then
4727                   ees0mij=dsqrt(ees0tmp)
4728                 else
4729                   ees0mij=0
4730                 endif
4731 c               ees0mij=0.0D0
4732                 if (shield_mode.eq.0) then
4733                 fac_shield(i)=1.0d0
4734                 fac_shield(j)=1.0d0
4735                 else
4736                 ees0plist(num_conti,i)=j
4737 C                fac_shield(i)=0.4d0
4738 C                fac_shield(j)=0.6d0
4739                 endif
4740                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4741      &          *fac_shield(i)*fac_shield(j)
4742                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4743      &          *fac_shield(i)*fac_shield(j)
4744 C Diagnostics. Comment out or remove after debugging!
4745 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4746 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4747 c               ees0m(num_conti,i)=0.0D0
4748 C End diagnostics.
4749 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4750 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4751 C Angular derivatives of the contact function
4752                 ees0pij1=fac3/ees0pij
4753                 ees0mij1=fac3/ees0mij
4754                 fac3p=-3.0D0*fac3*rrmij
4755                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4756                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4757 c               ees0mij1=0.0D0
4758                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4759                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4760                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4761                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4762                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4763                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4764                 ecosap=ecosa1+ecosa2
4765                 ecosbp=ecosb1+ecosb2
4766                 ecosgp=ecosg1+ecosg2
4767                 ecosam=ecosa1-ecosa2
4768                 ecosbm=ecosb1-ecosb2
4769                 ecosgm=ecosg1-ecosg2
4770 C Diagnostics
4771 c               ecosap=ecosa1
4772 c               ecosbp=ecosb1
4773 c               ecosgp=ecosg1
4774 c               ecosam=0.0D0
4775 c               ecosbm=0.0D0
4776 c               ecosgm=0.0D0
4777 C End diagnostics
4778                 facont_hb(num_conti,i)=fcont
4779                 fprimcont=fprimcont/rij
4780 cd              facont_hb(num_conti,i)=1.0D0
4781 C Following line is for diagnostics.
4782 cd              fprimcont=0.0D0
4783                 do k=1,3
4784                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4785                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4786                 enddo
4787                 do k=1,3
4788                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4789                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4790                 enddo
4791                 gggp(1)=gggp(1)+ees0pijp*xj
4792                 gggp(2)=gggp(2)+ees0pijp*yj
4793                 gggp(3)=gggp(3)+ees0pijp*zj
4794                 gggm(1)=gggm(1)+ees0mijp*xj
4795                 gggm(2)=gggm(2)+ees0mijp*yj
4796                 gggm(3)=gggm(3)+ees0mijp*zj
4797 C Derivatives due to the contact function
4798                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4799                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4800                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4801                 do k=1,3
4802 c
4803 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4804 c          following the change of gradient-summation algorithm.
4805 c
4806 cgrad                  ghalfp=0.5D0*gggp(k)
4807 cgrad                  ghalfm=0.5D0*gggm(k)
4808                   gacontp_hb1(k,num_conti,i)=!ghalfp
4809      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4810      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4811      &          *fac_shield(i)*fac_shield(j)
4812
4813                   gacontp_hb2(k,num_conti,i)=!ghalfp
4814      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4815      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4816      &          *fac_shield(i)*fac_shield(j)
4817
4818                   gacontp_hb3(k,num_conti,i)=gggp(k)
4819      &          *fac_shield(i)*fac_shield(j)
4820
4821                   gacontm_hb1(k,num_conti,i)=!ghalfm
4822      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4823      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4824      &          *fac_shield(i)*fac_shield(j)
4825
4826                   gacontm_hb2(k,num_conti,i)=!ghalfm
4827      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4828      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4829      &          *fac_shield(i)*fac_shield(j)
4830
4831                   gacontm_hb3(k,num_conti,i)=gggm(k)
4832      &          *fac_shield(i)*fac_shield(j)
4833
4834                 enddo
4835 C Diagnostics. Comment out or remove after debugging!
4836 cdiag           do k=1,3
4837 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4838 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4839 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4840 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4841 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4842 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4843 cdiag           enddo
4844               ENDIF ! wcorr
4845               endif  ! num_conti.le.maxconts
4846             endif  ! fcont.gt.0
4847           endif    ! j.gt.i+1
4848           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4849             do k=1,4
4850               do l=1,3
4851                 ghalf=0.5d0*agg(l,k)
4852                 aggi(l,k)=aggi(l,k)+ghalf
4853                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4854                 aggj(l,k)=aggj(l,k)+ghalf
4855               enddo
4856             enddo
4857             if (j.eq.nres-1 .and. i.lt.j-2) then
4858               do k=1,4
4859                 do l=1,3
4860                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4861                 enddo
4862               enddo
4863             endif
4864           endif
4865 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4866       return
4867       end
4868 C-----------------------------------------------------------------------------
4869       subroutine eturn3(i,eello_turn3)
4870 C Third- and fourth-order contributions from turns
4871       implicit real*8 (a-h,o-z)
4872       include 'DIMENSIONS'
4873       include 'COMMON.IOUNITS'
4874       include 'COMMON.GEO'
4875       include 'COMMON.VAR'
4876       include 'COMMON.LOCAL'
4877       include 'COMMON.CHAIN'
4878       include 'COMMON.DERIV'
4879       include 'COMMON.INTERACT'
4880       include 'COMMON.CONTACTS'
4881       include 'COMMON.TORSION'
4882       include 'COMMON.VECTORS'
4883       include 'COMMON.FFIELD'
4884       include 'COMMON.CONTROL'
4885       include 'COMMON.SHIELD'
4886       dimension ggg(3)
4887       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4888      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4889      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4890      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4891      &  auxgmat2(2,2),auxgmatt2(2,2)
4892       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4893      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4894       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4895      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4896      &    num_conti,j1,j2
4897       j=i+2
4898 c      write (iout,*) "eturn3",i,j,j1,j2
4899       a_temp(1,1)=a22
4900       a_temp(1,2)=a23
4901       a_temp(2,1)=a32
4902       a_temp(2,2)=a33
4903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4904 C
4905 C               Third-order contributions
4906 C
4907 C                 (i+2)o----(i+3)
4908 C                      | |
4909 C                      | |
4910 C                 (i+1)o----i
4911 C
4912 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4913 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4914         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4915 c auxalary matices for theta gradient
4916 c auxalary matrix for i+1 and constant i+2
4917         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4918 c auxalary matrix for i+2 and constant i+1
4919         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4920         call transpose2(auxmat(1,1),auxmat1(1,1))
4921         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4922         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4923         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4924         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4925         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4926         if (shield_mode.eq.0) then
4927         fac_shield(i)=1.0
4928         fac_shield(j)=1.0
4929 C        else
4930 C        fac_shield(i)=0.4
4931 C        fac_shield(j)=0.6
4932         endif
4933         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4934      &  *fac_shield(i)*fac_shield(j)
4935         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4936      &  *fac_shield(i)*fac_shield(j)
4937         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4938      &    eello_t3
4939 C#ifdef NEWCORR
4940 C Derivatives in theta
4941         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4942      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4943      &   *fac_shield(i)*fac_shield(j)
4944         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4945      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4946      &   *fac_shield(i)*fac_shield(j)
4947 C#endif
4948
4949 C Derivatives in shield mode
4950           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4951      &  (shield_mode.gt.0)) then
4952 C          print *,i,j
4953
4954           do ilist=1,ishield_list(i)
4955            iresshield=shield_list(ilist,i)
4956            do k=1,3
4957            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4958 C     &      *2.0
4959            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4960      &              rlocshield
4961      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4962             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4963      &      +rlocshield
4964            enddo
4965           enddo
4966           do ilist=1,ishield_list(j)
4967            iresshield=shield_list(ilist,j)
4968            do k=1,3
4969            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4970 C     &     *2.0
4971            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4972      &              rlocshield
4973      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4974            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4975      &             +rlocshield
4976
4977            enddo
4978           enddo
4979
4980           do k=1,3
4981             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4982      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4983             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4984      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4985             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4986      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4987             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4988      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4989            enddo
4990            endif
4991
4992 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4993 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4994 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4995 cd     &    ' eello_turn3_num',4*eello_turn3_num
4996 C Derivatives in gamma(i)
4997         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4998         call transpose2(auxmat2(1,1),auxmat3(1,1))
4999         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5000         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5001      &   *fac_shield(i)*fac_shield(j)
5002 C Derivatives in gamma(i+1)
5003         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5004         call transpose2(auxmat2(1,1),auxmat3(1,1))
5005         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5006         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5007      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5008      &   *fac_shield(i)*fac_shield(j)
5009 C Cartesian derivatives
5010         do l=1,3
5011 c            ghalf1=0.5d0*agg(l,1)
5012 c            ghalf2=0.5d0*agg(l,2)
5013 c            ghalf3=0.5d0*agg(l,3)
5014 c            ghalf4=0.5d0*agg(l,4)
5015           a_temp(1,1)=aggi(l,1)!+ghalf1
5016           a_temp(1,2)=aggi(l,2)!+ghalf2
5017           a_temp(2,1)=aggi(l,3)!+ghalf3
5018           a_temp(2,2)=aggi(l,4)!+ghalf4
5019           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5020           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5021      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5022      &   *fac_shield(i)*fac_shield(j)
5023
5024           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5025           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5026           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5027           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5028           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5029           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5030      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5031      &   *fac_shield(i)*fac_shield(j)
5032           a_temp(1,1)=aggj(l,1)!+ghalf1
5033           a_temp(1,2)=aggj(l,2)!+ghalf2
5034           a_temp(2,1)=aggj(l,3)!+ghalf3
5035           a_temp(2,2)=aggj(l,4)!+ghalf4
5036           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5037           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5038      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5039      &   *fac_shield(i)*fac_shield(j)
5040           a_temp(1,1)=aggj1(l,1)
5041           a_temp(1,2)=aggj1(l,2)
5042           a_temp(2,1)=aggj1(l,3)
5043           a_temp(2,2)=aggj1(l,4)
5044           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5045           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5046      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5047      &   *fac_shield(i)*fac_shield(j)
5048         enddo
5049       return
5050       end
5051 C-------------------------------------------------------------------------------
5052       subroutine eturn4(i,eello_turn4)
5053 C Third- and fourth-order contributions from turns
5054       implicit real*8 (a-h,o-z)
5055       include 'DIMENSIONS'
5056       include 'COMMON.IOUNITS'
5057       include 'COMMON.GEO'
5058       include 'COMMON.VAR'
5059       include 'COMMON.LOCAL'
5060       include 'COMMON.CHAIN'
5061       include 'COMMON.DERIV'
5062       include 'COMMON.INTERACT'
5063       include 'COMMON.CONTACTS'
5064       include 'COMMON.TORSION'
5065       include 'COMMON.VECTORS'
5066       include 'COMMON.FFIELD'
5067       include 'COMMON.CONTROL'
5068       include 'COMMON.SHIELD'
5069       dimension ggg(3)
5070       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5071      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5072      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5073      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5074      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5075      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5076      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5077       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5078      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5079       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5080      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5081      &    num_conti,j1,j2
5082       j=i+3
5083 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5084 C
5085 C               Fourth-order contributions
5086 C
5087 C                 (i+3)o----(i+4)
5088 C                     /  |
5089 C               (i+2)o   |
5090 C                     \  |
5091 C                 (i+1)o----i
5092 C
5093 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5094 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5095 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5096 c        write(iout,*)"WCHODZE W PROGRAM"
5097         a_temp(1,1)=a22
5098         a_temp(1,2)=a23
5099         a_temp(2,1)=a32
5100         a_temp(2,2)=a33
5101         iti1=itype2loc(itype(i+1))
5102         iti2=itype2loc(itype(i+2))
5103         iti3=itype2loc(itype(i+3))
5104 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5105         call transpose2(EUg(1,1,i+1),e1t(1,1))
5106         call transpose2(Eug(1,1,i+2),e2t(1,1))
5107         call transpose2(Eug(1,1,i+3),e3t(1,1))
5108 C Ematrix derivative in theta
5109         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5110         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5111         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5112         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5113 c       eta1 in derivative theta
5114         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5115         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5116 c       auxgvec is derivative of Ub2 so i+3 theta
5117         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5118 c       auxalary matrix of E i+1
5119         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5120 c        s1=0.0
5121 c        gs1=0.0
5122         s1=scalar2(b1(1,i+2),auxvec(1))
5123 c derivative of theta i+2 with constant i+3
5124         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5125 c derivative of theta i+2 with constant i+2
5126         gs32=scalar2(b1(1,i+2),auxgvec(1))
5127 c derivative of E matix in theta of i+1
5128         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5129
5130         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5131 c       ea31 in derivative theta
5132         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5133         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5134 c auxilary matrix auxgvec of Ub2 with constant E matirx
5135         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5136 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5137         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5138
5139 c        s2=0.0
5140 c        gs2=0.0
5141         s2=scalar2(b1(1,i+1),auxvec(1))
5142 c derivative of theta i+1 with constant i+3
5143         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5144 c derivative of theta i+2 with constant i+1
5145         gs21=scalar2(b1(1,i+1),auxgvec(1))
5146 c derivative of theta i+3 with constant i+1
5147         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5148 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5149 c     &  gtb1(1,i+1)
5150         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5151 c two derivatives over diffetent matrices
5152 c gtae3e2 is derivative over i+3
5153         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5154 c ae3gte2 is derivative over i+2
5155         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5156         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5157 c three possible derivative over theta E matices
5158 c i+1
5159         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5160 c i+2
5161         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5162 c i+3
5163         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5164         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5165
5166         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5167         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5168         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5169         if (shield_mode.eq.0) then
5170         fac_shield(i)=1.0
5171         fac_shield(j)=1.0
5172 C        else
5173 C        fac_shield(i)=0.6
5174 C        fac_shield(j)=0.4
5175         endif
5176         eello_turn4=eello_turn4-(s1+s2+s3)
5177      &  *fac_shield(i)*fac_shield(j)
5178         eello_t4=-(s1+s2+s3)
5179      &  *fac_shield(i)*fac_shield(j)
5180 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5181         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5182      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5183 C Now derivative over shield:
5184           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5185      &  (shield_mode.gt.0)) then
5186 C          print *,i,j
5187
5188           do ilist=1,ishield_list(i)
5189            iresshield=shield_list(ilist,i)
5190            do k=1,3
5191            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5192 C     &      *2.0
5193            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5194      &              rlocshield
5195      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5196             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5197      &      +rlocshield
5198            enddo
5199           enddo
5200           do ilist=1,ishield_list(j)
5201            iresshield=shield_list(ilist,j)
5202            do k=1,3
5203            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5204 C     &     *2.0
5205            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5206      &              rlocshield
5207      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5208            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5209      &             +rlocshield
5210
5211            enddo
5212           enddo
5213
5214           do k=1,3
5215             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5216      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5217             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5218      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5219             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5220      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5221             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5222      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5223            enddo
5224            endif
5225
5226
5227
5228
5229
5230
5231 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5232 cd     &    ' eello_turn4_num',8*eello_turn4_num
5233 #ifdef NEWCORR
5234         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5235      &                  -(gs13+gsE13+gsEE1)*wturn4
5236      &  *fac_shield(i)*fac_shield(j)
5237         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5238      &                    -(gs23+gs21+gsEE2)*wturn4
5239      &  *fac_shield(i)*fac_shield(j)
5240
5241         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5242      &                    -(gs32+gsE31+gsEE3)*wturn4
5243      &  *fac_shield(i)*fac_shield(j)
5244
5245 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5246 c     &   gs2
5247 #endif
5248         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5249      &      'eturn4',i,j,-(s1+s2+s3)
5250 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5251 c     &    ' eello_turn4_num',8*eello_turn4_num
5252 C Derivatives in gamma(i)
5253         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5254         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5255         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5256         s1=scalar2(b1(1,i+2),auxvec(1))
5257         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5258         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5259         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5260      &  *fac_shield(i)*fac_shield(j)
5261 C Derivatives in gamma(i+1)
5262         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5263         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5264         s2=scalar2(b1(1,i+1),auxvec(1))
5265         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5266         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5267         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5268         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5269      &  *fac_shield(i)*fac_shield(j)
5270 C Derivatives in gamma(i+2)
5271         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5272         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5273         s1=scalar2(b1(1,i+2),auxvec(1))
5274         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5275         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5276         s2=scalar2(b1(1,i+1),auxvec(1))
5277         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5278         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5279         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5280         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5281      &  *fac_shield(i)*fac_shield(j)
5282 C Cartesian derivatives
5283 C Derivatives of this turn contributions in DC(i+2)
5284         if (j.lt.nres-1) then
5285           do l=1,3
5286             a_temp(1,1)=agg(l,1)
5287             a_temp(1,2)=agg(l,2)
5288             a_temp(2,1)=agg(l,3)
5289             a_temp(2,2)=agg(l,4)
5290             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5291             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5292             s1=scalar2(b1(1,i+2),auxvec(1))
5293             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5294             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5295             s2=scalar2(b1(1,i+1),auxvec(1))
5296             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5297             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5298             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5299             ggg(l)=-(s1+s2+s3)
5300             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5301      &  *fac_shield(i)*fac_shield(j)
5302           enddo
5303         endif
5304 C Remaining derivatives of this turn contribution
5305         do l=1,3
5306           a_temp(1,1)=aggi(l,1)
5307           a_temp(1,2)=aggi(l,2)
5308           a_temp(2,1)=aggi(l,3)
5309           a_temp(2,2)=aggi(l,4)
5310           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5311           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5312           s1=scalar2(b1(1,i+2),auxvec(1))
5313           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5314           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5315           s2=scalar2(b1(1,i+1),auxvec(1))
5316           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5317           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5318           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5319           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5320      &  *fac_shield(i)*fac_shield(j)
5321           a_temp(1,1)=aggi1(l,1)
5322           a_temp(1,2)=aggi1(l,2)
5323           a_temp(2,1)=aggi1(l,3)
5324           a_temp(2,2)=aggi1(l,4)
5325           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5326           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5327           s1=scalar2(b1(1,i+2),auxvec(1))
5328           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5329           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5330           s2=scalar2(b1(1,i+1),auxvec(1))
5331           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5332           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5333           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5334           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5335      &  *fac_shield(i)*fac_shield(j)
5336           a_temp(1,1)=aggj(l,1)
5337           a_temp(1,2)=aggj(l,2)
5338           a_temp(2,1)=aggj(l,3)
5339           a_temp(2,2)=aggj(l,4)
5340           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5341           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5342           s1=scalar2(b1(1,i+2),auxvec(1))
5343           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5344           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5345           s2=scalar2(b1(1,i+1),auxvec(1))
5346           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5347           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5348           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5349           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5350      &  *fac_shield(i)*fac_shield(j)
5351           a_temp(1,1)=aggj1(l,1)
5352           a_temp(1,2)=aggj1(l,2)
5353           a_temp(2,1)=aggj1(l,3)
5354           a_temp(2,2)=aggj1(l,4)
5355           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5356           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5357           s1=scalar2(b1(1,i+2),auxvec(1))
5358           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5359           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5360           s2=scalar2(b1(1,i+1),auxvec(1))
5361           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5362           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5363           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5364 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5365           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5366      &  *fac_shield(i)*fac_shield(j)
5367         enddo
5368       return
5369       end
5370 C-----------------------------------------------------------------------------
5371       subroutine vecpr(u,v,w)
5372       implicit real*8(a-h,o-z)
5373       dimension u(3),v(3),w(3)
5374       w(1)=u(2)*v(3)-u(3)*v(2)
5375       w(2)=-u(1)*v(3)+u(3)*v(1)
5376       w(3)=u(1)*v(2)-u(2)*v(1)
5377       return
5378       end
5379 C-----------------------------------------------------------------------------
5380       subroutine unormderiv(u,ugrad,unorm,ungrad)
5381 C This subroutine computes the derivatives of a normalized vector u, given
5382 C the derivatives computed without normalization conditions, ugrad. Returns
5383 C ungrad.
5384       implicit none
5385       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5386       double precision vec(3)
5387       double precision scalar
5388       integer i,j
5389 c      write (2,*) 'ugrad',ugrad
5390 c      write (2,*) 'u',u
5391       do i=1,3
5392         vec(i)=scalar(ugrad(1,i),u(1))
5393       enddo
5394 c      write (2,*) 'vec',vec
5395       do i=1,3
5396         do j=1,3
5397           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5398         enddo
5399       enddo
5400 c      write (2,*) 'ungrad',ungrad
5401       return
5402       end
5403 C-----------------------------------------------------------------------------
5404       subroutine escp_soft_sphere(evdw2,evdw2_14)
5405 C
5406 C This subroutine calculates the excluded-volume interaction energy between
5407 C peptide-group centers and side chains and its gradient in virtual-bond and
5408 C side-chain vectors.
5409 C
5410       implicit real*8 (a-h,o-z)
5411       include 'DIMENSIONS'
5412       include 'COMMON.GEO'
5413       include 'COMMON.VAR'
5414       include 'COMMON.LOCAL'
5415       include 'COMMON.CHAIN'
5416       include 'COMMON.DERIV'
5417       include 'COMMON.INTERACT'
5418       include 'COMMON.FFIELD'
5419       include 'COMMON.IOUNITS'
5420       include 'COMMON.CONTROL'
5421       dimension ggg(3)
5422       integer xshift,yshift,zshift
5423       evdw2=0.0D0
5424       evdw2_14=0.0d0
5425       r0_scp=4.5d0
5426 cd    print '(a)','Enter ESCP'
5427 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5428 C      do xshift=-1,1
5429 C      do yshift=-1,1
5430 C      do zshift=-1,1
5431       do i=iatscp_s,iatscp_e
5432         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5433         iteli=itel(i)
5434         xi=0.5D0*(c(1,i)+c(1,i+1))
5435         yi=0.5D0*(c(2,i)+c(2,i+1))
5436         zi=0.5D0*(c(3,i)+c(3,i+1))
5437 C Return atom into box, boxxsize is size of box in x dimension
5438 c  134   continue
5439 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5440 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5441 C Condition for being inside the proper box
5442 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5443 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5444 c        go to 134
5445 c        endif
5446 c  135   continue
5447 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5448 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5449 C Condition for being inside the proper box
5450 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5451 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5452 c        go to 135
5453 c c       endif
5454 c  136   continue
5455 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5456 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5457 cC Condition for being inside the proper box
5458 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5459 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5460 c        go to 136
5461 c        endif
5462           xi=mod(xi,boxxsize)
5463           if (xi.lt.0) xi=xi+boxxsize
5464           yi=mod(yi,boxysize)
5465           if (yi.lt.0) yi=yi+boxysize
5466           zi=mod(zi,boxzsize)
5467           if (zi.lt.0) zi=zi+boxzsize
5468 C          xi=xi+xshift*boxxsize
5469 C          yi=yi+yshift*boxysize
5470 C          zi=zi+zshift*boxzsize
5471         do iint=1,nscp_gr(i)
5472
5473         do j=iscpstart(i,iint),iscpend(i,iint)
5474           if (itype(j).eq.ntyp1) cycle
5475           itypj=iabs(itype(j))
5476 C Uncomment following three lines for SC-p interactions
5477 c         xj=c(1,nres+j)-xi
5478 c         yj=c(2,nres+j)-yi
5479 c         zj=c(3,nres+j)-zi
5480 C Uncomment following three lines for Ca-p interactions
5481           xj=c(1,j)
5482           yj=c(2,j)
5483           zj=c(3,j)
5484 c  174   continue
5485 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5486 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5487 C Condition for being inside the proper box
5488 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5489 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5490 c        go to 174
5491 c        endif
5492 c  175   continue
5493 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5494 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5495 cC Condition for being inside the proper box
5496 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5497 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5498 c        go to 175
5499 c        endif
5500 c  176   continue
5501 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5502 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5503 C Condition for being inside the proper box
5504 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5505 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5506 c        go to 176
5507           xj=mod(xj,boxxsize)
5508           if (xj.lt.0) xj=xj+boxxsize
5509           yj=mod(yj,boxysize)
5510           if (yj.lt.0) yj=yj+boxysize
5511           zj=mod(zj,boxzsize)
5512           if (zj.lt.0) zj=zj+boxzsize
5513       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5514       xj_safe=xj
5515       yj_safe=yj
5516       zj_safe=zj
5517       subchap=0
5518       do xshift=-1,1
5519       do yshift=-1,1
5520       do zshift=-1,1
5521           xj=xj_safe+xshift*boxxsize
5522           yj=yj_safe+yshift*boxysize
5523           zj=zj_safe+zshift*boxzsize
5524           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5525           if(dist_temp.lt.dist_init) then
5526             dist_init=dist_temp
5527             xj_temp=xj
5528             yj_temp=yj
5529             zj_temp=zj
5530             subchap=1
5531           endif
5532        enddo
5533        enddo
5534        enddo
5535        if (subchap.eq.1) then
5536           xj=xj_temp-xi
5537           yj=yj_temp-yi
5538           zj=zj_temp-zi
5539        else
5540           xj=xj_safe-xi
5541           yj=yj_safe-yi
5542           zj=zj_safe-zi
5543        endif
5544 c c       endif
5545 C          xj=xj-xi
5546 C          yj=yj-yi
5547 C          zj=zj-zi
5548           rij=xj*xj+yj*yj+zj*zj
5549
5550           r0ij=r0_scp
5551           r0ijsq=r0ij*r0ij
5552           if (rij.lt.r0ijsq) then
5553             evdwij=0.25d0*(rij-r0ijsq)**2
5554             fac=rij-r0ijsq
5555           else
5556             evdwij=0.0d0
5557             fac=0.0d0
5558           endif
5559           evdw2=evdw2+evdwij
5560 C
5561 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5562 C
5563           ggg(1)=xj*fac
5564           ggg(2)=yj*fac
5565           ggg(3)=zj*fac
5566 cgrad          if (j.lt.i) then
5567 cd          write (iout,*) 'j<i'
5568 C Uncomment following three lines for SC-p interactions
5569 c           do k=1,3
5570 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5571 c           enddo
5572 cgrad          else
5573 cd          write (iout,*) 'j>i'
5574 cgrad            do k=1,3
5575 cgrad              ggg(k)=-ggg(k)
5576 C Uncomment following line for SC-p interactions
5577 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5578 cgrad            enddo
5579 cgrad          endif
5580 cgrad          do k=1,3
5581 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5582 cgrad          enddo
5583 cgrad          kstart=min0(i+1,j)
5584 cgrad          kend=max0(i-1,j-1)
5585 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5586 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5587 cgrad          do k=kstart,kend
5588 cgrad            do l=1,3
5589 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5590 cgrad            enddo
5591 cgrad          enddo
5592           do k=1,3
5593             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5594             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5595           enddo
5596         enddo
5597
5598         enddo ! iint
5599       enddo ! i
5600 C      enddo !zshift
5601 C      enddo !yshift
5602 C      enddo !xshift
5603       return
5604       end
5605 C-----------------------------------------------------------------------------
5606       subroutine escp(evdw2,evdw2_14)
5607 C
5608 C This subroutine calculates the excluded-volume interaction energy between
5609 C peptide-group centers and side chains and its gradient in virtual-bond and
5610 C side-chain vectors.
5611 C
5612       implicit real*8 (a-h,o-z)
5613       include 'DIMENSIONS'
5614       include 'COMMON.GEO'
5615       include 'COMMON.VAR'
5616       include 'COMMON.LOCAL'
5617       include 'COMMON.CHAIN'
5618       include 'COMMON.DERIV'
5619       include 'COMMON.INTERACT'
5620       include 'COMMON.FFIELD'
5621       include 'COMMON.IOUNITS'
5622       include 'COMMON.CONTROL'
5623       include 'COMMON.SPLITELE'
5624       integer xshift,yshift,zshift
5625       dimension ggg(3)
5626       evdw2=0.0D0
5627       evdw2_14=0.0d0
5628 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5629 cd    print '(a)','Enter ESCP'
5630 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5631 C      do xshift=-1,1
5632 C      do yshift=-1,1
5633 C      do zshift=-1,1
5634       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5635       do i=iatscp_s,iatscp_e
5636         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5637         iteli=itel(i)
5638         xi=0.5D0*(c(1,i)+c(1,i+1))
5639         yi=0.5D0*(c(2,i)+c(2,i+1))
5640         zi=0.5D0*(c(3,i)+c(3,i+1))
5641           xi=mod(xi,boxxsize)
5642           if (xi.lt.0) xi=xi+boxxsize
5643           yi=mod(yi,boxysize)
5644           if (yi.lt.0) yi=yi+boxysize
5645           zi=mod(zi,boxzsize)
5646           if (zi.lt.0) zi=zi+boxzsize
5647 c          xi=xi+xshift*boxxsize
5648 c          yi=yi+yshift*boxysize
5649 c          zi=zi+zshift*boxzsize
5650 c        print *,xi,yi,zi,'polozenie i'
5651 C Return atom into box, boxxsize is size of box in x dimension
5652 c  134   continue
5653 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5654 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5655 C Condition for being inside the proper box
5656 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5657 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5658 c        go to 134
5659 c        endif
5660 c  135   continue
5661 c          print *,xi,boxxsize,"pierwszy"
5662
5663 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5664 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5665 C Condition for being inside the proper box
5666 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5667 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5668 c        go to 135
5669 c        endif
5670 c  136   continue
5671 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5672 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5673 C Condition for being inside the proper box
5674 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5675 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5676 c        go to 136
5677 c        endif
5678         do iint=1,nscp_gr(i)
5679
5680         do j=iscpstart(i,iint),iscpend(i,iint)
5681           itypj=iabs(itype(j))
5682           if (itypj.eq.ntyp1) cycle
5683 C Uncomment following three lines for SC-p interactions
5684 c         xj=c(1,nres+j)-xi
5685 c         yj=c(2,nres+j)-yi
5686 c         zj=c(3,nres+j)-zi
5687 C Uncomment following three lines for Ca-p interactions
5688           xj=c(1,j)
5689           yj=c(2,j)
5690           zj=c(3,j)
5691           xj=mod(xj,boxxsize)
5692           if (xj.lt.0) xj=xj+boxxsize
5693           yj=mod(yj,boxysize)
5694           if (yj.lt.0) yj=yj+boxysize
5695           zj=mod(zj,boxzsize)
5696           if (zj.lt.0) zj=zj+boxzsize
5697 c  174   continue
5698 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5699 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5700 C Condition for being inside the proper box
5701 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5702 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5703 c        go to 174
5704 c        endif
5705 c  175   continue
5706 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5707 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5708 cC Condition for being inside the proper box
5709 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5710 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5711 c        go to 175
5712 c        endif
5713 c  176   continue
5714 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5715 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5716 C Condition for being inside the proper box
5717 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5718 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5719 c        go to 176
5720 c        endif
5721 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5722       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5723       xj_safe=xj
5724       yj_safe=yj
5725       zj_safe=zj
5726       subchap=0
5727       do xshift=-1,1
5728       do yshift=-1,1
5729       do zshift=-1,1
5730           xj=xj_safe+xshift*boxxsize
5731           yj=yj_safe+yshift*boxysize
5732           zj=zj_safe+zshift*boxzsize
5733           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5734           if(dist_temp.lt.dist_init) then
5735             dist_init=dist_temp
5736             xj_temp=xj
5737             yj_temp=yj
5738             zj_temp=zj
5739             subchap=1
5740           endif
5741        enddo
5742        enddo
5743        enddo
5744        if (subchap.eq.1) then
5745           xj=xj_temp-xi
5746           yj=yj_temp-yi
5747           zj=zj_temp-zi
5748        else
5749           xj=xj_safe-xi
5750           yj=yj_safe-yi
5751           zj=zj_safe-zi
5752        endif
5753 c          print *,xj,yj,zj,'polozenie j'
5754           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5755 c          print *,rrij
5756           sss=sscale(1.0d0/(dsqrt(rrij)))
5757 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5758 c          if (sss.eq.0) print *,'czasem jest OK'
5759           if (sss.le.0.0d0) cycle
5760           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5761           fac=rrij**expon2
5762           e1=fac*fac*aad(itypj,iteli)
5763           e2=fac*bad(itypj,iteli)
5764           if (iabs(j-i) .le. 2) then
5765             e1=scal14*e1
5766             e2=scal14*e2
5767             evdw2_14=evdw2_14+(e1+e2)*sss
5768           endif
5769           evdwij=e1+e2
5770           evdw2=evdw2+evdwij*sss
5771           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5772      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5773      &       bad(itypj,iteli)
5774 C
5775 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5776 C
5777           fac=-(evdwij+e1)*rrij*sss
5778           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5779           ggg(1)=xj*fac
5780           ggg(2)=yj*fac
5781           ggg(3)=zj*fac
5782 cgrad          if (j.lt.i) then
5783 cd          write (iout,*) 'j<i'
5784 C Uncomment following three lines for SC-p interactions
5785 c           do k=1,3
5786 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5787 c           enddo
5788 cgrad          else
5789 cd          write (iout,*) 'j>i'
5790 cgrad            do k=1,3
5791 cgrad              ggg(k)=-ggg(k)
5792 C Uncomment following line for SC-p interactions
5793 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5794 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5795 cgrad            enddo
5796 cgrad          endif
5797 cgrad          do k=1,3
5798 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5799 cgrad          enddo
5800 cgrad          kstart=min0(i+1,j)
5801 cgrad          kend=max0(i-1,j-1)
5802 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5803 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5804 cgrad          do k=kstart,kend
5805 cgrad            do l=1,3
5806 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5807 cgrad            enddo
5808 cgrad          enddo
5809           do k=1,3
5810             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5811             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5812           enddo
5813 c        endif !endif for sscale cutoff
5814         enddo ! j
5815
5816         enddo ! iint
5817       enddo ! i
5818 c      enddo !zshift
5819 c      enddo !yshift
5820 c      enddo !xshift
5821       do i=1,nct
5822         do j=1,3
5823           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5824           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5825           gradx_scp(j,i)=expon*gradx_scp(j,i)
5826         enddo
5827       enddo
5828 C******************************************************************************
5829 C
5830 C                              N O T E !!!
5831 C
5832 C To save time the factor EXPON has been extracted from ALL components
5833 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5834 C use!
5835 C
5836 C******************************************************************************
5837       return
5838       end
5839 C--------------------------------------------------------------------------
5840       subroutine edis(ehpb)
5841 C
5842 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5843 C
5844       implicit real*8 (a-h,o-z)
5845       include 'DIMENSIONS'
5846       include 'COMMON.SBRIDGE'
5847       include 'COMMON.CHAIN'
5848       include 'COMMON.DERIV'
5849       include 'COMMON.VAR'
5850       include 'COMMON.INTERACT'
5851       include 'COMMON.IOUNITS'
5852       include 'COMMON.CONTROL'
5853       dimension ggg(3),ggg_peak(3,1000)
5854       ehpb=0.0D0
5855       do i=1,3
5856        ggg(i)=0.0d0
5857       enddo
5858 c 8/21/18 AL: added explicit restraints on reference coords
5859 c      write (iout,*) "restr_on_coord",restr_on_coord
5860       if (restr_on_coord) then
5861
5862       do i=nnt,nct
5863         ecoor=0.0d0
5864         if (itype(i).eq.ntyp1) cycle
5865         do j=1,3
5866           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5867           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5868         enddo
5869         if (itype(i).ne.10) then
5870           do j=1,3
5871             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5872             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5873           enddo
5874         endif
5875         if (energy_dec) write (iout,*)
5876      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5877         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5878       enddo
5879
5880       endif
5881 C      write (iout,*) ,"link_end",link_end,constr_dist
5882 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5883 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5884 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5885 c     &  " link_end_peak",link_end_peak
5886       if (link_end.eq.0.and.link_end_peak.eq.0) return
5887       do i=link_start_peak,link_end_peak
5888         ehpb_peak=0.0d0
5889 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5890 c     &   ipeak(1,i),ipeak(2,i)
5891         do ip=ipeak(1,i),ipeak(2,i)
5892           ii=ihpb_peak(ip)
5893           jj=jhpb_peak(ip)
5894           dd=dist(ii,jj)
5895           iip=ip-ipeak(1,i)+1
5896 C iii and jjj point to the residues for which the distance is assigned.
5897 c          if (ii.gt.nres) then
5898 c            iii=ii-nres
5899 c            jjj=jj-nres
5900 c          else
5901 c            iii=ii
5902 c            jjj=jj
5903 c          endif
5904           if (ii.gt.nres) then
5905             iii=ii-nres
5906           else
5907             iii=ii
5908           endif
5909           if (jj.gt.nres) then
5910             jjj=jj-nres
5911           else
5912             jjj=jj
5913           endif
5914           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5915           aux=dexp(-scal_peak*aux)
5916           ehpb_peak=ehpb_peak+aux
5917           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5918      &      forcon_peak(ip))*aux/dd
5919           do j=1,3
5920             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5921           enddo
5922           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5923      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5924      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5925         enddo
5926 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5927         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5928         do ip=ipeak(1,i),ipeak(2,i)
5929           iip=ip-ipeak(1,i)+1
5930           do j=1,3
5931             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5932           enddo
5933           ii=ihpb_peak(ip)
5934           jj=jhpb_peak(ip)
5935 C iii and jjj point to the residues for which the distance is assigned.
5936 c          if (ii.gt.nres) then
5937 c            iii=ii-nres
5938 c            jjj=jj-nres
5939 c          else
5940 c            iii=ii
5941 c            jjj=jj
5942 c          endif
5943           if (ii.gt.nres) then
5944             iii=ii-nres
5945           else
5946             iii=ii
5947           endif
5948           if (jj.gt.nres) then
5949             jjj=jj-nres
5950           else
5951             jjj=jj
5952           endif
5953           if (iii.lt.ii) then
5954             do j=1,3
5955               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5956             enddo
5957           endif
5958           if (jjj.lt.jj) then
5959             do j=1,3
5960               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5961             enddo
5962           endif
5963           do k=1,3
5964             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5965             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5966           enddo
5967         enddo
5968       enddo
5969       do i=link_start,link_end
5970 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5971 C CA-CA distance used in regularization of structure.
5972         ii=ihpb(i)
5973         jj=jhpb(i)
5974 C iii and jjj point to the residues for which the distance is assigned.
5975         if (ii.gt.nres) then
5976           iii=ii-nres
5977         else
5978           iii=ii
5979         endif
5980         if (jj.gt.nres) then
5981           jjj=jj-nres
5982         else
5983           jjj=jj
5984         endif
5985 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5986 c     &    dhpb(i),dhpb1(i),forcon(i)
5987 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5988 C    distance and angle dependent SS bond potential.
5989 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5990 C     & iabs(itype(jjj)).eq.1) then
5991 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5992 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5993         if (.not.dyn_ss .and. i.le.nss) then
5994 C 15/02/13 CC dynamic SSbond - additional check
5995           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5996      &        iabs(itype(jjj)).eq.1) then
5997            call ssbond_ene(iii,jjj,eij)
5998            ehpb=ehpb+2*eij
5999          endif
6000 cd          write (iout,*) "eij",eij
6001 cd   &   ' waga=',waga,' fac=',fac
6002 !        else if (ii.gt.nres .and. jj.gt.nres) then
6003         else
6004 C Calculate the distance between the two points and its difference from the
6005 C target distance.
6006           dd=dist(ii,jj)
6007           if (irestr_type(i).eq.11) then
6008             ehpb=ehpb+fordepth(i)!**4.0d0
6009      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6010             fac=fordepth(i)!**4.0d0
6011      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6012             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6013      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6014      &        ehpb,irestr_type(i)
6015           else if (irestr_type(i).eq.10) then
6016 c AL 6//19/2018 cross-link restraints
6017             xdis = 0.5d0*(dd/forcon(i))**2
6018             expdis = dexp(-xdis)
6019 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6020             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6021 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6022 c     &          " wboltzd",wboltzd
6023             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6024 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6025             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6026      &           *expdis/(aux*forcon(i)**2)
6027             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6028      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6029      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6030           else if (irestr_type(i).eq.2) then
6031 c Quartic restraints
6032             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6033             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6034      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6035      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6036             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6037           else
6038 c Quadratic restraints
6039             rdis=dd-dhpb(i)
6040 C Get the force constant corresponding to this distance.
6041             waga=forcon(i)
6042 C Calculate the contribution to energy.
6043             ehpb=ehpb+0.5d0*waga*rdis*rdis
6044             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6045      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6046      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6047 C
6048 C Evaluate gradient.
6049 C
6050             fac=waga*rdis/dd
6051           endif
6052 c Calculate Cartesian gradient
6053           do j=1,3
6054             ggg(j)=fac*(c(j,jj)-c(j,ii))
6055           enddo
6056 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6057 C If this is a SC-SC distance, we need to calculate the contributions to the
6058 C Cartesian gradient in the SC vectors (ghpbx).
6059           if (iii.lt.ii) then
6060             do j=1,3
6061               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6062             enddo
6063           endif
6064           if (jjj.lt.jj) then
6065             do j=1,3
6066               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6067             enddo
6068           endif
6069           do k=1,3
6070             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6071             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6072           enddo
6073         endif
6074       enddo
6075       return
6076       end
6077 C--------------------------------------------------------------------------
6078       subroutine ssbond_ene(i,j,eij)
6079 C
6080 C Calculate the distance and angle dependent SS-bond potential energy
6081 C using a free-energy function derived based on RHF/6-31G** ab initio
6082 C calculations of diethyl disulfide.
6083 C
6084 C A. Liwo and U. Kozlowska, 11/24/03
6085 C
6086       implicit real*8 (a-h,o-z)
6087       include 'DIMENSIONS'
6088       include 'COMMON.SBRIDGE'
6089       include 'COMMON.CHAIN'
6090       include 'COMMON.DERIV'
6091       include 'COMMON.LOCAL'
6092       include 'COMMON.INTERACT'
6093       include 'COMMON.VAR'
6094       include 'COMMON.IOUNITS'
6095       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6096       itypi=iabs(itype(i))
6097       xi=c(1,nres+i)
6098       yi=c(2,nres+i)
6099       zi=c(3,nres+i)
6100       dxi=dc_norm(1,nres+i)
6101       dyi=dc_norm(2,nres+i)
6102       dzi=dc_norm(3,nres+i)
6103 c      dsci_inv=dsc_inv(itypi)
6104       dsci_inv=vbld_inv(nres+i)
6105       itypj=iabs(itype(j))
6106 c      dscj_inv=dsc_inv(itypj)
6107       dscj_inv=vbld_inv(nres+j)
6108       xj=c(1,nres+j)-xi
6109       yj=c(2,nres+j)-yi
6110       zj=c(3,nres+j)-zi
6111       dxj=dc_norm(1,nres+j)
6112       dyj=dc_norm(2,nres+j)
6113       dzj=dc_norm(3,nres+j)
6114       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6115       rij=dsqrt(rrij)
6116       erij(1)=xj*rij
6117       erij(2)=yj*rij
6118       erij(3)=zj*rij
6119       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6120       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6121       om12=dxi*dxj+dyi*dyj+dzi*dzj
6122       do k=1,3
6123         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6124         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6125       enddo
6126       rij=1.0d0/rij
6127       deltad=rij-d0cm
6128       deltat1=1.0d0-om1
6129       deltat2=1.0d0+om2
6130       deltat12=om2-om1+2.0d0
6131       cosphi=om12-om1*om2
6132       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6133      &  +akct*deltad*deltat12
6134      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6135 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6136 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6137 c     &  " deltat12",deltat12," eij",eij
6138       ed=2*akcm*deltad+akct*deltat12
6139       pom1=akct*deltad
6140       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6141       eom1=-2*akth*deltat1-pom1-om2*pom2
6142       eom2= 2*akth*deltat2+pom1-om1*pom2
6143       eom12=pom2
6144       do k=1,3
6145         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6146         ghpbx(k,i)=ghpbx(k,i)-ggk
6147      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6148      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6149         ghpbx(k,j)=ghpbx(k,j)+ggk
6150      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6151      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6152         ghpbc(k,i)=ghpbc(k,i)-ggk
6153         ghpbc(k,j)=ghpbc(k,j)+ggk
6154       enddo
6155 C
6156 C Calculate the components of the gradient in DC and X
6157 C
6158 cgrad      do k=i,j-1
6159 cgrad        do l=1,3
6160 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6161 cgrad        enddo
6162 cgrad      enddo
6163       return
6164       end
6165 C--------------------------------------------------------------------------
6166       subroutine ebond(estr)
6167 c
6168 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6169 c
6170       implicit real*8 (a-h,o-z)
6171       include 'DIMENSIONS'
6172       include 'COMMON.LOCAL'
6173       include 'COMMON.GEO'
6174       include 'COMMON.INTERACT'
6175       include 'COMMON.DERIV'
6176       include 'COMMON.VAR'
6177       include 'COMMON.CHAIN'
6178       include 'COMMON.IOUNITS'
6179       include 'COMMON.NAMES'
6180       include 'COMMON.FFIELD'
6181       include 'COMMON.CONTROL'
6182       include 'COMMON.SETUP'
6183       double precision u(3),ud(3)
6184       estr=0.0d0
6185       estr1=0.0d0
6186       do i=ibondp_start,ibondp_end
6187 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6188 c      used
6189 #ifdef FIVEDIAG
6190         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6191         diff = vbld(i)-vbldp0
6192 #else
6193         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6194 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6195 c          do j=1,3
6196 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6197 c     &      *dc(j,i-1)/vbld(i)
6198 c          enddo
6199 c          if (energy_dec) write(iout,*)
6200 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6201 c        else
6202 C       Checking if it involves dummy (NH3+ or COO-) group
6203         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6204 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6205           diff = vbld(i)-vbldpDUM
6206           if (energy_dec) write(iout,*) "dum_bond",i,diff
6207         else
6208 C NO    vbldp0 is the equlibrium length of spring for peptide group
6209           diff = vbld(i)-vbldp0
6210         endif
6211 #endif
6212         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6213      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6214         estr=estr+diff*diff
6215         do j=1,3
6216           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6217         enddo
6218 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6219 c        endif
6220       enddo
6221
6222       estr=0.5d0*AKP*estr+estr1
6223 c
6224 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6225 c
6226       do i=ibond_start,ibond_end
6227         iti=iabs(itype(i))
6228         if (iti.ne.10 .and. iti.ne.ntyp1) then
6229           nbi=nbondterm(iti)
6230           if (nbi.eq.1) then
6231             diff=vbld(i+nres)-vbldsc0(1,iti)
6232             if (energy_dec)  write (iout,*)
6233      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6234      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6235             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6236             do j=1,3
6237               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6238             enddo
6239           else
6240             do j=1,nbi
6241               diff=vbld(i+nres)-vbldsc0(j,iti)
6242               ud(j)=aksc(j,iti)*diff
6243               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6244             enddo
6245             uprod=u(1)
6246             do j=2,nbi
6247               uprod=uprod*u(j)
6248             enddo
6249             usum=0.0d0
6250             usumsqder=0.0d0
6251             do j=1,nbi
6252               uprod1=1.0d0
6253               uprod2=1.0d0
6254               do k=1,nbi
6255                 if (k.ne.j) then
6256                   uprod1=uprod1*u(k)
6257                   uprod2=uprod2*u(k)*u(k)
6258                 endif
6259               enddo
6260               usum=usum+uprod1
6261               usumsqder=usumsqder+ud(j)*uprod2
6262             enddo
6263             estr=estr+uprod/usum
6264             do j=1,3
6265              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6266             enddo
6267           endif
6268         endif
6269       enddo
6270       return
6271       end
6272 #ifdef CRYST_THETA
6273 C--------------------------------------------------------------------------
6274       subroutine ebend(etheta)
6275 C
6276 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6277 C angles gamma and its derivatives in consecutive thetas and gammas.
6278 C
6279       implicit real*8 (a-h,o-z)
6280       include 'DIMENSIONS'
6281       include 'COMMON.LOCAL'
6282       include 'COMMON.GEO'
6283       include 'COMMON.INTERACT'
6284       include 'COMMON.DERIV'
6285       include 'COMMON.VAR'
6286       include 'COMMON.CHAIN'
6287       include 'COMMON.IOUNITS'
6288       include 'COMMON.NAMES'
6289       include 'COMMON.FFIELD'
6290       include 'COMMON.CONTROL'
6291       include 'COMMON.TORCNSTR'
6292       common /calcthet/ term1,term2,termm,diffak,ratak,
6293      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6294      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6295       double precision y(2),z(2)
6296       delta=0.02d0*pi
6297 c      time11=dexp(-2*time)
6298 c      time12=1.0d0
6299       etheta=0.0D0
6300 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6301       do i=ithet_start,ithet_end
6302         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6303      &  .or.itype(i).eq.ntyp1) cycle
6304 C Zero the energy function and its derivative at 0 or pi.
6305         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6306         it=itype(i-1)
6307         ichir1=isign(1,itype(i-2))
6308         ichir2=isign(1,itype(i))
6309          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6310          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6311          if (itype(i-1).eq.10) then
6312           itype1=isign(10,itype(i-2))
6313           ichir11=isign(1,itype(i-2))
6314           ichir12=isign(1,itype(i-2))
6315           itype2=isign(10,itype(i))
6316           ichir21=isign(1,itype(i))
6317           ichir22=isign(1,itype(i))
6318          endif
6319
6320         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6321 #ifdef OSF
6322           phii=phi(i)
6323           if (phii.ne.phii) phii=150.0
6324 #else
6325           phii=phi(i)
6326 #endif
6327           y(1)=dcos(phii)
6328           y(2)=dsin(phii)
6329         else
6330           y(1)=0.0D0
6331           y(2)=0.0D0
6332         endif
6333         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6334 #ifdef OSF
6335           phii1=phi(i+1)
6336           if (phii1.ne.phii1) phii1=150.0
6337           phii1=pinorm(phii1)
6338           z(1)=cos(phii1)
6339 #else
6340           phii1=phi(i+1)
6341 #endif
6342           z(1)=dcos(phii1)
6343           z(2)=dsin(phii1)
6344         else
6345           z(1)=0.0D0
6346           z(2)=0.0D0
6347         endif
6348 C Calculate the "mean" value of theta from the part of the distribution
6349 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6350 C In following comments this theta will be referred to as t_c.
6351         thet_pred_mean=0.0d0
6352         do k=1,2
6353             athetk=athet(k,it,ichir1,ichir2)
6354             bthetk=bthet(k,it,ichir1,ichir2)
6355           if (it.eq.10) then
6356              athetk=athet(k,itype1,ichir11,ichir12)
6357              bthetk=bthet(k,itype2,ichir21,ichir22)
6358           endif
6359          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6360 c         write(iout,*) 'chuj tu', y(k),z(k)
6361         enddo
6362         dthett=thet_pred_mean*ssd
6363         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6364 C Derivatives of the "mean" values in gamma1 and gamma2.
6365         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6366      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6367          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6368      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6369          if (it.eq.10) then
6370       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6371      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6372         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6373      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6374          endif
6375         if (theta(i).gt.pi-delta) then
6376           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6377      &         E_tc0)
6378           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6379           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6380           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6381      &        E_theta)
6382           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6383      &        E_tc)
6384         else if (theta(i).lt.delta) then
6385           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6386           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6387           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6388      &        E_theta)
6389           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6390           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6391      &        E_tc)
6392         else
6393           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6394      &        E_theta,E_tc)
6395         endif
6396         etheta=etheta+ethetai
6397         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6398      &      'ebend',i,ethetai,theta(i),itype(i)
6399         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6400         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6401         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6402       enddo
6403
6404 C Ufff.... We've done all this!!!
6405       return
6406       end
6407 C---------------------------------------------------------------------------
6408       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6409      &     E_tc)
6410       implicit real*8 (a-h,o-z)
6411       include 'DIMENSIONS'
6412       include 'COMMON.LOCAL'
6413       include 'COMMON.IOUNITS'
6414       common /calcthet/ term1,term2,termm,diffak,ratak,
6415      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6416      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6417 C Calculate the contributions to both Gaussian lobes.
6418 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6419 C The "polynomial part" of the "standard deviation" of this part of
6420 C the distributioni.
6421 ccc        write (iout,*) thetai,thet_pred_mean
6422         sig=polthet(3,it)
6423         do j=2,0,-1
6424           sig=sig*thet_pred_mean+polthet(j,it)
6425         enddo
6426 C Derivative of the "interior part" of the "standard deviation of the"
6427 C gamma-dependent Gaussian lobe in t_c.
6428         sigtc=3*polthet(3,it)
6429         do j=2,1,-1
6430           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6431         enddo
6432         sigtc=sig*sigtc
6433 C Set the parameters of both Gaussian lobes of the distribution.
6434 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6435         fac=sig*sig+sigc0(it)
6436         sigcsq=fac+fac
6437         sigc=1.0D0/sigcsq
6438 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6439         sigsqtc=-4.0D0*sigcsq*sigtc
6440 c       print *,i,sig,sigtc,sigsqtc
6441 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6442         sigtc=-sigtc/(fac*fac)
6443 C Following variable is sigma(t_c)**(-2)
6444         sigcsq=sigcsq*sigcsq
6445         sig0i=sig0(it)
6446         sig0inv=1.0D0/sig0i**2
6447         delthec=thetai-thet_pred_mean
6448         delthe0=thetai-theta0i
6449         term1=-0.5D0*sigcsq*delthec*delthec
6450         term2=-0.5D0*sig0inv*delthe0*delthe0
6451 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6452 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6453 C NaNs in taking the logarithm. We extract the largest exponent which is added
6454 C to the energy (this being the log of the distribution) at the end of energy
6455 C term evaluation for this virtual-bond angle.
6456         if (term1.gt.term2) then
6457           termm=term1
6458           term2=dexp(term2-termm)
6459           term1=1.0d0
6460         else
6461           termm=term2
6462           term1=dexp(term1-termm)
6463           term2=1.0d0
6464         endif
6465 C The ratio between the gamma-independent and gamma-dependent lobes of
6466 C the distribution is a Gaussian function of thet_pred_mean too.
6467         diffak=gthet(2,it)-thet_pred_mean
6468         ratak=diffak/gthet(3,it)**2
6469         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6470 C Let's differentiate it in thet_pred_mean NOW.
6471         aktc=ak*ratak
6472 C Now put together the distribution terms to make complete distribution.
6473         termexp=term1+ak*term2
6474         termpre=sigc+ak*sig0i
6475 C Contribution of the bending energy from this theta is just the -log of
6476 C the sum of the contributions from the two lobes and the pre-exponential
6477 C factor. Simple enough, isn't it?
6478         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6479 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6480 C NOW the derivatives!!!
6481 C 6/6/97 Take into account the deformation.
6482         E_theta=(delthec*sigcsq*term1
6483      &       +ak*delthe0*sig0inv*term2)/termexp
6484         E_tc=((sigtc+aktc*sig0i)/termpre
6485      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6486      &       aktc*term2)/termexp)
6487       return
6488       end
6489 c-----------------------------------------------------------------------------
6490       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6491       implicit real*8 (a-h,o-z)
6492       include 'DIMENSIONS'
6493       include 'COMMON.LOCAL'
6494       include 'COMMON.IOUNITS'
6495       common /calcthet/ term1,term2,termm,diffak,ratak,
6496      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6497      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6498       delthec=thetai-thet_pred_mean
6499       delthe0=thetai-theta0i
6500 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6501       t3 = thetai-thet_pred_mean
6502       t6 = t3**2
6503       t9 = term1
6504       t12 = t3*sigcsq
6505       t14 = t12+t6*sigsqtc
6506       t16 = 1.0d0
6507       t21 = thetai-theta0i
6508       t23 = t21**2
6509       t26 = term2
6510       t27 = t21*t26
6511       t32 = termexp
6512       t40 = t32**2
6513       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6514      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6515      & *(-t12*t9-ak*sig0inv*t27)
6516       return
6517       end
6518 #else
6519 C--------------------------------------------------------------------------
6520       subroutine ebend(etheta)
6521 C
6522 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6523 C angles gamma and its derivatives in consecutive thetas and gammas.
6524 C ab initio-derived potentials from
6525 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6526 C
6527       implicit real*8 (a-h,o-z)
6528       include 'DIMENSIONS'
6529       include 'COMMON.LOCAL'
6530       include 'COMMON.GEO'
6531       include 'COMMON.INTERACT'
6532       include 'COMMON.DERIV'
6533       include 'COMMON.VAR'
6534       include 'COMMON.CHAIN'
6535       include 'COMMON.IOUNITS'
6536       include 'COMMON.NAMES'
6537       include 'COMMON.FFIELD'
6538       include 'COMMON.CONTROL'
6539       include 'COMMON.TORCNSTR'
6540       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6541      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6542      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6543      & sinph1ph2(maxdouble,maxdouble)
6544       logical lprn /.false./, lprn1 /.false./
6545       etheta=0.0D0
6546       do i=ithet_start,ithet_end
6547 c        print *,i,itype(i-1),itype(i),itype(i-2)
6548         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6549      &  .or.itype(i).eq.ntyp1) cycle
6550 C        print *,i,theta(i)
6551         if (iabs(itype(i+1)).eq.20) iblock=2
6552         if (iabs(itype(i+1)).ne.20) iblock=1
6553         dethetai=0.0d0
6554         dephii=0.0d0
6555         dephii1=0.0d0
6556         theti2=0.5d0*theta(i)
6557         ityp2=ithetyp((itype(i-1)))
6558         do k=1,nntheterm
6559           coskt(k)=dcos(k*theti2)
6560           sinkt(k)=dsin(k*theti2)
6561         enddo
6562 C        print *,ethetai
6563         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6564 #ifdef OSF
6565           phii=phi(i)
6566           if (phii.ne.phii) phii=150.0
6567 #else
6568           phii=phi(i)
6569 #endif
6570           ityp1=ithetyp((itype(i-2)))
6571 C propagation of chirality for glycine type
6572           do k=1,nsingle
6573             cosph1(k)=dcos(k*phii)
6574             sinph1(k)=dsin(k*phii)
6575           enddo
6576         else
6577           phii=0.0d0
6578           do k=1,nsingle
6579           ityp1=ithetyp((itype(i-2)))
6580             cosph1(k)=0.0d0
6581             sinph1(k)=0.0d0
6582           enddo
6583         endif
6584         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6585 #ifdef OSF
6586           phii1=phi(i+1)
6587           if (phii1.ne.phii1) phii1=150.0
6588           phii1=pinorm(phii1)
6589 #else
6590           phii1=phi(i+1)
6591 #endif
6592           ityp3=ithetyp((itype(i)))
6593           do k=1,nsingle
6594             cosph2(k)=dcos(k*phii1)
6595             sinph2(k)=dsin(k*phii1)
6596           enddo
6597         else
6598           phii1=0.0d0
6599           ityp3=ithetyp((itype(i)))
6600           do k=1,nsingle
6601             cosph2(k)=0.0d0
6602             sinph2(k)=0.0d0
6603           enddo
6604         endif
6605         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6606         do k=1,ndouble
6607           do l=1,k-1
6608             ccl=cosph1(l)*cosph2(k-l)
6609             ssl=sinph1(l)*sinph2(k-l)
6610             scl=sinph1(l)*cosph2(k-l)
6611             csl=cosph1(l)*sinph2(k-l)
6612             cosph1ph2(l,k)=ccl-ssl
6613             cosph1ph2(k,l)=ccl+ssl
6614             sinph1ph2(l,k)=scl+csl
6615             sinph1ph2(k,l)=scl-csl
6616           enddo
6617         enddo
6618         if (lprn) then
6619         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6620      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6621         write (iout,*) "coskt and sinkt"
6622         do k=1,nntheterm
6623           write (iout,*) k,coskt(k),sinkt(k)
6624         enddo
6625         endif
6626         do k=1,ntheterm
6627           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6628           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6629      &      *coskt(k)
6630           if (lprn)
6631      &    write (iout,*) "k",k,"
6632      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6633      &     " ethetai",ethetai
6634         enddo
6635         if (lprn) then
6636         write (iout,*) "cosph and sinph"
6637         do k=1,nsingle
6638           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6639         enddo
6640         write (iout,*) "cosph1ph2 and sinph2ph2"
6641         do k=2,ndouble
6642           do l=1,k-1
6643             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6644      &         sinph1ph2(l,k),sinph1ph2(k,l)
6645           enddo
6646         enddo
6647         write(iout,*) "ethetai",ethetai
6648         endif
6649 C       print *,ethetai
6650         do m=1,ntheterm2
6651           do k=1,nsingle
6652             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6653      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6654      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6655      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6656             ethetai=ethetai+sinkt(m)*aux
6657             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6658             dephii=dephii+k*sinkt(m)*(
6659      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6660      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6661             dephii1=dephii1+k*sinkt(m)*(
6662      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6663      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6664             if (lprn)
6665      &      write (iout,*) "m",m," k",k," bbthet",
6666      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6667      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6668      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6669      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6670 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6671           enddo
6672         enddo
6673 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6674 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6675 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6676 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6677         if (lprn)
6678      &  write(iout,*) "ethetai",ethetai
6679 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6680         do m=1,ntheterm3
6681           do k=2,ndouble
6682             do l=1,k-1
6683               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6684      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6685      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6686      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6687               ethetai=ethetai+sinkt(m)*aux
6688               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6689               dephii=dephii+l*sinkt(m)*(
6690      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6691      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6692      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6693      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6694               dephii1=dephii1+(k-l)*sinkt(m)*(
6695      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6696      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6697      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6698      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6699               if (lprn) then
6700               write (iout,*) "m",m," k",k," l",l," ffthet",
6701      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6702      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6703      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6704      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6705      &            " ethetai",ethetai
6706               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6707      &            cosph1ph2(k,l)*sinkt(m),
6708      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6709               endif
6710             enddo
6711           enddo
6712         enddo
6713 10      continue
6714 c        lprn1=.true.
6715 C        print *,ethetai
6716         if (lprn1)
6717      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6718      &   i,theta(i)*rad2deg,phii*rad2deg,
6719      &   phii1*rad2deg,ethetai
6720 c        lprn1=.false.
6721         etheta=etheta+ethetai
6722         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6723         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6724         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6725       enddo
6726
6727       return
6728       end
6729 #endif
6730 #ifdef CRYST_SC
6731 c-----------------------------------------------------------------------------
6732       subroutine esc(escloc)
6733 C Calculate the local energy of a side chain and its derivatives in the
6734 C corresponding virtual-bond valence angles THETA and the spherical angles
6735 C ALPHA and OMEGA.
6736       implicit real*8 (a-h,o-z)
6737       include 'DIMENSIONS'
6738       include 'COMMON.GEO'
6739       include 'COMMON.LOCAL'
6740       include 'COMMON.VAR'
6741       include 'COMMON.INTERACT'
6742       include 'COMMON.DERIV'
6743       include 'COMMON.CHAIN'
6744       include 'COMMON.IOUNITS'
6745       include 'COMMON.NAMES'
6746       include 'COMMON.FFIELD'
6747       include 'COMMON.CONTROL'
6748       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6749      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6750       common /sccalc/ time11,time12,time112,theti,it,nlobit
6751       delta=0.02d0*pi
6752       escloc=0.0D0
6753 c     write (iout,'(a)') 'ESC'
6754       do i=loc_start,loc_end
6755         it=itype(i)
6756         if (it.eq.ntyp1) cycle
6757         if (it.eq.10) goto 1
6758         nlobit=nlob(iabs(it))
6759 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6760 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6761         theti=theta(i+1)-pipol
6762         x(1)=dtan(theti)
6763         x(2)=alph(i)
6764         x(3)=omeg(i)
6765
6766         if (x(2).gt.pi-delta) then
6767           xtemp(1)=x(1)
6768           xtemp(2)=pi-delta
6769           xtemp(3)=x(3)
6770           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6771           xtemp(2)=pi
6772           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6773           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6774      &        escloci,dersc(2))
6775           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6776      &        ddersc0(1),dersc(1))
6777           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6778      &        ddersc0(3),dersc(3))
6779           xtemp(2)=pi-delta
6780           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6781           xtemp(2)=pi
6782           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6783           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6784      &            dersc0(2),esclocbi,dersc02)
6785           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6786      &            dersc12,dersc01)
6787           call splinthet(x(2),0.5d0*delta,ss,ssd)
6788           dersc0(1)=dersc01
6789           dersc0(2)=dersc02
6790           dersc0(3)=0.0d0
6791           do k=1,3
6792             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6793           enddo
6794           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6795 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6796 c    &             esclocbi,ss,ssd
6797           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6798 c         escloci=esclocbi
6799 c         write (iout,*) escloci
6800         else if (x(2).lt.delta) then
6801           xtemp(1)=x(1)
6802           xtemp(2)=delta
6803           xtemp(3)=x(3)
6804           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6805           xtemp(2)=0.0d0
6806           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6807           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6808      &        escloci,dersc(2))
6809           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6810      &        ddersc0(1),dersc(1))
6811           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6812      &        ddersc0(3),dersc(3))
6813           xtemp(2)=delta
6814           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6815           xtemp(2)=0.0d0
6816           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6817           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6818      &            dersc0(2),esclocbi,dersc02)
6819           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6820      &            dersc12,dersc01)
6821           dersc0(1)=dersc01
6822           dersc0(2)=dersc02
6823           dersc0(3)=0.0d0
6824           call splinthet(x(2),0.5d0*delta,ss,ssd)
6825           do k=1,3
6826             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6827           enddo
6828           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6829 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6830 c    &             esclocbi,ss,ssd
6831           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6832 c         write (iout,*) escloci
6833         else
6834           call enesc(x,escloci,dersc,ddummy,.false.)
6835         endif
6836
6837         escloc=escloc+escloci
6838         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6839      &     'escloc',i,escloci
6840 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6841
6842         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6843      &   wscloc*dersc(1)
6844         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6845         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6846     1   continue
6847       enddo
6848       return
6849       end
6850 C---------------------------------------------------------------------------
6851       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6852       implicit real*8 (a-h,o-z)
6853       include 'DIMENSIONS'
6854       include 'COMMON.GEO'
6855       include 'COMMON.LOCAL'
6856       include 'COMMON.IOUNITS'
6857       common /sccalc/ time11,time12,time112,theti,it,nlobit
6858       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6859       double precision contr(maxlob,-1:1)
6860       logical mixed
6861 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6862         escloc_i=0.0D0
6863         do j=1,3
6864           dersc(j)=0.0D0
6865           if (mixed) ddersc(j)=0.0d0
6866         enddo
6867         x3=x(3)
6868
6869 C Because of periodicity of the dependence of the SC energy in omega we have
6870 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6871 C To avoid underflows, first compute & store the exponents.
6872
6873         do iii=-1,1
6874
6875           x(3)=x3+iii*dwapi
6876
6877           do j=1,nlobit
6878             do k=1,3
6879               z(k)=x(k)-censc(k,j,it)
6880             enddo
6881             do k=1,3
6882               Axk=0.0D0
6883               do l=1,3
6884                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6885               enddo
6886               Ax(k,j,iii)=Axk
6887             enddo
6888             expfac=0.0D0
6889             do k=1,3
6890               expfac=expfac+Ax(k,j,iii)*z(k)
6891             enddo
6892             contr(j,iii)=expfac
6893           enddo ! j
6894
6895         enddo ! iii
6896
6897         x(3)=x3
6898 C As in the case of ebend, we want to avoid underflows in exponentiation and
6899 C subsequent NaNs and INFs in energy calculation.
6900 C Find the largest exponent
6901         emin=contr(1,-1)
6902         do iii=-1,1
6903           do j=1,nlobit
6904             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6905           enddo
6906         enddo
6907         emin=0.5D0*emin
6908 cd      print *,'it=',it,' emin=',emin
6909
6910 C Compute the contribution to SC energy and derivatives
6911         do iii=-1,1
6912
6913           do j=1,nlobit
6914 #ifdef OSF
6915             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6916             if(adexp.ne.adexp) adexp=1.0
6917             expfac=dexp(adexp)
6918 #else
6919             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6920 #endif
6921 cd          print *,'j=',j,' expfac=',expfac
6922             escloc_i=escloc_i+expfac
6923             do k=1,3
6924               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6925             enddo
6926             if (mixed) then
6927               do k=1,3,2
6928                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6929      &            +gaussc(k,2,j,it))*expfac
6930               enddo
6931             endif
6932           enddo
6933
6934         enddo ! iii
6935
6936         dersc(1)=dersc(1)/cos(theti)**2
6937         ddersc(1)=ddersc(1)/cos(theti)**2
6938         ddersc(3)=ddersc(3)
6939
6940         escloci=-(dlog(escloc_i)-emin)
6941         do j=1,3
6942           dersc(j)=dersc(j)/escloc_i
6943         enddo
6944         if (mixed) then
6945           do j=1,3,2
6946             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6947           enddo
6948         endif
6949       return
6950       end
6951 C------------------------------------------------------------------------------
6952       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6953       implicit real*8 (a-h,o-z)
6954       include 'DIMENSIONS'
6955       include 'COMMON.GEO'
6956       include 'COMMON.LOCAL'
6957       include 'COMMON.IOUNITS'
6958       common /sccalc/ time11,time12,time112,theti,it,nlobit
6959       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6960       double precision contr(maxlob)
6961       logical mixed
6962
6963       escloc_i=0.0D0
6964
6965       do j=1,3
6966         dersc(j)=0.0D0
6967       enddo
6968
6969       do j=1,nlobit
6970         do k=1,2
6971           z(k)=x(k)-censc(k,j,it)
6972         enddo
6973         z(3)=dwapi
6974         do k=1,3
6975           Axk=0.0D0
6976           do l=1,3
6977             Axk=Axk+gaussc(l,k,j,it)*z(l)
6978           enddo
6979           Ax(k,j)=Axk
6980         enddo
6981         expfac=0.0D0
6982         do k=1,3
6983           expfac=expfac+Ax(k,j)*z(k)
6984         enddo
6985         contr(j)=expfac
6986       enddo ! j
6987
6988 C As in the case of ebend, we want to avoid underflows in exponentiation and
6989 C subsequent NaNs and INFs in energy calculation.
6990 C Find the largest exponent
6991       emin=contr(1)
6992       do j=1,nlobit
6993         if (emin.gt.contr(j)) emin=contr(j)
6994       enddo
6995       emin=0.5D0*emin
6996
6997 C Compute the contribution to SC energy and derivatives
6998
6999       dersc12=0.0d0
7000       do j=1,nlobit
7001         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7002         escloc_i=escloc_i+expfac
7003         do k=1,2
7004           dersc(k)=dersc(k)+Ax(k,j)*expfac
7005         enddo
7006         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7007      &            +gaussc(1,2,j,it))*expfac
7008         dersc(3)=0.0d0
7009       enddo
7010
7011       dersc(1)=dersc(1)/cos(theti)**2
7012       dersc12=dersc12/cos(theti)**2
7013       escloci=-(dlog(escloc_i)-emin)
7014       do j=1,2
7015         dersc(j)=dersc(j)/escloc_i
7016       enddo
7017       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7018       return
7019       end
7020 #else
7021 c----------------------------------------------------------------------------------
7022       subroutine esc(escloc)
7023 C Calculate the local energy of a side chain and its derivatives in the
7024 C corresponding virtual-bond valence angles THETA and the spherical angles
7025 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7026 C added by Urszula Kozlowska. 07/11/2007
7027 C
7028       implicit real*8 (a-h,o-z)
7029       include 'DIMENSIONS'
7030       include 'COMMON.GEO'
7031       include 'COMMON.LOCAL'
7032       include 'COMMON.VAR'
7033       include 'COMMON.SCROT'
7034       include 'COMMON.INTERACT'
7035       include 'COMMON.DERIV'
7036       include 'COMMON.CHAIN'
7037       include 'COMMON.IOUNITS'
7038       include 'COMMON.NAMES'
7039       include 'COMMON.FFIELD'
7040       include 'COMMON.CONTROL'
7041       include 'COMMON.VECTORS'
7042       double precision x_prime(3),y_prime(3),z_prime(3)
7043      &    , sumene,dsc_i,dp2_i,x(65),
7044      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7045      &    de_dxx,de_dyy,de_dzz,de_dt
7046       double precision s1_t,s1_6_t,s2_t,s2_6_t
7047       double precision
7048      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7049      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7050      & dt_dCi(3),dt_dCi1(3)
7051       common /sccalc/ time11,time12,time112,theti,it,nlobit
7052       delta=0.02d0*pi
7053       escloc=0.0D0
7054       do i=loc_start,loc_end
7055         if (itype(i).eq.ntyp1) cycle
7056         costtab(i+1) =dcos(theta(i+1))
7057         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7058         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7059         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7060         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7061         cosfac=dsqrt(cosfac2)
7062         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7063         sinfac=dsqrt(sinfac2)
7064         it=iabs(itype(i))
7065         if (it.eq.10) goto 1
7066 c
7067 C  Compute the axes of tghe local cartesian coordinates system; store in
7068 c   x_prime, y_prime and z_prime
7069 c
7070         do j=1,3
7071           x_prime(j) = 0.00
7072           y_prime(j) = 0.00
7073           z_prime(j) = 0.00
7074         enddo
7075 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7076 C     &   dc_norm(3,i+nres)
7077         do j = 1,3
7078           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7079           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7080         enddo
7081         do j = 1,3
7082           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7083         enddo
7084 c       write (2,*) "i",i
7085 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7086 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7087 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7088 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7089 c      & " xy",scalar(x_prime(1),y_prime(1)),
7090 c      & " xz",scalar(x_prime(1),z_prime(1)),
7091 c      & " yy",scalar(y_prime(1),y_prime(1)),
7092 c      & " yz",scalar(y_prime(1),z_prime(1)),
7093 c      & " zz",scalar(z_prime(1),z_prime(1))
7094 c
7095 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7096 C to local coordinate system. Store in xx, yy, zz.
7097 c
7098         xx=0.0d0
7099         yy=0.0d0
7100         zz=0.0d0
7101         do j = 1,3
7102           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7103           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7104           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7105         enddo
7106
7107         xxtab(i)=xx
7108         yytab(i)=yy
7109         zztab(i)=zz
7110 C
7111 C Compute the energy of the ith side cbain
7112 C
7113 c        write (2,*) "xx",xx," yy",yy," zz",zz
7114         it=iabs(itype(i))
7115         do j = 1,65
7116           x(j) = sc_parmin(j,it)
7117         enddo
7118 #ifdef CHECK_COORD
7119 Cc diagnostics - remove later
7120         xx1 = dcos(alph(2))
7121         yy1 = dsin(alph(2))*dcos(omeg(2))
7122         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7123         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7124      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7125      &    xx1,yy1,zz1
7126 C,"  --- ", xx_w,yy_w,zz_w
7127 c end diagnostics
7128 #endif
7129         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7130      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7131      &   + x(10)*yy*zz
7132         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7133      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7134      & + x(20)*yy*zz
7135         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7136      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7137      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7138      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7139      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7140      &  +x(40)*xx*yy*zz
7141         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7142      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7143      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7144      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7145      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7146      &  +x(60)*xx*yy*zz
7147         dsc_i   = 0.743d0+x(61)
7148         dp2_i   = 1.9d0+x(62)
7149         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7150      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7151         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7152      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7153         s1=(1+x(63))/(0.1d0 + dscp1)
7154         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7155         s2=(1+x(65))/(0.1d0 + dscp2)
7156         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7157         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7158      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7159 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7160 c     &   sumene4,
7161 c     &   dscp1,dscp2,sumene
7162 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7163         escloc = escloc + sumene
7164 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7165 c     & ,zz,xx,yy
7166 c#define DEBUG
7167 #ifdef DEBUG
7168 C
7169 C This section to check the numerical derivatives of the energy of ith side
7170 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7171 C #define DEBUG in the code to turn it on.
7172 C
7173         write (2,*) "sumene               =",sumene
7174         aincr=1.0d-7
7175         xxsave=xx
7176         xx=xx+aincr
7177         write (2,*) xx,yy,zz
7178         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7179         de_dxx_num=(sumenep-sumene)/aincr
7180         xx=xxsave
7181         write (2,*) "xx+ sumene from enesc=",sumenep
7182         yysave=yy
7183         yy=yy+aincr
7184         write (2,*) xx,yy,zz
7185         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7186         de_dyy_num=(sumenep-sumene)/aincr
7187         yy=yysave
7188         write (2,*) "yy+ sumene from enesc=",sumenep
7189         zzsave=zz
7190         zz=zz+aincr
7191         write (2,*) xx,yy,zz
7192         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7193         de_dzz_num=(sumenep-sumene)/aincr
7194         zz=zzsave
7195         write (2,*) "zz+ sumene from enesc=",sumenep
7196         costsave=cost2tab(i+1)
7197         sintsave=sint2tab(i+1)
7198         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7199         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7200         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7201         de_dt_num=(sumenep-sumene)/aincr
7202         write (2,*) " t+ sumene from enesc=",sumenep
7203         cost2tab(i+1)=costsave
7204         sint2tab(i+1)=sintsave
7205 C End of diagnostics section.
7206 #endif
7207 C
7208 C Compute the gradient of esc
7209 C
7210 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7211         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7212         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7213         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7214         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7215         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7216         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7217         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7218         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7219         pom1=(sumene3*sint2tab(i+1)+sumene1)
7220      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7221         pom2=(sumene4*cost2tab(i+1)+sumene2)
7222      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7223         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7224         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7225      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7226      &  +x(40)*yy*zz
7227         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7228         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7229      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7230      &  +x(60)*yy*zz
7231         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7232      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7233      &        +(pom1+pom2)*pom_dx
7234 #ifdef DEBUG
7235         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7236 #endif
7237 C
7238         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7239         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7240      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7241      &  +x(40)*xx*zz
7242         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7243         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7244      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7245      &  +x(59)*zz**2 +x(60)*xx*zz
7246         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7247      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7248      &        +(pom1-pom2)*pom_dy
7249 #ifdef DEBUG
7250         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7251 #endif
7252 C
7253         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7254      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7255      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7256      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7257      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7258      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7259      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7260      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7261 #ifdef DEBUG
7262         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7263 #endif
7264 C
7265         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7266      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7267      &  +pom1*pom_dt1+pom2*pom_dt2
7268 #ifdef DEBUG
7269         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7270 #endif
7271 c#undef DEBUG
7272 c
7273 C
7274        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7275        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7276        cosfac2xx=cosfac2*xx
7277        sinfac2yy=sinfac2*yy
7278        do k = 1,3
7279          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7280      &      vbld_inv(i+1)
7281          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7282      &      vbld_inv(i)
7283          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7284          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7285 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7286 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7287 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7288 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7289          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7290          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7291          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7292          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7293          dZZ_Ci1(k)=0.0d0
7294          dZZ_Ci(k)=0.0d0
7295          do j=1,3
7296            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7297      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7298            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7299      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7300          enddo
7301
7302          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7303          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7304          dZZ_XYZ(k)=vbld_inv(i+nres)*
7305      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7306 c
7307          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7308          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7309        enddo
7310
7311        do k=1,3
7312          dXX_Ctab(k,i)=dXX_Ci(k)
7313          dXX_C1tab(k,i)=dXX_Ci1(k)
7314          dYY_Ctab(k,i)=dYY_Ci(k)
7315          dYY_C1tab(k,i)=dYY_Ci1(k)
7316          dZZ_Ctab(k,i)=dZZ_Ci(k)
7317          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7318          dXX_XYZtab(k,i)=dXX_XYZ(k)
7319          dYY_XYZtab(k,i)=dYY_XYZ(k)
7320          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7321        enddo
7322
7323        do k = 1,3
7324 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7325 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7326 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7327 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7328 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7329 c     &    dt_dci(k)
7330 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7331 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7332          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7333      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7334          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7335      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7336          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7337      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7338        enddo
7339 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7340 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7341
7342 C to check gradient call subroutine check_grad
7343
7344     1 continue
7345       enddo
7346       return
7347       end
7348 c------------------------------------------------------------------------------
7349       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7350       implicit none
7351       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7352      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7353       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7354      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7355      &   + x(10)*yy*zz
7356       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7357      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7358      & + x(20)*yy*zz
7359       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7360      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7361      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7362      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7363      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7364      &  +x(40)*xx*yy*zz
7365       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7366      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7367      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7368      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7369      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7370      &  +x(60)*xx*yy*zz
7371       dsc_i   = 0.743d0+x(61)
7372       dp2_i   = 1.9d0+x(62)
7373       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7374      &          *(xx*cost2+yy*sint2))
7375       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7376      &          *(xx*cost2-yy*sint2))
7377       s1=(1+x(63))/(0.1d0 + dscp1)
7378       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7379       s2=(1+x(65))/(0.1d0 + dscp2)
7380       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7381       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7382      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7383       enesc=sumene
7384       return
7385       end
7386 #endif
7387 c------------------------------------------------------------------------------
7388       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7389 C
7390 C This procedure calculates two-body contact function g(rij) and its derivative:
7391 C
7392 C           eps0ij                                     !       x < -1
7393 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7394 C            0                                         !       x > 1
7395 C
7396 C where x=(rij-r0ij)/delta
7397 C
7398 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7399 C
7400       implicit none
7401       double precision rij,r0ij,eps0ij,fcont,fprimcont
7402       double precision x,x2,x4,delta
7403 c     delta=0.02D0*r0ij
7404 c      delta=0.2D0*r0ij
7405       x=(rij-r0ij)/delta
7406       if (x.lt.-1.0D0) then
7407         fcont=eps0ij
7408         fprimcont=0.0D0
7409       else if (x.le.1.0D0) then
7410         x2=x*x
7411         x4=x2*x2
7412         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7413         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7414       else
7415         fcont=0.0D0
7416         fprimcont=0.0D0
7417       endif
7418       return
7419       end
7420 c------------------------------------------------------------------------------
7421       subroutine splinthet(theti,delta,ss,ssder)
7422       implicit real*8 (a-h,o-z)
7423       include 'DIMENSIONS'
7424       include 'COMMON.VAR'
7425       include 'COMMON.GEO'
7426       thetup=pi-delta
7427       thetlow=delta
7428       if (theti.gt.pipol) then
7429         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7430       else
7431         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7432         ssder=-ssder
7433       endif
7434       return
7435       end
7436 c------------------------------------------------------------------------------
7437       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7438       implicit none
7439       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7440       double precision ksi,ksi2,ksi3,a1,a2,a3
7441       a1=fprim0*delta/(f1-f0)
7442       a2=3.0d0-2.0d0*a1
7443       a3=a1-2.0d0
7444       ksi=(x-x0)/delta
7445       ksi2=ksi*ksi
7446       ksi3=ksi2*ksi
7447       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7448       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7449       return
7450       end
7451 c------------------------------------------------------------------------------
7452       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7453       implicit none
7454       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7455       double precision ksi,ksi2,ksi3,a1,a2,a3
7456       ksi=(x-x0)/delta
7457       ksi2=ksi*ksi
7458       ksi3=ksi2*ksi
7459       a1=fprim0x*delta
7460       a2=3*(f1x-f0x)-2*fprim0x*delta
7461       a3=fprim0x*delta-2*(f1x-f0x)
7462       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7463       return
7464       end
7465 C-----------------------------------------------------------------------------
7466 #ifdef CRYST_TOR
7467 C-----------------------------------------------------------------------------
7468       subroutine etor(etors)
7469       implicit real*8 (a-h,o-z)
7470       include 'DIMENSIONS'
7471       include 'COMMON.VAR'
7472       include 'COMMON.GEO'
7473       include 'COMMON.LOCAL'
7474       include 'COMMON.TORSION'
7475       include 'COMMON.INTERACT'
7476       include 'COMMON.DERIV'
7477       include 'COMMON.CHAIN'
7478       include 'COMMON.NAMES'
7479       include 'COMMON.IOUNITS'
7480       include 'COMMON.FFIELD'
7481       include 'COMMON.TORCNSTR'
7482       include 'COMMON.CONTROL'
7483       logical lprn
7484 C Set lprn=.true. for debugging
7485       lprn=.false.
7486 c      lprn=.true.
7487       etors=0.0D0
7488       do i=iphi_start,iphi_end
7489       etors_ii=0.0D0
7490         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7491      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7492         itori=itortyp(itype(i-2))
7493         itori1=itortyp(itype(i-1))
7494         phii=phi(i)
7495         gloci=0.0D0
7496 C Proline-Proline pair is a special case...
7497         if (itori.eq.3 .and. itori1.eq.3) then
7498           if (phii.gt.-dwapi3) then
7499             cosphi=dcos(3*phii)
7500             fac=1.0D0/(1.0D0-cosphi)
7501             etorsi=v1(1,3,3)*fac
7502             etorsi=etorsi+etorsi
7503             etors=etors+etorsi-v1(1,3,3)
7504             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7505             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7506           endif
7507           do j=1,3
7508             v1ij=v1(j+1,itori,itori1)
7509             v2ij=v2(j+1,itori,itori1)
7510             cosphi=dcos(j*phii)
7511             sinphi=dsin(j*phii)
7512             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7513             if (energy_dec) etors_ii=etors_ii+
7514      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7515             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7516           enddo
7517         else
7518           do j=1,nterm_old
7519             v1ij=v1(j,itori,itori1)
7520             v2ij=v2(j,itori,itori1)
7521             cosphi=dcos(j*phii)
7522             sinphi=dsin(j*phii)
7523             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7524             if (energy_dec) etors_ii=etors_ii+
7525      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7526             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7527           enddo
7528         endif
7529         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7530              'etor',i,etors_ii
7531         if (lprn)
7532      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7533      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7534      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7535         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7536 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7537       enddo
7538       return
7539       end
7540 c------------------------------------------------------------------------------
7541       subroutine etor_d(etors_d)
7542       etors_d=0.0d0
7543       return
7544       end
7545 c----------------------------------------------------------------------------
7546 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7547       subroutine e_modeller(ehomology_constr)
7548       ehomology_constr=0.0d0
7549       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7550       return
7551       end
7552 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7553
7554 c------------------------------------------------------------------------------
7555       subroutine etor_d(etors_d)
7556       etors_d=0.0d0
7557       return
7558       end
7559 c----------------------------------------------------------------------------
7560 #else
7561       subroutine etor(etors)
7562       implicit real*8 (a-h,o-z)
7563       include 'DIMENSIONS'
7564       include 'COMMON.VAR'
7565       include 'COMMON.GEO'
7566       include 'COMMON.LOCAL'
7567       include 'COMMON.TORSION'
7568       include 'COMMON.INTERACT'
7569       include 'COMMON.DERIV'
7570       include 'COMMON.CHAIN'
7571       include 'COMMON.NAMES'
7572       include 'COMMON.IOUNITS'
7573       include 'COMMON.FFIELD'
7574       include 'COMMON.TORCNSTR'
7575       include 'COMMON.CONTROL'
7576       logical lprn
7577 C Set lprn=.true. for debugging
7578       lprn=.false.
7579 c     lprn=.true.
7580       etors=0.0D0
7581       do i=iphi_start,iphi_end
7582 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7583 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7584 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7585 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7586         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7587      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7588 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7589 C For introducing the NH3+ and COO- group please check the etor_d for reference
7590 C and guidance
7591         etors_ii=0.0D0
7592          if (iabs(itype(i)).eq.20) then
7593          iblock=2
7594          else
7595          iblock=1
7596          endif
7597         itori=itortyp(itype(i-2))
7598         itori1=itortyp(itype(i-1))
7599         phii=phi(i)
7600         gloci=0.0D0
7601 C Regular cosine and sine terms
7602         do j=1,nterm(itori,itori1,iblock)
7603           v1ij=v1(j,itori,itori1,iblock)
7604           v2ij=v2(j,itori,itori1,iblock)
7605           cosphi=dcos(j*phii)
7606           sinphi=dsin(j*phii)
7607           etors=etors+v1ij*cosphi+v2ij*sinphi
7608           if (energy_dec) etors_ii=etors_ii+
7609      &                v1ij*cosphi+v2ij*sinphi
7610           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7611         enddo
7612 C Lorentz terms
7613 C                         v1
7614 C  E = SUM ----------------------------------- - v1
7615 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7616 C
7617         cosphi=dcos(0.5d0*phii)
7618         sinphi=dsin(0.5d0*phii)
7619         do j=1,nlor(itori,itori1,iblock)
7620           vl1ij=vlor1(j,itori,itori1)
7621           vl2ij=vlor2(j,itori,itori1)
7622           vl3ij=vlor3(j,itori,itori1)
7623           pom=vl2ij*cosphi+vl3ij*sinphi
7624           pom1=1.0d0/(pom*pom+1.0d0)
7625           etors=etors+vl1ij*pom1
7626           if (energy_dec) etors_ii=etors_ii+
7627      &                vl1ij*pom1
7628           pom=-pom*pom1*pom1
7629           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7630         enddo
7631 C Subtract the constant term
7632         etors=etors-v0(itori,itori1,iblock)
7633           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7634      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7635         if (lprn)
7636      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7637      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7638      &  (v1(j,itori,itori1,iblock),j=1,6),
7639      &  (v2(j,itori,itori1,iblock),j=1,6)
7640         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7641 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7642       enddo
7643       return
7644       end
7645 c----------------------------------------------------------------------------
7646       subroutine etor_d(etors_d)
7647 C 6/23/01 Compute double torsional energy
7648       implicit real*8 (a-h,o-z)
7649       include 'DIMENSIONS'
7650       include 'COMMON.VAR'
7651       include 'COMMON.GEO'
7652       include 'COMMON.LOCAL'
7653       include 'COMMON.TORSION'
7654       include 'COMMON.INTERACT'
7655       include 'COMMON.DERIV'
7656       include 'COMMON.CHAIN'
7657       include 'COMMON.NAMES'
7658       include 'COMMON.IOUNITS'
7659       include 'COMMON.FFIELD'
7660       include 'COMMON.TORCNSTR'
7661       logical lprn
7662 C Set lprn=.true. for debugging
7663       lprn=.false.
7664 c     lprn=.true.
7665       etors_d=0.0D0
7666 c      write(iout,*) "a tu??"
7667       do i=iphid_start,iphid_end
7668 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7669 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7670 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7671 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7672 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7673          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7674      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7675      &  (itype(i+1).eq.ntyp1)) cycle
7676 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7677         itori=itortyp(itype(i-2))
7678         itori1=itortyp(itype(i-1))
7679         itori2=itortyp(itype(i))
7680         phii=phi(i)
7681         phii1=phi(i+1)
7682         gloci1=0.0D0
7683         gloci2=0.0D0
7684         iblock=1
7685         if (iabs(itype(i+1)).eq.20) iblock=2
7686 C Iblock=2 Proline type
7687 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7688 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7689 C        if (itype(i+1).eq.ntyp1) iblock=3
7690 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7691 C IS or IS NOT need for this
7692 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7693 C        is (itype(i-3).eq.ntyp1) ntblock=2
7694 C        ntblock is N-terminal blocking group
7695
7696 C Regular cosine and sine terms
7697         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7698 C Example of changes for NH3+ blocking group
7699 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7700 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7701           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7702           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7703           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7704           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7705           cosphi1=dcos(j*phii)
7706           sinphi1=dsin(j*phii)
7707           cosphi2=dcos(j*phii1)
7708           sinphi2=dsin(j*phii1)
7709           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7710      &     v2cij*cosphi2+v2sij*sinphi2
7711           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7712           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7713         enddo
7714         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7715           do l=1,k-1
7716             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7717             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7718             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7719             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7720             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7721             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7722             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7723             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7724             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7725      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7726             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7727      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7728             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7729      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7730           enddo
7731         enddo
7732         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7733         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7734       enddo
7735       return
7736       end
7737 #endif
7738 C----------------------------------------------------------------------------------
7739 C The rigorous attempt to derive energy function
7740       subroutine etor_kcc(etors)
7741       implicit real*8 (a-h,o-z)
7742       include 'DIMENSIONS'
7743       include 'COMMON.VAR'
7744       include 'COMMON.GEO'
7745       include 'COMMON.LOCAL'
7746       include 'COMMON.TORSION'
7747       include 'COMMON.INTERACT'
7748       include 'COMMON.DERIV'
7749       include 'COMMON.CHAIN'
7750       include 'COMMON.NAMES'
7751       include 'COMMON.IOUNITS'
7752       include 'COMMON.FFIELD'
7753       include 'COMMON.TORCNSTR'
7754       include 'COMMON.CONTROL'
7755       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7756       logical lprn
7757 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7758 C Set lprn=.true. for debugging
7759       lprn=energy_dec
7760 c     lprn=.true.
7761 C      print *,"wchodze kcc"
7762       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7763       etors=0.0D0
7764       do i=iphi_start,iphi_end
7765 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7766 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7767 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7768 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7769         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7770      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7771         itori=itortyp(itype(i-2))
7772         itori1=itortyp(itype(i-1))
7773         phii=phi(i)
7774         glocig=0.0D0
7775         glocit1=0.0d0
7776         glocit2=0.0d0
7777 C to avoid multiple devision by 2
7778 c        theti22=0.5d0*theta(i)
7779 C theta 12 is the theta_1 /2
7780 C theta 22 is theta_2 /2
7781 c        theti12=0.5d0*theta(i-1)
7782 C and appropriate sinus function
7783         sinthet1=dsin(theta(i-1))
7784         sinthet2=dsin(theta(i))
7785         costhet1=dcos(theta(i-1))
7786         costhet2=dcos(theta(i))
7787 C to speed up lets store its mutliplication
7788         sint1t2=sinthet2*sinthet1
7789         sint1t2n=1.0d0
7790 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7791 C +d_n*sin(n*gamma)) *
7792 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7793 C we have two sum 1) Non-Chebyshev which is with n and gamma
7794         nval=nterm_kcc_Tb(itori,itori1)
7795         c1(0)=0.0d0
7796         c2(0)=0.0d0
7797         c1(1)=1.0d0
7798         c2(1)=1.0d0
7799         do j=2,nval
7800           c1(j)=c1(j-1)*costhet1
7801           c2(j)=c2(j-1)*costhet2
7802         enddo
7803         etori=0.0d0
7804         do j=1,nterm_kcc(itori,itori1)
7805           cosphi=dcos(j*phii)
7806           sinphi=dsin(j*phii)
7807           sint1t2n1=sint1t2n
7808           sint1t2n=sint1t2n*sint1t2
7809           sumvalc=0.0d0
7810           gradvalct1=0.0d0
7811           gradvalct2=0.0d0
7812           do k=1,nval
7813             do l=1,nval
7814               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7815               gradvalct1=gradvalct1+
7816      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7817               gradvalct2=gradvalct2+
7818      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7819             enddo
7820           enddo
7821           gradvalct1=-gradvalct1*sinthet1
7822           gradvalct2=-gradvalct2*sinthet2
7823           sumvals=0.0d0
7824           gradvalst1=0.0d0
7825           gradvalst2=0.0d0
7826           do k=1,nval
7827             do l=1,nval
7828               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7829               gradvalst1=gradvalst1+
7830      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7831               gradvalst2=gradvalst2+
7832      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7833             enddo
7834           enddo
7835           gradvalst1=-gradvalst1*sinthet1
7836           gradvalst2=-gradvalst2*sinthet2
7837           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7838           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7839 C glocig is the gradient local i site in gamma
7840           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7841 C now gradient over theta_1
7842           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7843      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7844           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7845      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7846         enddo ! j
7847         etors=etors+etori
7848 C derivative over gamma
7849         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7850 C derivative over theta1
7851         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7852 C now derivative over theta2
7853         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7854         if (lprn) then
7855           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7856      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7857           write (iout,*) "c1",(c1(k),k=0,nval),
7858      &    " c2",(c2(k),k=0,nval)
7859         endif
7860       enddo
7861       return
7862       end
7863 c---------------------------------------------------------------------------------------------
7864       subroutine etor_constr(edihcnstr)
7865       implicit real*8 (a-h,o-z)
7866       include 'DIMENSIONS'
7867       include 'COMMON.VAR'
7868       include 'COMMON.GEO'
7869       include 'COMMON.LOCAL'
7870       include 'COMMON.TORSION'
7871       include 'COMMON.INTERACT'
7872       include 'COMMON.DERIV'
7873       include 'COMMON.CHAIN'
7874       include 'COMMON.NAMES'
7875       include 'COMMON.IOUNITS'
7876       include 'COMMON.FFIELD'
7877       include 'COMMON.TORCNSTR'
7878       include 'COMMON.BOUNDS'
7879       include 'COMMON.CONTROL'
7880 ! 6/20/98 - dihedral angle constraints
7881       edihcnstr=0.0d0
7882 c      do i=1,ndih_constr
7883       if (raw_psipred) then
7884         do i=idihconstr_start,idihconstr_end
7885           itori=idih_constr(i)
7886           phii=phi(itori)
7887           gaudih_i=vpsipred(1,i)
7888           gauder_i=0.0d0
7889           do j=1,2
7890             s = sdihed(j,i)
7891             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7892             dexpcos_i=dexp(-cos_i*cos_i)
7893             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7894             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7895      &            *cos_i*dexpcos_i/s**2
7896           enddo
7897           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7898           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7899           if (energy_dec)
7900      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7901      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7902      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7903      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7904      &     -wdihc*dlog(gaudih_i)
7905         enddo
7906       else
7907
7908       do i=idihconstr_start,idihconstr_end
7909         itori=idih_constr(i)
7910         phii=phi(itori)
7911         difi=pinorm(phii-phi0(i))
7912         if (difi.gt.drange(i)) then
7913           difi=difi-drange(i)
7914           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7915           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7916         else if (difi.lt.-drange(i)) then
7917           difi=difi+drange(i)
7918           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7919           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7920         else
7921           difi=0.0
7922         endif
7923       enddo
7924
7925       endif
7926
7927       return
7928       end
7929 c----------------------------------------------------------------------------
7930 c MODELLER restraint function
7931       subroutine e_modeller(ehomology_constr)
7932       implicit none
7933       include 'DIMENSIONS'
7934
7935       double precision ehomology_constr
7936       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7937       integer katy, odleglosci, test7
7938       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7939       real*8 Eval,Erot
7940       real*8 distance(max_template),distancek(max_template),
7941      &    min_odl,godl(max_template),dih_diff(max_template)
7942
7943 c
7944 c     FP - 30/10/2014 Temporary specifications for homology restraints
7945 c
7946       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7947      &                 sgtheta
7948       double precision, dimension (maxres) :: guscdiff,usc_diff
7949       double precision, dimension (max_template) ::
7950      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7951      &           theta_diff
7952       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7953      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7954      & betai,sum_sgodl,dij
7955       double precision dist,pinorm
7956 c
7957       include 'COMMON.SBRIDGE'
7958       include 'COMMON.CHAIN'
7959       include 'COMMON.GEO'
7960       include 'COMMON.DERIV'
7961       include 'COMMON.LOCAL'
7962       include 'COMMON.INTERACT'
7963       include 'COMMON.VAR'
7964       include 'COMMON.IOUNITS'
7965 c      include 'COMMON.MD'
7966       include 'COMMON.CONTROL'
7967       include 'COMMON.HOMOLOGY'
7968       include 'COMMON.QRESTR'
7969 c
7970 c     From subroutine Econstr_back
7971 c
7972       include 'COMMON.NAMES'
7973       include 'COMMON.TIME1'
7974 c
7975
7976
7977       do i=1,max_template
7978         distancek(i)=9999999.9
7979       enddo
7980
7981
7982       odleg=0.0d0
7983
7984 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7985 c function)
7986 C AL 5/2/14 - Introduce list of restraints
7987 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7988 #ifdef DEBUG
7989       write(iout,*) "------- dist restrs start -------"
7990 #endif
7991       do ii = link_start_homo,link_end_homo
7992          i = ires_homo(ii)
7993          j = jres_homo(ii)
7994          dij=dist(i,j)
7995 c        write (iout,*) "dij(",i,j,") =",dij
7996          nexl=0
7997          do k=1,constr_homology
7998 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7999            if(.not.l_homo(k,ii)) then
8000              nexl=nexl+1
8001              cycle
8002            endif
8003            distance(k)=odl(k,ii)-dij
8004 c          write (iout,*) "distance(",k,") =",distance(k)
8005 c
8006 c          For Gaussian-type Urestr
8007 c
8008            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8009 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8010 c          write (iout,*) "distancek(",k,") =",distancek(k)
8011 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8012 c
8013 c          For Lorentzian-type Urestr
8014 c
8015            if (waga_dist.lt.0.0d0) then
8016               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8017               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8018      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8019            endif
8020          enddo
8021
8022 c         min_odl=minval(distancek)
8023          do kk=1,constr_homology
8024           if(l_homo(kk,ii)) then
8025             min_odl=distancek(kk)
8026             exit
8027           endif
8028          enddo
8029          do kk=1,constr_homology
8030           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8031      &              min_odl=distancek(kk)
8032          enddo
8033
8034 c        write (iout,* )"min_odl",min_odl
8035 #ifdef DEBUG
8036          write (iout,*) "ij dij",i,j,dij
8037          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8038          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8039          write (iout,* )"min_odl",min_odl
8040 #endif
8041 #ifdef OLDRESTR
8042          odleg2=0.0d0
8043 #else
8044          if (waga_dist.ge.0.0d0) then
8045            odleg2=nexl
8046          else
8047            odleg2=0.0d0
8048          endif
8049 #endif
8050          do k=1,constr_homology
8051 c Nie wiem po co to liczycie jeszcze raz!
8052 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8053 c     &              (2*(sigma_odl(i,j,k))**2))
8054            if(.not.l_homo(k,ii)) cycle
8055            if (waga_dist.ge.0.0d0) then
8056 c
8057 c          For Gaussian-type Urestr
8058 c
8059             godl(k)=dexp(-distancek(k)+min_odl)
8060             odleg2=odleg2+godl(k)
8061 c
8062 c          For Lorentzian-type Urestr
8063 c
8064            else
8065             odleg2=odleg2+distancek(k)
8066            endif
8067
8068 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8069 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8070 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8071 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8072
8073          enddo
8074 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8075 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8076 #ifdef DEBUG
8077          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8078          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8079 #endif
8080            if (waga_dist.ge.0.0d0) then
8081 c
8082 c          For Gaussian-type Urestr
8083 c
8084               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8085 c
8086 c          For Lorentzian-type Urestr
8087 c
8088            else
8089               odleg=odleg+odleg2/constr_homology
8090            endif
8091 c
8092 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8093 c Gradient
8094 c
8095 c          For Gaussian-type Urestr
8096 c
8097          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8098          sum_sgodl=0.0d0
8099          do k=1,constr_homology
8100 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8101 c     &           *waga_dist)+min_odl
8102 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8103 c
8104          if(.not.l_homo(k,ii)) cycle
8105          if (waga_dist.ge.0.0d0) then
8106 c          For Gaussian-type Urestr
8107 c
8108            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8109 c
8110 c          For Lorentzian-type Urestr
8111 c
8112          else
8113            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8114      &           sigma_odlir(k,ii)**2)**2)
8115          endif
8116            sum_sgodl=sum_sgodl+sgodl
8117
8118 c            sgodl2=sgodl2+sgodl
8119 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8120 c      write(iout,*) "constr_homology=",constr_homology
8121 c      write(iout,*) i, j, k, "TEST K"
8122          enddo
8123          if (waga_dist.ge.0.0d0) then
8124 c
8125 c          For Gaussian-type Urestr
8126 c
8127             grad_odl3=waga_homology(iset)*waga_dist
8128      &                *sum_sgodl/(sum_godl*dij)
8129 c
8130 c          For Lorentzian-type Urestr
8131 c
8132          else
8133 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8134 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8135             grad_odl3=-waga_homology(iset)*waga_dist*
8136      &                sum_sgodl/(constr_homology*dij)
8137          endif
8138 c
8139 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8140
8141
8142 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8143 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8144 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8145
8146 ccc      write(iout,*) godl, sgodl, grad_odl3
8147
8148 c          grad_odl=grad_odl+grad_odl3
8149
8150          do jik=1,3
8151             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8152 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8153 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8154 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8155             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8156             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8157 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8158 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8159 c         if (i.eq.25.and.j.eq.27) then
8160 c         write(iout,*) "jik",jik,"i",i,"j",j
8161 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8162 c         write(iout,*) "grad_odl3",grad_odl3
8163 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8164 c         write(iout,*) "ggodl",ggodl
8165 c         write(iout,*) "ghpbc(",jik,i,")",
8166 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8167 c     &                 ghpbc(jik,j)
8168 c         endif
8169          enddo
8170 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8171 ccc     & dLOG(odleg2),"-odleg=", -odleg
8172
8173       enddo ! ii-loop for dist
8174 #ifdef DEBUG
8175       write(iout,*) "------- dist restrs end -------"
8176 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8177 c    &     waga_d.eq.1.0d0) call sum_gradient
8178 #endif
8179 c Pseudo-energy and gradient from dihedral-angle restraints from
8180 c homology templates
8181 c      write (iout,*) "End of distance loop"
8182 c      call flush(iout)
8183       kat=0.0d0
8184 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8185 #ifdef DEBUG
8186       write(iout,*) "------- dih restrs start -------"
8187       do i=idihconstr_start_homo,idihconstr_end_homo
8188         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8189       enddo
8190 #endif
8191       do i=idihconstr_start_homo,idihconstr_end_homo
8192         kat2=0.0d0
8193 c        betai=beta(i,i+1,i+2,i+3)
8194         betai = phi(i)
8195 c       write (iout,*) "betai =",betai
8196         do k=1,constr_homology
8197           dih_diff(k)=pinorm(dih(k,i)-betai)
8198 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8199 cd     &                  ,sigma_dih(k,i)
8200 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8201 c     &                                   -(6.28318-dih_diff(i,k))
8202 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8203 c     &                                   6.28318+dih_diff(i,k)
8204 #ifdef OLD_DIHED
8205           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8206 #else
8207           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8208 #endif
8209 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8210           gdih(k)=dexp(kat3)
8211           kat2=kat2+gdih(k)
8212 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8213 c          write(*,*)""
8214         enddo
8215 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8216 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8217 #ifdef DEBUG
8218         write (iout,*) "i",i," betai",betai," kat2",kat2
8219         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8220 #endif
8221         if (kat2.le.1.0d-14) cycle
8222         kat=kat-dLOG(kat2/constr_homology)
8223 c       write (iout,*) "kat",kat ! sum of -ln-s
8224
8225 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8226 ccc     & dLOG(kat2), "-kat=", -kat
8227
8228 c ----------------------------------------------------------------------
8229 c Gradient
8230 c ----------------------------------------------------------------------
8231
8232         sum_gdih=kat2
8233         sum_sgdih=0.0d0
8234         do k=1,constr_homology
8235 #ifdef OLD_DIHED
8236           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8237 #else
8238           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8239 #endif
8240 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8241           sum_sgdih=sum_sgdih+sgdih
8242         enddo
8243 c       grad_dih3=sum_sgdih/sum_gdih
8244         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8245
8246 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8247 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8248 ccc     & gloc(nphi+i-3,icg)
8249         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8250 c        if (i.eq.25) then
8251 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8252 c        endif
8253 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8254 ccc     & gloc(nphi+i-3,icg)
8255
8256       enddo ! i-loop for dih
8257 #ifdef DEBUG
8258       write(iout,*) "------- dih restrs end -------"
8259 #endif
8260
8261 c Pseudo-energy and gradient for theta angle restraints from
8262 c homology templates
8263 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8264 c adapted
8265
8266 c
8267 c     For constr_homology reference structures (FP)
8268 c
8269 c     Uconst_back_tot=0.0d0
8270       Eval=0.0d0
8271       Erot=0.0d0
8272 c     Econstr_back legacy
8273       do i=1,nres
8274 c     do i=ithet_start,ithet_end
8275        dutheta(i)=0.0d0
8276 c     enddo
8277 c     do i=loc_start,loc_end
8278         do j=1,3
8279           duscdiff(j,i)=0.0d0
8280           duscdiffx(j,i)=0.0d0
8281         enddo
8282       enddo
8283 c
8284 c     do iref=1,nref
8285 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8286 c     write (iout,*) "waga_theta",waga_theta
8287       if (waga_theta.gt.0.0d0) then
8288 #ifdef DEBUG
8289       write (iout,*) "usampl",usampl
8290       write(iout,*) "------- theta restrs start -------"
8291 c     do i=ithet_start,ithet_end
8292 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8293 c     enddo
8294 #endif
8295 c     write (iout,*) "maxres",maxres,"nres",nres
8296
8297       do i=ithet_start,ithet_end
8298 c
8299 c     do i=1,nfrag_back
8300 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8301 c
8302 c Deviation of theta angles wrt constr_homology ref structures
8303 c
8304         utheta_i=0.0d0 ! argument of Gaussian for single k
8305         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8306 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8307 c       over residues in a fragment
8308 c       write (iout,*) "theta(",i,")=",theta(i)
8309         do k=1,constr_homology
8310 c
8311 c         dtheta_i=theta(j)-thetaref(j,iref)
8312 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8313           theta_diff(k)=thetatpl(k,i)-theta(i)
8314 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8315 cd     &                  ,sigma_theta(k,i)
8316
8317 c
8318           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8319 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8320           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8321           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8322 c         Gradient for single Gaussian restraint in subr Econstr_back
8323 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8324 c
8325         enddo
8326 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8327 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8328
8329 c
8330 c         Gradient for multiple Gaussian restraint
8331         sum_gtheta=gutheta_i
8332         sum_sgtheta=0.0d0
8333         do k=1,constr_homology
8334 c        New generalized expr for multiple Gaussian from Econstr_back
8335          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8336 c
8337 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8338           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8339         enddo
8340 c       Final value of gradient using same var as in Econstr_back
8341         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8342      &      +sum_sgtheta/sum_gtheta*waga_theta
8343      &               *waga_homology(iset)
8344 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8345 c     &               *waga_homology(iset)
8346 c       dutheta(i)=sum_sgtheta/sum_gtheta
8347 c
8348 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8349         Eval=Eval-dLOG(gutheta_i/constr_homology)
8350 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8351 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8352 c       Uconst_back=Uconst_back+utheta(i)
8353       enddo ! (i-loop for theta)
8354 #ifdef DEBUG
8355       write(iout,*) "------- theta restrs end -------"
8356 #endif
8357       endif
8358 c
8359 c Deviation of local SC geometry
8360 c
8361 c Separation of two i-loops (instructed by AL - 11/3/2014)
8362 c
8363 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8364 c     write (iout,*) "waga_d",waga_d
8365
8366 #ifdef DEBUG
8367       write(iout,*) "------- SC restrs start -------"
8368       write (iout,*) "Initial duscdiff,duscdiffx"
8369       do i=loc_start,loc_end
8370         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8371      &                 (duscdiffx(jik,i),jik=1,3)
8372       enddo
8373 #endif
8374       do i=loc_start,loc_end
8375         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8376         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8377 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8378 c       write(iout,*) "xxtab, yytab, zztab"
8379 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8380         do k=1,constr_homology
8381 c
8382           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8383 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8384           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8385           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8386 c         write(iout,*) "dxx, dyy, dzz"
8387 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8388 c
8389           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8390 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8391 c         uscdiffk(k)=usc_diff(i)
8392           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8393 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8394 c     &       " guscdiff2",guscdiff2(k)
8395           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8396 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8397 c     &      xxref(j),yyref(j),zzref(j)
8398         enddo
8399 c
8400 c       Gradient
8401 c
8402 c       Generalized expression for multiple Gaussian acc to that for a single
8403 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8404 c
8405 c       Original implementation
8406 c       sum_guscdiff=guscdiff(i)
8407 c
8408 c       sum_sguscdiff=0.0d0
8409 c       do k=1,constr_homology
8410 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8411 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8412 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8413 c       enddo
8414 c
8415 c       Implementation of new expressions for gradient (Jan. 2015)
8416 c
8417 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8418         do k=1,constr_homology
8419 c
8420 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8421 c       before. Now the drivatives should be correct
8422 c
8423           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8424 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8425           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8426           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8427 c
8428 c         New implementation
8429 c
8430           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8431      &                 sigma_d(k,i) ! for the grad wrt r'
8432 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8433 c
8434 c
8435 c        New implementation
8436          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8437          do jik=1,3
8438             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8439      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8440      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8441             duscdiff(jik,i)=duscdiff(jik,i)+
8442      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8443      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8444             duscdiffx(jik,i)=duscdiffx(jik,i)+
8445      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8446      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8447 c
8448 #ifdef DEBUG
8449              write(iout,*) "jik",jik,"i",i
8450              write(iout,*) "dxx, dyy, dzz"
8451              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8452              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8453 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8454 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8455 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8456 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8457 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8458 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8459 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8460 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8461 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8462 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8463 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8464 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8465 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8466 c            endif
8467 #endif
8468          enddo
8469         enddo
8470 c
8471 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8472 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8473 c
8474 c        write (iout,*) i," uscdiff",uscdiff(i)
8475 c
8476 c Put together deviations from local geometry
8477
8478 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8479 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8480         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8481 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8482 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8483 c       Uconst_back=Uconst_back+usc_diff(i)
8484 c
8485 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8486 c
8487 c     New implment: multiplied by sum_sguscdiff
8488 c
8489
8490       enddo ! (i-loop for dscdiff)
8491
8492 c      endif
8493
8494 #ifdef DEBUG
8495       write(iout,*) "------- SC restrs end -------"
8496         write (iout,*) "------ After SC loop in e_modeller ------"
8497         do i=loc_start,loc_end
8498          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8499          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8500         enddo
8501       if (waga_theta.eq.1.0d0) then
8502       write (iout,*) "in e_modeller after SC restr end: dutheta"
8503       do i=ithet_start,ithet_end
8504         write (iout,*) i,dutheta(i)
8505       enddo
8506       endif
8507       if (waga_d.eq.1.0d0) then
8508       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8509       do i=1,nres
8510         write (iout,*) i,(duscdiff(j,i),j=1,3)
8511         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8512       enddo
8513       endif
8514 #endif
8515
8516 c Total energy from homology restraints
8517 #ifdef DEBUG
8518       write (iout,*) "odleg",odleg," kat",kat
8519 #endif
8520 c
8521 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8522 c
8523 c     ehomology_constr=odleg+kat
8524 c
8525 c     For Lorentzian-type Urestr
8526 c
8527
8528       if (waga_dist.ge.0.0d0) then
8529 c
8530 c          For Gaussian-type Urestr
8531 c
8532         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8533      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8534 c     write (iout,*) "ehomology_constr=",ehomology_constr
8535       else
8536 c
8537 c          For Lorentzian-type Urestr
8538 c
8539         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8540      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8541 c     write (iout,*) "ehomology_constr=",ehomology_constr
8542       endif
8543 #ifdef DEBUG
8544       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8545      & "Eval",waga_theta,eval,
8546      &   "Erot",waga_d,Erot
8547       write (iout,*) "ehomology_constr",ehomology_constr
8548 #endif
8549       return
8550 c
8551 c FP 01/15 end
8552 c
8553   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8554   747 format(a12,i4,i4,i4,f8.3,f8.3)
8555   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8556   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8557   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8558      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8559       end
8560 c----------------------------------------------------------------------------
8561 C The rigorous attempt to derive energy function
8562       subroutine ebend_kcc(etheta)
8563
8564       implicit real*8 (a-h,o-z)
8565       include 'DIMENSIONS'
8566       include 'COMMON.VAR'
8567       include 'COMMON.GEO'
8568       include 'COMMON.LOCAL'
8569       include 'COMMON.TORSION'
8570       include 'COMMON.INTERACT'
8571       include 'COMMON.DERIV'
8572       include 'COMMON.CHAIN'
8573       include 'COMMON.NAMES'
8574       include 'COMMON.IOUNITS'
8575       include 'COMMON.FFIELD'
8576       include 'COMMON.TORCNSTR'
8577       include 'COMMON.CONTROL'
8578       logical lprn
8579       double precision thybt1(maxang_kcc)
8580 C Set lprn=.true. for debugging
8581       lprn=energy_dec
8582 c     lprn=.true.
8583 C      print *,"wchodze kcc"
8584       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8585       etheta=0.0D0
8586       do i=ithet_start,ithet_end
8587 c        print *,i,itype(i-1),itype(i),itype(i-2)
8588         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8589      &  .or.itype(i).eq.ntyp1) cycle
8590         iti=iabs(itortyp(itype(i-1)))
8591         sinthet=dsin(theta(i))
8592         costhet=dcos(theta(i))
8593         do j=1,nbend_kcc_Tb(iti)
8594           thybt1(j)=v1bend_chyb(j,iti)
8595         enddo
8596         sumth1thyb=v1bend_chyb(0,iti)+
8597      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8598         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8599      &    sumth1thyb
8600         ihelp=nbend_kcc_Tb(iti)-1
8601         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8602         etheta=etheta+sumth1thyb
8603 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8604         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8605       enddo
8606       return
8607       end
8608 c-------------------------------------------------------------------------------------
8609       subroutine etheta_constr(ethetacnstr)
8610
8611       implicit real*8 (a-h,o-z)
8612       include 'DIMENSIONS'
8613       include 'COMMON.VAR'
8614       include 'COMMON.GEO'
8615       include 'COMMON.LOCAL'
8616       include 'COMMON.TORSION'
8617       include 'COMMON.INTERACT'
8618       include 'COMMON.DERIV'
8619       include 'COMMON.CHAIN'
8620       include 'COMMON.NAMES'
8621       include 'COMMON.IOUNITS'
8622       include 'COMMON.FFIELD'
8623       include 'COMMON.TORCNSTR'
8624       include 'COMMON.CONTROL'
8625       ethetacnstr=0.0d0
8626 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8627       do i=ithetaconstr_start,ithetaconstr_end
8628         itheta=itheta_constr(i)
8629         thetiii=theta(itheta)
8630         difi=pinorm(thetiii-theta_constr0(i))
8631         if (difi.gt.theta_drange(i)) then
8632           difi=difi-theta_drange(i)
8633           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8634           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8635      &    +for_thet_constr(i)*difi**3
8636         else if (difi.lt.-drange(i)) then
8637           difi=difi+drange(i)
8638           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8639           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8640      &    +for_thet_constr(i)*difi**3
8641         else
8642           difi=0.0
8643         endif
8644        if (energy_dec) then
8645         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8646      &    i,itheta,rad2deg*thetiii,
8647      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8648      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8649      &    gloc(itheta+nphi-2,icg)
8650         endif
8651       enddo
8652       return
8653       end
8654 c------------------------------------------------------------------------------
8655       subroutine eback_sc_corr(esccor)
8656 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8657 c        conformational states; temporarily implemented as differences
8658 c        between UNRES torsional potentials (dependent on three types of
8659 c        residues) and the torsional potentials dependent on all 20 types
8660 c        of residues computed from AM1  energy surfaces of terminally-blocked
8661 c        amino-acid residues.
8662       implicit real*8 (a-h,o-z)
8663       include 'DIMENSIONS'
8664       include 'COMMON.VAR'
8665       include 'COMMON.GEO'
8666       include 'COMMON.LOCAL'
8667       include 'COMMON.TORSION'
8668       include 'COMMON.SCCOR'
8669       include 'COMMON.INTERACT'
8670       include 'COMMON.DERIV'
8671       include 'COMMON.CHAIN'
8672       include 'COMMON.NAMES'
8673       include 'COMMON.IOUNITS'
8674       include 'COMMON.FFIELD'
8675       include 'COMMON.CONTROL'
8676       logical lprn
8677 C Set lprn=.true. for debugging
8678       lprn=.false.
8679 c      lprn=.true.
8680 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8681       esccor=0.0D0
8682       do i=itau_start,itau_end
8683         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8684         esccor_ii=0.0D0
8685         isccori=isccortyp(itype(i-2))
8686         isccori1=isccortyp(itype(i-1))
8687 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8688         phii=phi(i)
8689         do intertyp=1,3 !intertyp
8690 cc Added 09 May 2012 (Adasko)
8691 cc  Intertyp means interaction type of backbone mainchain correlation:
8692 c   1 = SC...Ca...Ca...Ca
8693 c   2 = Ca...Ca...Ca...SC
8694 c   3 = SC...Ca...Ca...SCi
8695         gloci=0.0D0
8696         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8697      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8698      &      (itype(i-1).eq.ntyp1)))
8699      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8700      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8701      &     .or.(itype(i).eq.ntyp1)))
8702      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8703      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8704      &      (itype(i-3).eq.ntyp1)))) cycle
8705         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8706         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8707      & cycle
8708        do j=1,nterm_sccor(isccori,isccori1)
8709           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8710           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8711           cosphi=dcos(j*tauangle(intertyp,i))
8712           sinphi=dsin(j*tauangle(intertyp,i))
8713           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8714           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8715         enddo
8716 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8717         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8718         if (lprn)
8719      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8720      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8721      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8722      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8723         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8724        enddo !intertyp
8725       enddo
8726
8727       return
8728       end
8729 c----------------------------------------------------------------------------
8730       subroutine multibody(ecorr)
8731 C This subroutine calculates multi-body contributions to energy following
8732 C the idea of Skolnick et al. If side chains I and J make a contact and
8733 C at the same time side chains I+1 and J+1 make a contact, an extra
8734 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8735       implicit real*8 (a-h,o-z)
8736       include 'DIMENSIONS'
8737       include 'COMMON.IOUNITS'
8738       include 'COMMON.DERIV'
8739       include 'COMMON.INTERACT'
8740       include 'COMMON.CONTACTS'
8741       double precision gx(3),gx1(3)
8742       logical lprn
8743
8744 C Set lprn=.true. for debugging
8745       lprn=.false.
8746
8747       if (lprn) then
8748         write (iout,'(a)') 'Contact function values:'
8749         do i=nnt,nct-2
8750           write (iout,'(i2,20(1x,i2,f10.5))')
8751      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8752         enddo
8753       endif
8754       ecorr=0.0D0
8755       do i=nnt,nct
8756         do j=1,3
8757           gradcorr(j,i)=0.0D0
8758           gradxorr(j,i)=0.0D0
8759         enddo
8760       enddo
8761       do i=nnt,nct-2
8762
8763         DO ISHIFT = 3,4
8764
8765         i1=i+ishift
8766         num_conti=num_cont(i)
8767         num_conti1=num_cont(i1)
8768         do jj=1,num_conti
8769           j=jcont(jj,i)
8770           do kk=1,num_conti1
8771             j1=jcont(kk,i1)
8772             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8773 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8774 cd   &                   ' ishift=',ishift
8775 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8776 C The system gains extra energy.
8777               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8778             endif   ! j1==j+-ishift
8779           enddo     ! kk
8780         enddo       ! jj
8781
8782         ENDDO ! ISHIFT
8783
8784       enddo         ! i
8785       return
8786       end
8787 c------------------------------------------------------------------------------
8788       double precision function esccorr(i,j,k,l,jj,kk)
8789       implicit real*8 (a-h,o-z)
8790       include 'DIMENSIONS'
8791       include 'COMMON.IOUNITS'
8792       include 'COMMON.DERIV'
8793       include 'COMMON.INTERACT'
8794       include 'COMMON.CONTACTS'
8795       include 'COMMON.SHIELD'
8796       double precision gx(3),gx1(3)
8797       logical lprn
8798       lprn=.false.
8799       eij=facont(jj,i)
8800       ekl=facont(kk,k)
8801 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8802 C Calculate the multi-body contribution to energy.
8803 C Calculate multi-body contributions to the gradient.
8804 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8805 cd   & k,l,(gacont(m,kk,k),m=1,3)
8806       do m=1,3
8807         gx(m) =ekl*gacont(m,jj,i)
8808         gx1(m)=eij*gacont(m,kk,k)
8809         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8810         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8811         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8812         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8813       enddo
8814       do m=i,j-1
8815         do ll=1,3
8816           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8817         enddo
8818       enddo
8819       do m=k,l-1
8820         do ll=1,3
8821           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8822         enddo
8823       enddo
8824       esccorr=-eij*ekl
8825       return
8826       end
8827 c------------------------------------------------------------------------------
8828       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8829 C This subroutine calculates multi-body contributions to hydrogen-bonding
8830       implicit real*8 (a-h,o-z)
8831       include 'DIMENSIONS'
8832       include 'COMMON.IOUNITS'
8833 #ifdef MPI
8834       include "mpif.h"
8835       parameter (max_cont=maxconts)
8836       parameter (max_dim=26)
8837       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8838       double precision zapas(max_dim,maxconts,max_fg_procs),
8839      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8840       common /przechowalnia/ zapas
8841       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8842      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8843 #endif
8844       include 'COMMON.SETUP'
8845       include 'COMMON.FFIELD'
8846       include 'COMMON.DERIV'
8847       include 'COMMON.INTERACT'
8848       include 'COMMON.CONTACTS'
8849       include 'COMMON.CONTROL'
8850       include 'COMMON.LOCAL'
8851       double precision gx(3),gx1(3),time00
8852       logical lprn,ldone
8853
8854 C Set lprn=.true. for debugging
8855       lprn=.false.
8856 #ifdef MPI
8857       n_corr=0
8858       n_corr1=0
8859       if (nfgtasks.le.1) goto 30
8860       if (lprn) then
8861         write (iout,'(a)') 'Contact function values before RECEIVE:'
8862         do i=nnt,nct-2
8863           write (iout,'(2i3,50(1x,i2,f5.2))')
8864      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8865      &    j=1,num_cont_hb(i))
8866         enddo
8867         call flush(iout)
8868       endif
8869       do i=1,ntask_cont_from
8870         ncont_recv(i)=0
8871       enddo
8872       do i=1,ntask_cont_to
8873         ncont_sent(i)=0
8874       enddo
8875 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8876 c     & ntask_cont_to
8877 C Make the list of contacts to send to send to other procesors
8878 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8879 c      call flush(iout)
8880       do i=iturn3_start,iturn3_end
8881 c        write (iout,*) "make contact list turn3",i," num_cont",
8882 c     &    num_cont_hb(i)
8883         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8884       enddo
8885       do i=iturn4_start,iturn4_end
8886 c        write (iout,*) "make contact list turn4",i," num_cont",
8887 c     &   num_cont_hb(i)
8888         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8889       enddo
8890       do ii=1,nat_sent
8891         i=iat_sent(ii)
8892 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8893 c     &    num_cont_hb(i)
8894         do j=1,num_cont_hb(i)
8895         do k=1,4
8896           jjc=jcont_hb(j,i)
8897           iproc=iint_sent_local(k,jjc,ii)
8898 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8899           if (iproc.gt.0) then
8900             ncont_sent(iproc)=ncont_sent(iproc)+1
8901             nn=ncont_sent(iproc)
8902             zapas(1,nn,iproc)=i
8903             zapas(2,nn,iproc)=jjc
8904             zapas(3,nn,iproc)=facont_hb(j,i)
8905             zapas(4,nn,iproc)=ees0p(j,i)
8906             zapas(5,nn,iproc)=ees0m(j,i)
8907             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8908             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8909             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8910             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8911             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8912             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8913             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8914             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8915             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8916             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8917             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8918             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8919             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8920             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8921             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8922             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8923             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8924             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8925             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8926             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8927             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8928           endif
8929         enddo
8930         enddo
8931       enddo
8932       if (lprn) then
8933       write (iout,*)
8934      &  "Numbers of contacts to be sent to other processors",
8935      &  (ncont_sent(i),i=1,ntask_cont_to)
8936       write (iout,*) "Contacts sent"
8937       do ii=1,ntask_cont_to
8938         nn=ncont_sent(ii)
8939         iproc=itask_cont_to(ii)
8940         write (iout,*) nn," contacts to processor",iproc,
8941      &   " of CONT_TO_COMM group"
8942         do i=1,nn
8943           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8944         enddo
8945       enddo
8946       call flush(iout)
8947       endif
8948       CorrelType=477
8949       CorrelID=fg_rank+1
8950       CorrelType1=478
8951       CorrelID1=nfgtasks+fg_rank+1
8952       ireq=0
8953 C Receive the numbers of needed contacts from other processors
8954       do ii=1,ntask_cont_from
8955         iproc=itask_cont_from(ii)
8956         ireq=ireq+1
8957         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8958      &    FG_COMM,req(ireq),IERR)
8959       enddo
8960 c      write (iout,*) "IRECV ended"
8961 c      call flush(iout)
8962 C Send the number of contacts needed by other processors
8963       do ii=1,ntask_cont_to
8964         iproc=itask_cont_to(ii)
8965         ireq=ireq+1
8966         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8967      &    FG_COMM,req(ireq),IERR)
8968       enddo
8969 c      write (iout,*) "ISEND ended"
8970 c      write (iout,*) "number of requests (nn)",ireq
8971 c      call flush(iout)
8972       if (ireq.gt.0)
8973      &  call MPI_Waitall(ireq,req,status_array,ierr)
8974 c      write (iout,*)
8975 c     &  "Numbers of contacts to be received from other processors",
8976 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8977 c      call flush(iout)
8978 C Receive contacts
8979       ireq=0
8980       do ii=1,ntask_cont_from
8981         iproc=itask_cont_from(ii)
8982         nn=ncont_recv(ii)
8983 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8984 c     &   " of CONT_TO_COMM group"
8985 c        call flush(iout)
8986         if (nn.gt.0) then
8987           ireq=ireq+1
8988           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8989      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8990 c          write (iout,*) "ireq,req",ireq,req(ireq)
8991         endif
8992       enddo
8993 C Send the contacts to processors that need them
8994       do ii=1,ntask_cont_to
8995         iproc=itask_cont_to(ii)
8996         nn=ncont_sent(ii)
8997 c        write (iout,*) nn," contacts to processor",iproc,
8998 c     &   " of CONT_TO_COMM group"
8999         if (nn.gt.0) then
9000           ireq=ireq+1
9001           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9002      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9003 c          write (iout,*) "ireq,req",ireq,req(ireq)
9004 c          do i=1,nn
9005 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9006 c          enddo
9007         endif
9008       enddo
9009 c      write (iout,*) "number of requests (contacts)",ireq
9010 c      write (iout,*) "req",(req(i),i=1,4)
9011 c      call flush(iout)
9012       if (ireq.gt.0)
9013      & call MPI_Waitall(ireq,req,status_array,ierr)
9014       do iii=1,ntask_cont_from
9015         iproc=itask_cont_from(iii)
9016         nn=ncont_recv(iii)
9017         if (lprn) then
9018         write (iout,*) "Received",nn," contacts from processor",iproc,
9019      &   " of CONT_FROM_COMM group"
9020         call flush(iout)
9021         do i=1,nn
9022           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9023         enddo
9024         call flush(iout)
9025         endif
9026         do i=1,nn
9027           ii=zapas_recv(1,i,iii)
9028 c Flag the received contacts to prevent double-counting
9029           jj=-zapas_recv(2,i,iii)
9030 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9031 c          call flush(iout)
9032           nnn=num_cont_hb(ii)+1
9033           num_cont_hb(ii)=nnn
9034           jcont_hb(nnn,ii)=jj
9035           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9036           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9037           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9038           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9039           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9040           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9041           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9042           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9043           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9044           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9045           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9046           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9047           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9048           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9049           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9050           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9051           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9052           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9053           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9054           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9055           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9056           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9057           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9058           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9059         enddo
9060       enddo
9061       if (lprn) then
9062         write (iout,'(a)') 'Contact function values after receive:'
9063         do i=nnt,nct-2
9064           write (iout,'(2i3,50(1x,i3,f5.2))')
9065      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9066      &    j=1,num_cont_hb(i))
9067         enddo
9068         call flush(iout)
9069       endif
9070    30 continue
9071 #endif
9072       if (lprn) then
9073         write (iout,'(a)') 'Contact function values:'
9074         do i=nnt,nct-2
9075           write (iout,'(2i3,50(1x,i3,f5.2))')
9076      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9077      &    j=1,num_cont_hb(i))
9078         enddo
9079         call flush(iout)
9080       endif
9081       ecorr=0.0D0
9082 C Remove the loop below after debugging !!!
9083       do i=nnt,nct
9084         do j=1,3
9085           gradcorr(j,i)=0.0D0
9086           gradxorr(j,i)=0.0D0
9087         enddo
9088       enddo
9089 C Calculate the local-electrostatic correlation terms
9090       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9091         i1=i+1
9092         num_conti=num_cont_hb(i)
9093         num_conti1=num_cont_hb(i+1)
9094         do jj=1,num_conti
9095           j=jcont_hb(jj,i)
9096           jp=iabs(j)
9097           do kk=1,num_conti1
9098             j1=jcont_hb(kk,i1)
9099             jp1=iabs(j1)
9100 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9101 c     &         ' jj=',jj,' kk=',kk
9102 c            call flush(iout)
9103             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9104      &          .or. j.lt.0 .and. j1.gt.0) .and.
9105      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9106 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9107 C The system gains extra energy.
9108               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9109               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9110      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9111               n_corr=n_corr+1
9112             else if (j1.eq.j) then
9113 C Contacts I-J and I-(J+1) occur simultaneously.
9114 C The system loses extra energy.
9115 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9116             endif
9117           enddo ! kk
9118           do kk=1,num_conti
9119             j1=jcont_hb(kk,i)
9120 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9121 c    &         ' jj=',jj,' kk=',kk
9122             if (j1.eq.j+1) then
9123 C Contacts I-J and (I+1)-J occur simultaneously.
9124 C The system loses extra energy.
9125 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9126             endif ! j1==j+1
9127           enddo ! kk
9128         enddo ! jj
9129       enddo ! i
9130       return
9131       end
9132 c------------------------------------------------------------------------------
9133       subroutine add_hb_contact(ii,jj,itask)
9134       implicit real*8 (a-h,o-z)
9135       include "DIMENSIONS"
9136       include "COMMON.IOUNITS"
9137       integer max_cont
9138       integer max_dim
9139       parameter (max_cont=maxconts)
9140       parameter (max_dim=26)
9141       include "COMMON.CONTACTS"
9142       double precision zapas(max_dim,maxconts,max_fg_procs),
9143      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9144       common /przechowalnia/ zapas
9145       integer i,j,ii,jj,iproc,itask(4),nn
9146 c      write (iout,*) "itask",itask
9147       do i=1,2
9148         iproc=itask(i)
9149         if (iproc.gt.0) then
9150           do j=1,num_cont_hb(ii)
9151             jjc=jcont_hb(j,ii)
9152 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9153             if (jjc.eq.jj) then
9154               ncont_sent(iproc)=ncont_sent(iproc)+1
9155               nn=ncont_sent(iproc)
9156               zapas(1,nn,iproc)=ii
9157               zapas(2,nn,iproc)=jjc
9158               zapas(3,nn,iproc)=facont_hb(j,ii)
9159               zapas(4,nn,iproc)=ees0p(j,ii)
9160               zapas(5,nn,iproc)=ees0m(j,ii)
9161               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9162               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9163               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9164               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9165               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9166               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9167               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9168               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9169               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9170               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9171               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9172               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9173               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9174               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9175               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9176               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9177               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9178               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9179               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9180               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9181               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9182               exit
9183             endif
9184           enddo
9185         endif
9186       enddo
9187       return
9188       end
9189 c------------------------------------------------------------------------------
9190       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9191      &  n_corr1)
9192 C This subroutine calculates multi-body contributions to hydrogen-bonding
9193       implicit real*8 (a-h,o-z)
9194       include 'DIMENSIONS'
9195       include 'COMMON.IOUNITS'
9196 #ifdef MPI
9197       include "mpif.h"
9198       parameter (max_cont=maxconts)
9199       parameter (max_dim=70)
9200       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9201       double precision zapas(max_dim,maxconts,max_fg_procs),
9202      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9203       common /przechowalnia/ zapas
9204       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9205      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9206 #endif
9207       include 'COMMON.SETUP'
9208       include 'COMMON.FFIELD'
9209       include 'COMMON.DERIV'
9210       include 'COMMON.LOCAL'
9211       include 'COMMON.INTERACT'
9212       include 'COMMON.CONTACTS'
9213       include 'COMMON.CHAIN'
9214       include 'COMMON.CONTROL'
9215       include 'COMMON.SHIELD'
9216       double precision gx(3),gx1(3)
9217       integer num_cont_hb_old(maxres)
9218       logical lprn,ldone
9219       double precision eello4,eello5,eelo6,eello_turn6
9220       external eello4,eello5,eello6,eello_turn6
9221 C Set lprn=.true. for debugging
9222       lprn=.false.
9223       eturn6=0.0d0
9224 #ifdef MPI
9225       do i=1,nres
9226         num_cont_hb_old(i)=num_cont_hb(i)
9227       enddo
9228       n_corr=0
9229       n_corr1=0
9230       if (nfgtasks.le.1) goto 30
9231       if (lprn) then
9232         write (iout,'(a)') 'Contact function values before RECEIVE:'
9233         do i=nnt,nct-2
9234           write (iout,'(2i3,50(1x,i2,f5.2))')
9235      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9236      &    j=1,num_cont_hb(i))
9237         enddo
9238       endif
9239       do i=1,ntask_cont_from
9240         ncont_recv(i)=0
9241       enddo
9242       do i=1,ntask_cont_to
9243         ncont_sent(i)=0
9244       enddo
9245 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9246 c     & ntask_cont_to
9247 C Make the list of contacts to send to send to other procesors
9248       do i=iturn3_start,iturn3_end
9249 c        write (iout,*) "make contact list turn3",i," num_cont",
9250 c     &    num_cont_hb(i)
9251         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9252       enddo
9253       do i=iturn4_start,iturn4_end
9254 c        write (iout,*) "make contact list turn4",i," num_cont",
9255 c     &   num_cont_hb(i)
9256         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9257       enddo
9258       do ii=1,nat_sent
9259         i=iat_sent(ii)
9260 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9261 c     &    num_cont_hb(i)
9262         do j=1,num_cont_hb(i)
9263         do k=1,4
9264           jjc=jcont_hb(j,i)
9265           iproc=iint_sent_local(k,jjc,ii)
9266 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9267           if (iproc.ne.0) then
9268             ncont_sent(iproc)=ncont_sent(iproc)+1
9269             nn=ncont_sent(iproc)
9270             zapas(1,nn,iproc)=i
9271             zapas(2,nn,iproc)=jjc
9272             zapas(3,nn,iproc)=d_cont(j,i)
9273             ind=3
9274             do kk=1,3
9275               ind=ind+1
9276               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9277             enddo
9278             do kk=1,2
9279               do ll=1,2
9280                 ind=ind+1
9281                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9282               enddo
9283             enddo
9284             do jj=1,5
9285               do kk=1,3
9286                 do ll=1,2
9287                   do mm=1,2
9288                     ind=ind+1
9289                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9290                   enddo
9291                 enddo
9292               enddo
9293             enddo
9294           endif
9295         enddo
9296         enddo
9297       enddo
9298       if (lprn) then
9299       write (iout,*)
9300      &  "Numbers of contacts to be sent to other processors",
9301      &  (ncont_sent(i),i=1,ntask_cont_to)
9302       write (iout,*) "Contacts sent"
9303       do ii=1,ntask_cont_to
9304         nn=ncont_sent(ii)
9305         iproc=itask_cont_to(ii)
9306         write (iout,*) nn," contacts to processor",iproc,
9307      &   " of CONT_TO_COMM group"
9308         do i=1,nn
9309           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9310         enddo
9311       enddo
9312       call flush(iout)
9313       endif
9314       CorrelType=477
9315       CorrelID=fg_rank+1
9316       CorrelType1=478
9317       CorrelID1=nfgtasks+fg_rank+1
9318       ireq=0
9319 C Receive the numbers of needed contacts from other processors
9320       do ii=1,ntask_cont_from
9321         iproc=itask_cont_from(ii)
9322         ireq=ireq+1
9323         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9324      &    FG_COMM,req(ireq),IERR)
9325       enddo
9326 c      write (iout,*) "IRECV ended"
9327 c      call flush(iout)
9328 C Send the number of contacts needed by other processors
9329       do ii=1,ntask_cont_to
9330         iproc=itask_cont_to(ii)
9331         ireq=ireq+1
9332         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9333      &    FG_COMM,req(ireq),IERR)
9334       enddo
9335 c      write (iout,*) "ISEND ended"
9336 c      write (iout,*) "number of requests (nn)",ireq
9337 c      call flush(iout)
9338       if (ireq.gt.0)
9339      &  call MPI_Waitall(ireq,req,status_array,ierr)
9340 c      write (iout,*)
9341 c     &  "Numbers of contacts to be received from other processors",
9342 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9343 c      call flush(iout)
9344 C Receive contacts
9345       ireq=0
9346       do ii=1,ntask_cont_from
9347         iproc=itask_cont_from(ii)
9348         nn=ncont_recv(ii)
9349 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9350 c     &   " of CONT_TO_COMM group"
9351 c        call flush(iout)
9352         if (nn.gt.0) then
9353           ireq=ireq+1
9354           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9355      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9356 c          write (iout,*) "ireq,req",ireq,req(ireq)
9357         endif
9358       enddo
9359 C Send the contacts to processors that need them
9360       do ii=1,ntask_cont_to
9361         iproc=itask_cont_to(ii)
9362         nn=ncont_sent(ii)
9363 c        write (iout,*) nn," contacts to processor",iproc,
9364 c     &   " of CONT_TO_COMM group"
9365         if (nn.gt.0) then
9366           ireq=ireq+1
9367           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9368      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9369 c          write (iout,*) "ireq,req",ireq,req(ireq)
9370 c          do i=1,nn
9371 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9372 c          enddo
9373         endif
9374       enddo
9375 c      write (iout,*) "number of requests (contacts)",ireq
9376 c      write (iout,*) "req",(req(i),i=1,4)
9377 c      call flush(iout)
9378       if (ireq.gt.0)
9379      & call MPI_Waitall(ireq,req,status_array,ierr)
9380       do iii=1,ntask_cont_from
9381         iproc=itask_cont_from(iii)
9382         nn=ncont_recv(iii)
9383         if (lprn) then
9384         write (iout,*) "Received",nn," contacts from processor",iproc,
9385      &   " of CONT_FROM_COMM group"
9386         call flush(iout)
9387         do i=1,nn
9388           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9389         enddo
9390         call flush(iout)
9391         endif
9392         do i=1,nn
9393           ii=zapas_recv(1,i,iii)
9394 c Flag the received contacts to prevent double-counting
9395           jj=-zapas_recv(2,i,iii)
9396 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9397 c          call flush(iout)
9398           nnn=num_cont_hb(ii)+1
9399           num_cont_hb(ii)=nnn
9400           jcont_hb(nnn,ii)=jj
9401           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9402           ind=3
9403           do kk=1,3
9404             ind=ind+1
9405             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9406           enddo
9407           do kk=1,2
9408             do ll=1,2
9409               ind=ind+1
9410               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9411             enddo
9412           enddo
9413           do jj=1,5
9414             do kk=1,3
9415               do ll=1,2
9416                 do mm=1,2
9417                   ind=ind+1
9418                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9419                 enddo
9420               enddo
9421             enddo
9422           enddo
9423         enddo
9424       enddo
9425       if (lprn) then
9426         write (iout,'(a)') 'Contact function values after receive:'
9427         do i=nnt,nct-2
9428           write (iout,'(2i3,50(1x,i3,5f6.3))')
9429      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9430      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9431         enddo
9432         call flush(iout)
9433       endif
9434    30 continue
9435 #endif
9436       if (lprn) then
9437         write (iout,'(a)') 'Contact function values:'
9438         do i=nnt,nct-2
9439           write (iout,'(2i3,50(1x,i2,5f6.3))')
9440      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9441      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9442         enddo
9443       endif
9444       ecorr=0.0D0
9445       ecorr5=0.0d0
9446       ecorr6=0.0d0
9447 C Remove the loop below after debugging !!!
9448       do i=nnt,nct
9449         do j=1,3
9450           gradcorr(j,i)=0.0D0
9451           gradxorr(j,i)=0.0D0
9452         enddo
9453       enddo
9454 C Calculate the dipole-dipole interaction energies
9455       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9456       do i=iatel_s,iatel_e+1
9457         num_conti=num_cont_hb(i)
9458         do jj=1,num_conti
9459           j=jcont_hb(jj,i)
9460 #ifdef MOMENT
9461           call dipole(i,j,jj)
9462 #endif
9463         enddo
9464       enddo
9465       endif
9466 C Calculate the local-electrostatic correlation terms
9467 c                write (iout,*) "gradcorr5 in eello5 before loop"
9468 c                do iii=1,nres
9469 c                  write (iout,'(i5,3f10.5)')
9470 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9471 c                enddo
9472       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9473 c        write (iout,*) "corr loop i",i
9474         i1=i+1
9475         num_conti=num_cont_hb(i)
9476         num_conti1=num_cont_hb(i+1)
9477         do jj=1,num_conti
9478           j=jcont_hb(jj,i)
9479           jp=iabs(j)
9480           do kk=1,num_conti1
9481             j1=jcont_hb(kk,i1)
9482             jp1=iabs(j1)
9483 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9484 c     &         ' jj=',jj,' kk=',kk
9485 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9486             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9487      &          .or. j.lt.0 .and. j1.gt.0) .and.
9488      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9489 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9490 C The system gains extra energy.
9491               n_corr=n_corr+1
9492               sqd1=dsqrt(d_cont(jj,i))
9493               sqd2=dsqrt(d_cont(kk,i1))
9494               sred_geom = sqd1*sqd2
9495               IF (sred_geom.lt.cutoff_corr) THEN
9496                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9497      &            ekont,fprimcont)
9498 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9499 cd     &         ' jj=',jj,' kk=',kk
9500                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9501                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9502                 do l=1,3
9503                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9504                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9505                 enddo
9506                 n_corr1=n_corr1+1
9507 cd               write (iout,*) 'sred_geom=',sred_geom,
9508 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9509 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9510 cd               write (iout,*) "g_contij",g_contij
9511 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9512 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9513                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9514                 if (wcorr4.gt.0.0d0)
9515      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9516 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9517                   if (energy_dec.and.wcorr4.gt.0.0d0)
9518      1                 write (iout,'(a6,4i5,0pf7.3)')
9519      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9520 c                write (iout,*) "gradcorr5 before eello5"
9521 c                do iii=1,nres
9522 c                  write (iout,'(i5,3f10.5)')
9523 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9524 c                enddo
9525                 if (wcorr5.gt.0.0d0)
9526      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9527 c                write (iout,*) "gradcorr5 after eello5"
9528 c                do iii=1,nres
9529 c                  write (iout,'(i5,3f10.5)')
9530 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9531 c                enddo
9532                   if (energy_dec.and.wcorr5.gt.0.0d0)
9533      1                 write (iout,'(a6,4i5,0pf7.3)')
9534      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9535 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9536 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9537                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9538      &               .or. wturn6.eq.0.0d0))then
9539 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9540                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9541                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9542      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9543 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9544 cd     &            'ecorr6=',ecorr6
9545 cd                write (iout,'(4e15.5)') sred_geom,
9546 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9547 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9548 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9549                 else if (wturn6.gt.0.0d0
9550      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9551 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9552                   eturn6=eturn6+eello_turn6(i,jj,kk)
9553                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9554      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9555 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9556                 endif
9557               ENDIF
9558 1111          continue
9559             endif
9560           enddo ! kk
9561         enddo ! jj
9562       enddo ! i
9563       do i=1,nres
9564         num_cont_hb(i)=num_cont_hb_old(i)
9565       enddo
9566 c                write (iout,*) "gradcorr5 in eello5"
9567 c                do iii=1,nres
9568 c                  write (iout,'(i5,3f10.5)')
9569 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9570 c                enddo
9571       return
9572       end
9573 c------------------------------------------------------------------------------
9574       subroutine add_hb_contact_eello(ii,jj,itask)
9575       implicit real*8 (a-h,o-z)
9576       include "DIMENSIONS"
9577       include "COMMON.IOUNITS"
9578       integer max_cont
9579       integer max_dim
9580       parameter (max_cont=maxconts)
9581       parameter (max_dim=70)
9582       include "COMMON.CONTACTS"
9583       double precision zapas(max_dim,maxconts,max_fg_procs),
9584      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9585       common /przechowalnia/ zapas
9586       integer i,j,ii,jj,iproc,itask(4),nn
9587 c      write (iout,*) "itask",itask
9588       do i=1,2
9589         iproc=itask(i)
9590         if (iproc.gt.0) then
9591           do j=1,num_cont_hb(ii)
9592             jjc=jcont_hb(j,ii)
9593 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9594             if (jjc.eq.jj) then
9595               ncont_sent(iproc)=ncont_sent(iproc)+1
9596               nn=ncont_sent(iproc)
9597               zapas(1,nn,iproc)=ii
9598               zapas(2,nn,iproc)=jjc
9599               zapas(3,nn,iproc)=d_cont(j,ii)
9600               ind=3
9601               do kk=1,3
9602                 ind=ind+1
9603                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9604               enddo
9605               do kk=1,2
9606                 do ll=1,2
9607                   ind=ind+1
9608                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9609                 enddo
9610               enddo
9611               do jj=1,5
9612                 do kk=1,3
9613                   do ll=1,2
9614                     do mm=1,2
9615                       ind=ind+1
9616                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9617                     enddo
9618                   enddo
9619                 enddo
9620               enddo
9621               exit
9622             endif
9623           enddo
9624         endif
9625       enddo
9626       return
9627       end
9628 c------------------------------------------------------------------------------
9629       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9630       implicit real*8 (a-h,o-z)
9631       include 'DIMENSIONS'
9632       include 'COMMON.IOUNITS'
9633       include 'COMMON.DERIV'
9634       include 'COMMON.INTERACT'
9635       include 'COMMON.CONTACTS'
9636       include 'COMMON.SHIELD'
9637       include 'COMMON.CONTROL'
9638       double precision gx(3),gx1(3)
9639       logical lprn
9640       lprn=.false.
9641 C      print *,"wchodze",fac_shield(i),shield_mode
9642       eij=facont_hb(jj,i)
9643       ekl=facont_hb(kk,k)
9644       ees0pij=ees0p(jj,i)
9645       ees0pkl=ees0p(kk,k)
9646       ees0mij=ees0m(jj,i)
9647       ees0mkl=ees0m(kk,k)
9648       ekont=eij*ekl
9649       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9650 C*
9651 C     & fac_shield(i)**2*fac_shield(j)**2
9652 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9653 C Following 4 lines for diagnostics.
9654 cd    ees0pkl=0.0D0
9655 cd    ees0pij=1.0D0
9656 cd    ees0mkl=0.0D0
9657 cd    ees0mij=1.0D0
9658 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9659 c     & 'Contacts ',i,j,
9660 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9661 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9662 c     & 'gradcorr_long'
9663 C Calculate the multi-body contribution to energy.
9664 C      ecorr=ecorr+ekont*ees
9665 C Calculate multi-body contributions to the gradient.
9666       coeffpees0pij=coeffp*ees0pij
9667       coeffmees0mij=coeffm*ees0mij
9668       coeffpees0pkl=coeffp*ees0pkl
9669       coeffmees0mkl=coeffm*ees0mkl
9670       do ll=1,3
9671 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9672         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9673      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9674      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9675         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9676      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9677      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9678 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9679         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9680      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9681      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9682         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9683      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9684      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9685         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9686      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9687      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9688         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9689         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9690         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9691      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9692      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9693         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9694         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9695 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9696       enddo
9697 c      write (iout,*)
9698 cgrad      do m=i+1,j-1
9699 cgrad        do ll=1,3
9700 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9701 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9702 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9703 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9704 cgrad        enddo
9705 cgrad      enddo
9706 cgrad      do m=k+1,l-1
9707 cgrad        do ll=1,3
9708 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9709 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9710 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9711 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9712 cgrad        enddo
9713 cgrad      enddo
9714 c      write (iout,*) "ehbcorr",ekont*ees
9715 C      print *,ekont,ees,i,k
9716       ehbcorr=ekont*ees
9717 C now gradient over shielding
9718 C      return
9719       if (shield_mode.gt.0) then
9720        j=ees0plist(jj,i)
9721        l=ees0plist(kk,k)
9722 C        print *,i,j,fac_shield(i),fac_shield(j),
9723 C     &fac_shield(k),fac_shield(l)
9724         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9725      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9726           do ilist=1,ishield_list(i)
9727            iresshield=shield_list(ilist,i)
9728            do m=1,3
9729            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9730 C     &      *2.0
9731            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9732      &              rlocshield
9733      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9734             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9735      &+rlocshield
9736            enddo
9737           enddo
9738           do ilist=1,ishield_list(j)
9739            iresshield=shield_list(ilist,j)
9740            do m=1,3
9741            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9742 C     &     *2.0
9743            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9744      &              rlocshield
9745      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9746            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9747      &     +rlocshield
9748            enddo
9749           enddo
9750
9751           do ilist=1,ishield_list(k)
9752            iresshield=shield_list(ilist,k)
9753            do m=1,3
9754            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9755 C     &     *2.0
9756            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9757      &              rlocshield
9758      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9759            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9760      &     +rlocshield
9761            enddo
9762           enddo
9763           do ilist=1,ishield_list(l)
9764            iresshield=shield_list(ilist,l)
9765            do m=1,3
9766            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9767 C     &     *2.0
9768            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9769      &              rlocshield
9770      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9771            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9772      &     +rlocshield
9773            enddo
9774           enddo
9775 C          print *,gshieldx(m,iresshield)
9776           do m=1,3
9777             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9778      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9779             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9780      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9781             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9782      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9783             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9784      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9785
9786             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9787      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9788             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9789      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9790             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9791      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9792             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9793      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9794
9795            enddo
9796       endif
9797       endif
9798       return
9799       end
9800 #ifdef MOMENT
9801 C---------------------------------------------------------------------------
9802       subroutine dipole(i,j,jj)
9803       implicit real*8 (a-h,o-z)
9804       include 'DIMENSIONS'
9805       include 'COMMON.IOUNITS'
9806       include 'COMMON.CHAIN'
9807       include 'COMMON.FFIELD'
9808       include 'COMMON.DERIV'
9809       include 'COMMON.INTERACT'
9810       include 'COMMON.CONTACTS'
9811       include 'COMMON.TORSION'
9812       include 'COMMON.VAR'
9813       include 'COMMON.GEO'
9814       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9815      &  auxmat(2,2)
9816       iti1 = itortyp(itype(i+1))
9817       if (j.lt.nres-1) then
9818         itj1 = itype2loc(itype(j+1))
9819       else
9820         itj1=nloctyp
9821       endif
9822       do iii=1,2
9823         dipi(iii,1)=Ub2(iii,i)
9824         dipderi(iii)=Ub2der(iii,i)
9825         dipi(iii,2)=b1(iii,i+1)
9826         dipj(iii,1)=Ub2(iii,j)
9827         dipderj(iii)=Ub2der(iii,j)
9828         dipj(iii,2)=b1(iii,j+1)
9829       enddo
9830       kkk=0
9831       do iii=1,2
9832         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9833         do jjj=1,2
9834           kkk=kkk+1
9835           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9836         enddo
9837       enddo
9838       do kkk=1,5
9839         do lll=1,3
9840           mmm=0
9841           do iii=1,2
9842             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9843      &        auxvec(1))
9844             do jjj=1,2
9845               mmm=mmm+1
9846               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9847             enddo
9848           enddo
9849         enddo
9850       enddo
9851       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9852       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9853       do iii=1,2
9854         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9855       enddo
9856       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9857       do iii=1,2
9858         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9859       enddo
9860       return
9861       end
9862 #endif
9863 C---------------------------------------------------------------------------
9864       subroutine calc_eello(i,j,k,l,jj,kk)
9865 C
9866 C This subroutine computes matrices and vectors needed to calculate
9867 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9868 C
9869       implicit real*8 (a-h,o-z)
9870       include 'DIMENSIONS'
9871       include 'COMMON.IOUNITS'
9872       include 'COMMON.CHAIN'
9873       include 'COMMON.DERIV'
9874       include 'COMMON.INTERACT'
9875       include 'COMMON.CONTACTS'
9876       include 'COMMON.TORSION'
9877       include 'COMMON.VAR'
9878       include 'COMMON.GEO'
9879       include 'COMMON.FFIELD'
9880       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9881      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9882       logical lprn
9883       common /kutas/ lprn
9884 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9885 cd     & ' jj=',jj,' kk=',kk
9886 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9887 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9888 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9889       do iii=1,2
9890         do jjj=1,2
9891           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9892           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9893         enddo
9894       enddo
9895       call transpose2(aa1(1,1),aa1t(1,1))
9896       call transpose2(aa2(1,1),aa2t(1,1))
9897       do kkk=1,5
9898         do lll=1,3
9899           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9900      &      aa1tder(1,1,lll,kkk))
9901           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9902      &      aa2tder(1,1,lll,kkk))
9903         enddo
9904       enddo
9905       if (l.eq.j+1) then
9906 C parallel orientation of the two CA-CA-CA frames.
9907         if (i.gt.1) then
9908           iti=itype2loc(itype(i))
9909         else
9910           iti=nloctyp
9911         endif
9912         itk1=itype2loc(itype(k+1))
9913         itj=itype2loc(itype(j))
9914         if (l.lt.nres-1) then
9915           itl1=itype2loc(itype(l+1))
9916         else
9917           itl1=nloctyp
9918         endif
9919 C A1 kernel(j+1) A2T
9920 cd        do iii=1,2
9921 cd          write (iout,'(3f10.5,5x,3f10.5)')
9922 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9923 cd        enddo
9924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9925      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9926      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9927 C Following matrices are needed only for 6-th order cumulants
9928         IF (wcorr6.gt.0.0d0) THEN
9929         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9930      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9931      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9932         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9933      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9934      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9935      &   ADtEAderx(1,1,1,1,1,1))
9936         lprn=.false.
9937         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9938      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9939      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9940      &   ADtEA1derx(1,1,1,1,1,1))
9941         ENDIF
9942 C End 6-th order cumulants
9943 cd        lprn=.false.
9944 cd        if (lprn) then
9945 cd        write (2,*) 'In calc_eello6'
9946 cd        do iii=1,2
9947 cd          write (2,*) 'iii=',iii
9948 cd          do kkk=1,5
9949 cd            write (2,*) 'kkk=',kkk
9950 cd            do jjj=1,2
9951 cd              write (2,'(3(2f10.5),5x)')
9952 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9953 cd            enddo
9954 cd          enddo
9955 cd        enddo
9956 cd        endif
9957         call transpose2(EUgder(1,1,k),auxmat(1,1))
9958         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9959         call transpose2(EUg(1,1,k),auxmat(1,1))
9960         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9961         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9962 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9963 c    in theta; to be sriten later.
9964 c#ifdef NEWCORR
9965 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9966 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9967 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9968 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9969 c#endif
9970         do iii=1,2
9971           do kkk=1,5
9972             do lll=1,3
9973               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9974      &          EAEAderx(1,1,lll,kkk,iii,1))
9975             enddo
9976           enddo
9977         enddo
9978 C A1T kernel(i+1) A2
9979         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9980      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9981      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9982 C Following matrices are needed only for 6-th order cumulants
9983         IF (wcorr6.gt.0.0d0) THEN
9984         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9985      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9986      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9987         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9988      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9989      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9990      &   ADtEAderx(1,1,1,1,1,2))
9991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9992      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9993      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9994      &   ADtEA1derx(1,1,1,1,1,2))
9995         ENDIF
9996 C End 6-th order cumulants
9997         call transpose2(EUgder(1,1,l),auxmat(1,1))
9998         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9999         call transpose2(EUg(1,1,l),auxmat(1,1))
10000         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10001         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10002         do iii=1,2
10003           do kkk=1,5
10004             do lll=1,3
10005               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10006      &          EAEAderx(1,1,lll,kkk,iii,2))
10007             enddo
10008           enddo
10009         enddo
10010 C AEAb1 and AEAb2
10011 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10012 C They are needed only when the fifth- or the sixth-order cumulants are
10013 C indluded.
10014         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10015         call transpose2(AEA(1,1,1),auxmat(1,1))
10016         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10017         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10018         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10019         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10020         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10021         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10022         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10023         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10024         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10025         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10026         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10027         call transpose2(AEA(1,1,2),auxmat(1,1))
10028         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10029         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10030         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10031         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10032         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10033         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10034         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10035         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10036         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10037         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10038         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10039 C Calculate the Cartesian derivatives of the vectors.
10040         do iii=1,2
10041           do kkk=1,5
10042             do lll=1,3
10043               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10044               call matvec2(auxmat(1,1),b1(1,i),
10045      &          AEAb1derx(1,lll,kkk,iii,1,1))
10046               call matvec2(auxmat(1,1),Ub2(1,i),
10047      &          AEAb2derx(1,lll,kkk,iii,1,1))
10048               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10049      &          AEAb1derx(1,lll,kkk,iii,2,1))
10050               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10051      &          AEAb2derx(1,lll,kkk,iii,2,1))
10052               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10053               call matvec2(auxmat(1,1),b1(1,j),
10054      &          AEAb1derx(1,lll,kkk,iii,1,2))
10055               call matvec2(auxmat(1,1),Ub2(1,j),
10056      &          AEAb2derx(1,lll,kkk,iii,1,2))
10057               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10058      &          AEAb1derx(1,lll,kkk,iii,2,2))
10059               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10060      &          AEAb2derx(1,lll,kkk,iii,2,2))
10061             enddo
10062           enddo
10063         enddo
10064         ENDIF
10065 C End vectors
10066       else
10067 C Antiparallel orientation of the two CA-CA-CA frames.
10068         if (i.gt.1) then
10069           iti=itype2loc(itype(i))
10070         else
10071           iti=nloctyp
10072         endif
10073         itk1=itype2loc(itype(k+1))
10074         itl=itype2loc(itype(l))
10075         itj=itype2loc(itype(j))
10076         if (j.lt.nres-1) then
10077           itj1=itype2loc(itype(j+1))
10078         else
10079           itj1=nloctyp
10080         endif
10081 C A2 kernel(j-1)T A1T
10082         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10083      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10084      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10085 C Following matrices are needed only for 6-th order cumulants
10086         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10087      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10088         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10089      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10090      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10091         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10092      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10093      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10094      &   ADtEAderx(1,1,1,1,1,1))
10095         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10096      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10097      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10098      &   ADtEA1derx(1,1,1,1,1,1))
10099         ENDIF
10100 C End 6-th order cumulants
10101         call transpose2(EUgder(1,1,k),auxmat(1,1))
10102         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10103         call transpose2(EUg(1,1,k),auxmat(1,1))
10104         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10105         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10106         do iii=1,2
10107           do kkk=1,5
10108             do lll=1,3
10109               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10110      &          EAEAderx(1,1,lll,kkk,iii,1))
10111             enddo
10112           enddo
10113         enddo
10114 C A2T kernel(i+1)T A1
10115         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10116      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10117      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10118 C Following matrices are needed only for 6-th order cumulants
10119         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10120      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10121         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10122      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10123      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10124         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10125      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10126      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10127      &   ADtEAderx(1,1,1,1,1,2))
10128         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10129      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10130      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10131      &   ADtEA1derx(1,1,1,1,1,2))
10132         ENDIF
10133 C End 6-th order cumulants
10134         call transpose2(EUgder(1,1,j),auxmat(1,1))
10135         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10136         call transpose2(EUg(1,1,j),auxmat(1,1))
10137         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10138         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10139         do iii=1,2
10140           do kkk=1,5
10141             do lll=1,3
10142               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10143      &          EAEAderx(1,1,lll,kkk,iii,2))
10144             enddo
10145           enddo
10146         enddo
10147 C AEAb1 and AEAb2
10148 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10149 C They are needed only when the fifth- or the sixth-order cumulants are
10150 C indluded.
10151         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10152      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10153         call transpose2(AEA(1,1,1),auxmat(1,1))
10154         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10155         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10156         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10157         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10158         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10159         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10160         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10161         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10162         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10163         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10164         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10165         call transpose2(AEA(1,1,2),auxmat(1,1))
10166         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10167         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10168         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10169         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10170         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10171         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10172         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10173         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10174         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10175         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10176         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10177 C Calculate the Cartesian derivatives of the vectors.
10178         do iii=1,2
10179           do kkk=1,5
10180             do lll=1,3
10181               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10182               call matvec2(auxmat(1,1),b1(1,i),
10183      &          AEAb1derx(1,lll,kkk,iii,1,1))
10184               call matvec2(auxmat(1,1),Ub2(1,i),
10185      &          AEAb2derx(1,lll,kkk,iii,1,1))
10186               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10187      &          AEAb1derx(1,lll,kkk,iii,2,1))
10188               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10189      &          AEAb2derx(1,lll,kkk,iii,2,1))
10190               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10191               call matvec2(auxmat(1,1),b1(1,l),
10192      &          AEAb1derx(1,lll,kkk,iii,1,2))
10193               call matvec2(auxmat(1,1),Ub2(1,l),
10194      &          AEAb2derx(1,lll,kkk,iii,1,2))
10195               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10196      &          AEAb1derx(1,lll,kkk,iii,2,2))
10197               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10198      &          AEAb2derx(1,lll,kkk,iii,2,2))
10199             enddo
10200           enddo
10201         enddo
10202         ENDIF
10203 C End vectors
10204       endif
10205       return
10206       end
10207 C---------------------------------------------------------------------------
10208       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10209      &  KK,KKderg,AKA,AKAderg,AKAderx)
10210       implicit none
10211       integer nderg
10212       logical transp
10213       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10214      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10215      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10216       integer iii,kkk,lll
10217       integer jjj,mmm
10218       logical lprn
10219       common /kutas/ lprn
10220       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10221       do iii=1,nderg
10222         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10223      &    AKAderg(1,1,iii))
10224       enddo
10225 cd      if (lprn) write (2,*) 'In kernel'
10226       do kkk=1,5
10227 cd        if (lprn) write (2,*) 'kkk=',kkk
10228         do lll=1,3
10229           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10230      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10231 cd          if (lprn) then
10232 cd            write (2,*) 'lll=',lll
10233 cd            write (2,*) 'iii=1'
10234 cd            do jjj=1,2
10235 cd              write (2,'(3(2f10.5),5x)')
10236 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10237 cd            enddo
10238 cd          endif
10239           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10240      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10241 cd          if (lprn) then
10242 cd            write (2,*) 'lll=',lll
10243 cd            write (2,*) 'iii=2'
10244 cd            do jjj=1,2
10245 cd              write (2,'(3(2f10.5),5x)')
10246 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10247 cd            enddo
10248 cd          endif
10249         enddo
10250       enddo
10251       return
10252       end
10253 C---------------------------------------------------------------------------
10254       double precision function eello4(i,j,k,l,jj,kk)
10255       implicit real*8 (a-h,o-z)
10256       include 'DIMENSIONS'
10257       include 'COMMON.IOUNITS'
10258       include 'COMMON.CHAIN'
10259       include 'COMMON.DERIV'
10260       include 'COMMON.INTERACT'
10261       include 'COMMON.CONTACTS'
10262       include 'COMMON.TORSION'
10263       include 'COMMON.VAR'
10264       include 'COMMON.GEO'
10265       double precision pizda(2,2),ggg1(3),ggg2(3)
10266 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10267 cd        eello4=0.0d0
10268 cd        return
10269 cd      endif
10270 cd      print *,'eello4:',i,j,k,l,jj,kk
10271 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10272 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10273 cold      eij=facont_hb(jj,i)
10274 cold      ekl=facont_hb(kk,k)
10275 cold      ekont=eij*ekl
10276       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10277 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10278       gcorr_loc(k-1)=gcorr_loc(k-1)
10279      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10280       if (l.eq.j+1) then
10281         gcorr_loc(l-1)=gcorr_loc(l-1)
10282      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10283 C Al 4/16/16: Derivatives in theta, to be added later.
10284 c#ifdef NEWCORR
10285 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10286 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10287 c#endif
10288       else
10289         gcorr_loc(j-1)=gcorr_loc(j-1)
10290      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10291 c#ifdef NEWCORR
10292 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10293 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10294 c#endif
10295       endif
10296       do iii=1,2
10297         do kkk=1,5
10298           do lll=1,3
10299             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10300      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10301 cd            derx(lll,kkk,iii)=0.0d0
10302           enddo
10303         enddo
10304       enddo
10305 cd      gcorr_loc(l-1)=0.0d0
10306 cd      gcorr_loc(j-1)=0.0d0
10307 cd      gcorr_loc(k-1)=0.0d0
10308 cd      eel4=1.0d0
10309 cd      write (iout,*)'Contacts have occurred for peptide groups',
10310 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10311 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10312       if (j.lt.nres-1) then
10313         j1=j+1
10314         j2=j-1
10315       else
10316         j1=j-1
10317         j2=j-2
10318       endif
10319       if (l.lt.nres-1) then
10320         l1=l+1
10321         l2=l-1
10322       else
10323         l1=l-1
10324         l2=l-2
10325       endif
10326       do ll=1,3
10327 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10328 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10329         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10330         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10331 cgrad        ghalf=0.5d0*ggg1(ll)
10332         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10333         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10334         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10335         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10336         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10337         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10338 cgrad        ghalf=0.5d0*ggg2(ll)
10339         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10340         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10341         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10342         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10343         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10344         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10345       enddo
10346 cgrad      do m=i+1,j-1
10347 cgrad        do ll=1,3
10348 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10349 cgrad        enddo
10350 cgrad      enddo
10351 cgrad      do m=k+1,l-1
10352 cgrad        do ll=1,3
10353 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10354 cgrad        enddo
10355 cgrad      enddo
10356 cgrad      do m=i+2,j2
10357 cgrad        do ll=1,3
10358 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10359 cgrad        enddo
10360 cgrad      enddo
10361 cgrad      do m=k+2,l2
10362 cgrad        do ll=1,3
10363 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10364 cgrad        enddo
10365 cgrad      enddo
10366 cd      do iii=1,nres-3
10367 cd        write (2,*) iii,gcorr_loc(iii)
10368 cd      enddo
10369       eello4=ekont*eel4
10370 cd      write (2,*) 'ekont',ekont
10371 cd      write (iout,*) 'eello4',ekont*eel4
10372       return
10373       end
10374 C---------------------------------------------------------------------------
10375       double precision function eello5(i,j,k,l,jj,kk)
10376       implicit real*8 (a-h,o-z)
10377       include 'DIMENSIONS'
10378       include 'COMMON.IOUNITS'
10379       include 'COMMON.CHAIN'
10380       include 'COMMON.DERIV'
10381       include 'COMMON.INTERACT'
10382       include 'COMMON.CONTACTS'
10383       include 'COMMON.TORSION'
10384       include 'COMMON.VAR'
10385       include 'COMMON.GEO'
10386       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10387       double precision ggg1(3),ggg2(3)
10388 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10389 C                                                                              C
10390 C                            Parallel chains                                   C
10391 C                                                                              C
10392 C          o             o                   o             o                   C
10393 C         /l\           / \             \   / \           / \   /              C
10394 C        /   \         /   \             \ /   \         /   \ /               C
10395 C       j| o |l1       | o |              o| o |         | o |o                C
10396 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10397 C      \i/   \         /   \ /             /   \         /   \                 C
10398 C       o    k1             o                                                  C
10399 C         (I)          (II)                (III)          (IV)                 C
10400 C                                                                              C
10401 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10402 C                                                                              C
10403 C                            Antiparallel chains                               C
10404 C                                                                              C
10405 C          o             o                   o             o                   C
10406 C         /j\           / \             \   / \           / \   /              C
10407 C        /   \         /   \             \ /   \         /   \ /               C
10408 C      j1| o |l        | o |              o| o |         | o |o                C
10409 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10410 C      \i/   \         /   \ /             /   \         /   \                 C
10411 C       o     k1            o                                                  C
10412 C         (I)          (II)                (III)          (IV)                 C
10413 C                                                                              C
10414 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10415 C                                                                              C
10416 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10417 C                                                                              C
10418 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10419 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10420 cd        eello5=0.0d0
10421 cd        return
10422 cd      endif
10423 cd      write (iout,*)
10424 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10425 cd     &   ' and',k,l
10426       itk=itype2loc(itype(k))
10427       itl=itype2loc(itype(l))
10428       itj=itype2loc(itype(j))
10429       eello5_1=0.0d0
10430       eello5_2=0.0d0
10431       eello5_3=0.0d0
10432       eello5_4=0.0d0
10433 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10434 cd     &   eel5_3_num,eel5_4_num)
10435       do iii=1,2
10436         do kkk=1,5
10437           do lll=1,3
10438             derx(lll,kkk,iii)=0.0d0
10439           enddo
10440         enddo
10441       enddo
10442 cd      eij=facont_hb(jj,i)
10443 cd      ekl=facont_hb(kk,k)
10444 cd      ekont=eij*ekl
10445 cd      write (iout,*)'Contacts have occurred for peptide groups',
10446 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10447 cd      goto 1111
10448 C Contribution from the graph I.
10449 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10450 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10451       call transpose2(EUg(1,1,k),auxmat(1,1))
10452       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10453       vv(1)=pizda(1,1)-pizda(2,2)
10454       vv(2)=pizda(1,2)+pizda(2,1)
10455       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10456      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10457 C Explicit gradient in virtual-dihedral angles.
10458       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10459      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10460      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10461       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10462       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10463       vv(1)=pizda(1,1)-pizda(2,2)
10464       vv(2)=pizda(1,2)+pizda(2,1)
10465       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10466      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10467      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10468       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10469       vv(1)=pizda(1,1)-pizda(2,2)
10470       vv(2)=pizda(1,2)+pizda(2,1)
10471       if (l.eq.j+1) then
10472         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10473      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10474      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10475       else
10476         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10477      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10478      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10479       endif
10480 C Cartesian gradient
10481       do iii=1,2
10482         do kkk=1,5
10483           do lll=1,3
10484             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10485      &        pizda(1,1))
10486             vv(1)=pizda(1,1)-pizda(2,2)
10487             vv(2)=pizda(1,2)+pizda(2,1)
10488             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10489      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10490      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10491           enddo
10492         enddo
10493       enddo
10494 c      goto 1112
10495 c1111  continue
10496 C Contribution from graph II
10497       call transpose2(EE(1,1,k),auxmat(1,1))
10498       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10499       vv(1)=pizda(1,1)+pizda(2,2)
10500       vv(2)=pizda(2,1)-pizda(1,2)
10501       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10502      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10503 C Explicit gradient in virtual-dihedral angles.
10504       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10505      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10506       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10507       vv(1)=pizda(1,1)+pizda(2,2)
10508       vv(2)=pizda(2,1)-pizda(1,2)
10509       if (l.eq.j+1) then
10510         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10511      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10512      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10513       else
10514         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10515      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10516      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10517       endif
10518 C Cartesian gradient
10519       do iii=1,2
10520         do kkk=1,5
10521           do lll=1,3
10522             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10523      &        pizda(1,1))
10524             vv(1)=pizda(1,1)+pizda(2,2)
10525             vv(2)=pizda(2,1)-pizda(1,2)
10526             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10527      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10528      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10529           enddo
10530         enddo
10531       enddo
10532 cd      goto 1112
10533 cd1111  continue
10534       if (l.eq.j+1) then
10535 cd        goto 1110
10536 C Parallel orientation
10537 C Contribution from graph III
10538         call transpose2(EUg(1,1,l),auxmat(1,1))
10539         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10540         vv(1)=pizda(1,1)-pizda(2,2)
10541         vv(2)=pizda(1,2)+pizda(2,1)
10542         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10543      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10544 C Explicit gradient in virtual-dihedral angles.
10545         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10546      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10547      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10548         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10549         vv(1)=pizda(1,1)-pizda(2,2)
10550         vv(2)=pizda(1,2)+pizda(2,1)
10551         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10552      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10553      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10554         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10555         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10556         vv(1)=pizda(1,1)-pizda(2,2)
10557         vv(2)=pizda(1,2)+pizda(2,1)
10558         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10559      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10560      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10561 C Cartesian gradient
10562         do iii=1,2
10563           do kkk=1,5
10564             do lll=1,3
10565               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10566      &          pizda(1,1))
10567               vv(1)=pizda(1,1)-pizda(2,2)
10568               vv(2)=pizda(1,2)+pizda(2,1)
10569               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10570      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10571      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10572             enddo
10573           enddo
10574         enddo
10575 cd        goto 1112
10576 C Contribution from graph IV
10577 cd1110    continue
10578         call transpose2(EE(1,1,l),auxmat(1,1))
10579         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10580         vv(1)=pizda(1,1)+pizda(2,2)
10581         vv(2)=pizda(2,1)-pizda(1,2)
10582         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10583      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10584 C Explicit gradient in virtual-dihedral angles.
10585         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10586      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10587         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10588         vv(1)=pizda(1,1)+pizda(2,2)
10589         vv(2)=pizda(2,1)-pizda(1,2)
10590         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10591      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10592      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10593 C Cartesian gradient
10594         do iii=1,2
10595           do kkk=1,5
10596             do lll=1,3
10597               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10598      &          pizda(1,1))
10599               vv(1)=pizda(1,1)+pizda(2,2)
10600               vv(2)=pizda(2,1)-pizda(1,2)
10601               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10602      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10603      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10604             enddo
10605           enddo
10606         enddo
10607       else
10608 C Antiparallel orientation
10609 C Contribution from graph III
10610 c        goto 1110
10611         call transpose2(EUg(1,1,j),auxmat(1,1))
10612         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10613         vv(1)=pizda(1,1)-pizda(2,2)
10614         vv(2)=pizda(1,2)+pizda(2,1)
10615         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10616      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10617 C Explicit gradient in virtual-dihedral angles.
10618         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10619      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10620      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10621         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10622         vv(1)=pizda(1,1)-pizda(2,2)
10623         vv(2)=pizda(1,2)+pizda(2,1)
10624         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10625      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10626      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10627         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10628         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10629         vv(1)=pizda(1,1)-pizda(2,2)
10630         vv(2)=pizda(1,2)+pizda(2,1)
10631         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10632      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10633      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10634 C Cartesian gradient
10635         do iii=1,2
10636           do kkk=1,5
10637             do lll=1,3
10638               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10639      &          pizda(1,1))
10640               vv(1)=pizda(1,1)-pizda(2,2)
10641               vv(2)=pizda(1,2)+pizda(2,1)
10642               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10643      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10644      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10645             enddo
10646           enddo
10647         enddo
10648 cd        goto 1112
10649 C Contribution from graph IV
10650 1110    continue
10651         call transpose2(EE(1,1,j),auxmat(1,1))
10652         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10653         vv(1)=pizda(1,1)+pizda(2,2)
10654         vv(2)=pizda(2,1)-pizda(1,2)
10655         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10656      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10657 C Explicit gradient in virtual-dihedral angles.
10658         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10659      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10660         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10661         vv(1)=pizda(1,1)+pizda(2,2)
10662         vv(2)=pizda(2,1)-pizda(1,2)
10663         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10664      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10665      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10666 C Cartesian gradient
10667         do iii=1,2
10668           do kkk=1,5
10669             do lll=1,3
10670               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10671      &          pizda(1,1))
10672               vv(1)=pizda(1,1)+pizda(2,2)
10673               vv(2)=pizda(2,1)-pizda(1,2)
10674               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10675      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10676      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10677             enddo
10678           enddo
10679         enddo
10680       endif
10681 1112  continue
10682       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10683 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10684 cd        write (2,*) 'ijkl',i,j,k,l
10685 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10686 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10687 cd      endif
10688 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10689 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10690 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10691 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10692       if (j.lt.nres-1) then
10693         j1=j+1
10694         j2=j-1
10695       else
10696         j1=j-1
10697         j2=j-2
10698       endif
10699       if (l.lt.nres-1) then
10700         l1=l+1
10701         l2=l-1
10702       else
10703         l1=l-1
10704         l2=l-2
10705       endif
10706 cd      eij=1.0d0
10707 cd      ekl=1.0d0
10708 cd      ekont=1.0d0
10709 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10710 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10711 C        summed up outside the subrouine as for the other subroutines
10712 C        handling long-range interactions. The old code is commented out
10713 C        with "cgrad" to keep track of changes.
10714       do ll=1,3
10715 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10716 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10717         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10718         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10719 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10720 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10721 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10722 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10723 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10724 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10725 c     &   gradcorr5ij,
10726 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10727 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10728 cgrad        ghalf=0.5d0*ggg1(ll)
10729 cd        ghalf=0.0d0
10730         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10731         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10732         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10733         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10734         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10735         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10736 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10737 cgrad        ghalf=0.5d0*ggg2(ll)
10738 cd        ghalf=0.0d0
10739         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10740         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10741         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10742         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10743         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10744         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10745       enddo
10746 cd      goto 1112
10747 cgrad      do m=i+1,j-1
10748 cgrad        do ll=1,3
10749 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10750 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10751 cgrad        enddo
10752 cgrad      enddo
10753 cgrad      do m=k+1,l-1
10754 cgrad        do ll=1,3
10755 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10756 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10757 cgrad        enddo
10758 cgrad      enddo
10759 c1112  continue
10760 cgrad      do m=i+2,j2
10761 cgrad        do ll=1,3
10762 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10763 cgrad        enddo
10764 cgrad      enddo
10765 cgrad      do m=k+2,l2
10766 cgrad        do ll=1,3
10767 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10768 cgrad        enddo
10769 cgrad      enddo
10770 cd      do iii=1,nres-3
10771 cd        write (2,*) iii,g_corr5_loc(iii)
10772 cd      enddo
10773       eello5=ekont*eel5
10774 cd      write (2,*) 'ekont',ekont
10775 cd      write (iout,*) 'eello5',ekont*eel5
10776       return
10777       end
10778 c--------------------------------------------------------------------------
10779       double precision function eello6(i,j,k,l,jj,kk)
10780       implicit real*8 (a-h,o-z)
10781       include 'DIMENSIONS'
10782       include 'COMMON.IOUNITS'
10783       include 'COMMON.CHAIN'
10784       include 'COMMON.DERIV'
10785       include 'COMMON.INTERACT'
10786       include 'COMMON.CONTACTS'
10787       include 'COMMON.TORSION'
10788       include 'COMMON.VAR'
10789       include 'COMMON.GEO'
10790       include 'COMMON.FFIELD'
10791       double precision ggg1(3),ggg2(3)
10792 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10793 cd        eello6=0.0d0
10794 cd        return
10795 cd      endif
10796 cd      write (iout,*)
10797 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10798 cd     &   ' and',k,l
10799       eello6_1=0.0d0
10800       eello6_2=0.0d0
10801       eello6_3=0.0d0
10802       eello6_4=0.0d0
10803       eello6_5=0.0d0
10804       eello6_6=0.0d0
10805 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10806 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10807       do iii=1,2
10808         do kkk=1,5
10809           do lll=1,3
10810             derx(lll,kkk,iii)=0.0d0
10811           enddo
10812         enddo
10813       enddo
10814 cd      eij=facont_hb(jj,i)
10815 cd      ekl=facont_hb(kk,k)
10816 cd      ekont=eij*ekl
10817 cd      eij=1.0d0
10818 cd      ekl=1.0d0
10819 cd      ekont=1.0d0
10820       if (l.eq.j+1) then
10821         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10822         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10823         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10824         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10825         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10826         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10827       else
10828         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10829         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10830         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10831         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10832         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10833           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10834         else
10835           eello6_5=0.0d0
10836         endif
10837         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10838       endif
10839 C If turn contributions are considered, they will be handled separately.
10840       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10841 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10842 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10843 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10844 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10845 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10846 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10847 cd      goto 1112
10848       if (j.lt.nres-1) then
10849         j1=j+1
10850         j2=j-1
10851       else
10852         j1=j-1
10853         j2=j-2
10854       endif
10855       if (l.lt.nres-1) then
10856         l1=l+1
10857         l2=l-1
10858       else
10859         l1=l-1
10860         l2=l-2
10861       endif
10862       do ll=1,3
10863 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10864 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10865 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10866 cgrad        ghalf=0.5d0*ggg1(ll)
10867 cd        ghalf=0.0d0
10868         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10869         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10870         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10871         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10872         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10873         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10874         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10875         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10876 cgrad        ghalf=0.5d0*ggg2(ll)
10877 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10878 cd        ghalf=0.0d0
10879         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10880         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10881         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10882         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10883         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10884         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10885       enddo
10886 cd      goto 1112
10887 cgrad      do m=i+1,j-1
10888 cgrad        do ll=1,3
10889 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10890 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10891 cgrad        enddo
10892 cgrad      enddo
10893 cgrad      do m=k+1,l-1
10894 cgrad        do ll=1,3
10895 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10896 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10897 cgrad        enddo
10898 cgrad      enddo
10899 cgrad1112  continue
10900 cgrad      do m=i+2,j2
10901 cgrad        do ll=1,3
10902 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10903 cgrad        enddo
10904 cgrad      enddo
10905 cgrad      do m=k+2,l2
10906 cgrad        do ll=1,3
10907 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10908 cgrad        enddo
10909 cgrad      enddo
10910 cd      do iii=1,nres-3
10911 cd        write (2,*) iii,g_corr6_loc(iii)
10912 cd      enddo
10913       eello6=ekont*eel6
10914 cd      write (2,*) 'ekont',ekont
10915 cd      write (iout,*) 'eello6',ekont*eel6
10916       return
10917       end
10918 c--------------------------------------------------------------------------
10919       double precision function eello6_graph1(i,j,k,l,imat,swap)
10920       implicit real*8 (a-h,o-z)
10921       include 'DIMENSIONS'
10922       include 'COMMON.IOUNITS'
10923       include 'COMMON.CHAIN'
10924       include 'COMMON.DERIV'
10925       include 'COMMON.INTERACT'
10926       include 'COMMON.CONTACTS'
10927       include 'COMMON.TORSION'
10928       include 'COMMON.VAR'
10929       include 'COMMON.GEO'
10930       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10931       logical swap
10932       logical lprn
10933       common /kutas/ lprn
10934 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10935 C                                                                              C
10936 C      Parallel       Antiparallel                                             C
10937 C                                                                              C
10938 C          o             o                                                     C
10939 C         /l\           /j\                                                    C
10940 C        /   \         /   \                                                   C
10941 C       /| o |         | o |\                                                  C
10942 C     \ j|/k\|  /   \  |/k\|l /                                                C
10943 C      \ /   \ /     \ /   \ /                                                 C
10944 C       o     o       o     o                                                  C
10945 C       i             i                                                        C
10946 C                                                                              C
10947 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10948       itk=itype2loc(itype(k))
10949       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10950       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10951       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10952       call transpose2(EUgC(1,1,k),auxmat(1,1))
10953       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10954       vv1(1)=pizda1(1,1)-pizda1(2,2)
10955       vv1(2)=pizda1(1,2)+pizda1(2,1)
10956       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10957       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10958       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10959       s5=scalar2(vv(1),Dtobr2(1,i))
10960 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10961       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10962       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10963      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10964      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10965      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10966      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10967      & +scalar2(vv(1),Dtobr2der(1,i)))
10968       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10969       vv1(1)=pizda1(1,1)-pizda1(2,2)
10970       vv1(2)=pizda1(1,2)+pizda1(2,1)
10971       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10972       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10973       if (l.eq.j+1) then
10974         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10975      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10976      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10977      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10978      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10979       else
10980         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10981      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10982      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10983      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10984      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10985       endif
10986       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10987       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10988       vv1(1)=pizda1(1,1)-pizda1(2,2)
10989       vv1(2)=pizda1(1,2)+pizda1(2,1)
10990       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10991      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10992      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10993      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10994       do iii=1,2
10995         if (swap) then
10996           ind=3-iii
10997         else
10998           ind=iii
10999         endif
11000         do kkk=1,5
11001           do lll=1,3
11002             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11003             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11004             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11005             call transpose2(EUgC(1,1,k),auxmat(1,1))
11006             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11007      &        pizda1(1,1))
11008             vv1(1)=pizda1(1,1)-pizda1(2,2)
11009             vv1(2)=pizda1(1,2)+pizda1(2,1)
11010             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11011             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11012      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11013             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11014      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11015             s5=scalar2(vv(1),Dtobr2(1,i))
11016             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11017           enddo
11018         enddo
11019       enddo
11020       return
11021       end
11022 c----------------------------------------------------------------------------
11023       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11024       implicit real*8 (a-h,o-z)
11025       include 'DIMENSIONS'
11026       include 'COMMON.IOUNITS'
11027       include 'COMMON.CHAIN'
11028       include 'COMMON.DERIV'
11029       include 'COMMON.INTERACT'
11030       include 'COMMON.CONTACTS'
11031       include 'COMMON.TORSION'
11032       include 'COMMON.VAR'
11033       include 'COMMON.GEO'
11034       logical swap
11035       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11036      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11037       logical lprn
11038       common /kutas/ lprn
11039 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11040 C                                                                              C
11041 C      Parallel       Antiparallel                                             C
11042 C                                                                              C
11043 C          o             o                                                     C
11044 C     \   /l\           /j\   /                                                C
11045 C      \ /   \         /   \ /                                                 C
11046 C       o| o |         | o |o                                                  C
11047 C     \ j|/k\|      \  |/k\|l                                                  C
11048 C      \ /   \       \ /   \                                                   C
11049 C       o             o                                                        C
11050 C       i             i                                                        C
11051 C                                                                              C
11052 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11053 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11054 C AL 7/4/01 s1 would occur in the sixth-order moment,
11055 C           but not in a cluster cumulant
11056 #ifdef MOMENT
11057       s1=dip(1,jj,i)*dip(1,kk,k)
11058 #endif
11059       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11060       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11061       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11062       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11063       call transpose2(EUg(1,1,k),auxmat(1,1))
11064       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11065       vv(1)=pizda(1,1)-pizda(2,2)
11066       vv(2)=pizda(1,2)+pizda(2,1)
11067       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11068 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11069 #ifdef MOMENT
11070       eello6_graph2=-(s1+s2+s3+s4)
11071 #else
11072       eello6_graph2=-(s2+s3+s4)
11073 #endif
11074 c      eello6_graph2=-s3
11075 C Derivatives in gamma(i-1)
11076       if (i.gt.1) then
11077 #ifdef MOMENT
11078         s1=dipderg(1,jj,i)*dip(1,kk,k)
11079 #endif
11080         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11081         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11082         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11083         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11084 #ifdef MOMENT
11085         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11086 #else
11087         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11088 #endif
11089 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11090       endif
11091 C Derivatives in gamma(k-1)
11092 #ifdef MOMENT
11093       s1=dip(1,jj,i)*dipderg(1,kk,k)
11094 #endif
11095       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11096       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11097       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11098       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11099       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11100       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11101       vv(1)=pizda(1,1)-pizda(2,2)
11102       vv(2)=pizda(1,2)+pizda(2,1)
11103       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11104 #ifdef MOMENT
11105       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11106 #else
11107       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11108 #endif
11109 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11110 C Derivatives in gamma(j-1) or gamma(l-1)
11111       if (j.gt.1) then
11112 #ifdef MOMENT
11113         s1=dipderg(3,jj,i)*dip(1,kk,k)
11114 #endif
11115         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11116         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11117         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11118         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11119         vv(1)=pizda(1,1)-pizda(2,2)
11120         vv(2)=pizda(1,2)+pizda(2,1)
11121         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11122 #ifdef MOMENT
11123         if (swap) then
11124           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11125         else
11126           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11127         endif
11128 #endif
11129         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11130 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11131       endif
11132 C Derivatives in gamma(l-1) or gamma(j-1)
11133       if (l.gt.1) then
11134 #ifdef MOMENT
11135         s1=dip(1,jj,i)*dipderg(3,kk,k)
11136 #endif
11137         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11138         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11139         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11140         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11141         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11142         vv(1)=pizda(1,1)-pizda(2,2)
11143         vv(2)=pizda(1,2)+pizda(2,1)
11144         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11145 #ifdef MOMENT
11146         if (swap) then
11147           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11148         else
11149           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11150         endif
11151 #endif
11152         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11153 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11154       endif
11155 C Cartesian derivatives.
11156       if (lprn) then
11157         write (2,*) 'In eello6_graph2'
11158         do iii=1,2
11159           write (2,*) 'iii=',iii
11160           do kkk=1,5
11161             write (2,*) 'kkk=',kkk
11162             do jjj=1,2
11163               write (2,'(3(2f10.5),5x)')
11164      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11165             enddo
11166           enddo
11167         enddo
11168       endif
11169       do iii=1,2
11170         do kkk=1,5
11171           do lll=1,3
11172 #ifdef MOMENT
11173             if (iii.eq.1) then
11174               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11175             else
11176               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11177             endif
11178 #endif
11179             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11180      &        auxvec(1))
11181             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11182             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11183      &        auxvec(1))
11184             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11185             call transpose2(EUg(1,1,k),auxmat(1,1))
11186             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11187      &        pizda(1,1))
11188             vv(1)=pizda(1,1)-pizda(2,2)
11189             vv(2)=pizda(1,2)+pizda(2,1)
11190             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11191 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11192 #ifdef MOMENT
11193             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11194 #else
11195             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11196 #endif
11197             if (swap) then
11198               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11199             else
11200               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11201             endif
11202           enddo
11203         enddo
11204       enddo
11205       return
11206       end
11207 c----------------------------------------------------------------------------
11208       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11209       implicit real*8 (a-h,o-z)
11210       include 'DIMENSIONS'
11211       include 'COMMON.IOUNITS'
11212       include 'COMMON.CHAIN'
11213       include 'COMMON.DERIV'
11214       include 'COMMON.INTERACT'
11215       include 'COMMON.CONTACTS'
11216       include 'COMMON.TORSION'
11217       include 'COMMON.VAR'
11218       include 'COMMON.GEO'
11219       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11220       logical swap
11221 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11222 C                                                                              C
11223 C      Parallel       Antiparallel                                             C
11224 C                                                                              C
11225 C          o             o                                                     C
11226 C         /l\   /   \   /j\                                                    C
11227 C        /   \ /     \ /   \                                                   C
11228 C       /| o |o       o| o |\                                                  C
11229 C       j|/k\|  /      |/k\|l /                                                C
11230 C        /   \ /       /   \ /                                                 C
11231 C       /     o       /     o                                                  C
11232 C       i             i                                                        C
11233 C                                                                              C
11234 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11235 C
11236 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11237 C           energy moment and not to the cluster cumulant.
11238       iti=itortyp(itype(i))
11239       if (j.lt.nres-1) then
11240         itj1=itype2loc(itype(j+1))
11241       else
11242         itj1=nloctyp
11243       endif
11244       itk=itype2loc(itype(k))
11245       itk1=itype2loc(itype(k+1))
11246       if (l.lt.nres-1) then
11247         itl1=itype2loc(itype(l+1))
11248       else
11249         itl1=nloctyp
11250       endif
11251 #ifdef MOMENT
11252       s1=dip(4,jj,i)*dip(4,kk,k)
11253 #endif
11254       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11255       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11256       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11257       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11258       call transpose2(EE(1,1,k),auxmat(1,1))
11259       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11260       vv(1)=pizda(1,1)+pizda(2,2)
11261       vv(2)=pizda(2,1)-pizda(1,2)
11262       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11263 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11264 cd     & "sum",-(s2+s3+s4)
11265 #ifdef MOMENT
11266       eello6_graph3=-(s1+s2+s3+s4)
11267 #else
11268       eello6_graph3=-(s2+s3+s4)
11269 #endif
11270 c      eello6_graph3=-s4
11271 C Derivatives in gamma(k-1)
11272       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11273       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11274       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11275       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11276 C Derivatives in gamma(l-1)
11277       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11278       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11279       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11280       vv(1)=pizda(1,1)+pizda(2,2)
11281       vv(2)=pizda(2,1)-pizda(1,2)
11282       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11283       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11284 C Cartesian derivatives.
11285       do iii=1,2
11286         do kkk=1,5
11287           do lll=1,3
11288 #ifdef MOMENT
11289             if (iii.eq.1) then
11290               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11291             else
11292               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11293             endif
11294 #endif
11295             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11296      &        auxvec(1))
11297             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11298             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11299      &        auxvec(1))
11300             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11301             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11302      &        pizda(1,1))
11303             vv(1)=pizda(1,1)+pizda(2,2)
11304             vv(2)=pizda(2,1)-pizda(1,2)
11305             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11306 #ifdef MOMENT
11307             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11308 #else
11309             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11310 #endif
11311             if (swap) then
11312               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11313             else
11314               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11315             endif
11316 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11317           enddo
11318         enddo
11319       enddo
11320       return
11321       end
11322 c----------------------------------------------------------------------------
11323       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11324       implicit real*8 (a-h,o-z)
11325       include 'DIMENSIONS'
11326       include 'COMMON.IOUNITS'
11327       include 'COMMON.CHAIN'
11328       include 'COMMON.DERIV'
11329       include 'COMMON.INTERACT'
11330       include 'COMMON.CONTACTS'
11331       include 'COMMON.TORSION'
11332       include 'COMMON.VAR'
11333       include 'COMMON.GEO'
11334       include 'COMMON.FFIELD'
11335       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11336      & auxvec1(2),auxmat1(2,2)
11337       logical swap
11338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11339 C                                                                              C
11340 C      Parallel       Antiparallel                                             C
11341 C                                                                              C
11342 C          o             o                                                     C
11343 C         /l\   /   \   /j\                                                    C
11344 C        /   \ /     \ /   \                                                   C
11345 C       /| o |o       o| o |\                                                  C
11346 C     \ j|/k\|      \  |/k\|l                                                  C
11347 C      \ /   \       \ /   \                                                   C
11348 C       o     \       o     \                                                  C
11349 C       i             i                                                        C
11350 C                                                                              C
11351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11352 C
11353 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11354 C           energy moment and not to the cluster cumulant.
11355 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11356       iti=itype2loc(itype(i))
11357       itj=itype2loc(itype(j))
11358       if (j.lt.nres-1) then
11359         itj1=itype2loc(itype(j+1))
11360       else
11361         itj1=nloctyp
11362       endif
11363       itk=itype2loc(itype(k))
11364       if (k.lt.nres-1) then
11365         itk1=itype2loc(itype(k+1))
11366       else
11367         itk1=nloctyp
11368       endif
11369       itl=itype2loc(itype(l))
11370       if (l.lt.nres-1) then
11371         itl1=itype2loc(itype(l+1))
11372       else
11373         itl1=nloctyp
11374       endif
11375 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11376 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11377 cd     & ' itl',itl,' itl1',itl1
11378 #ifdef MOMENT
11379       if (imat.eq.1) then
11380         s1=dip(3,jj,i)*dip(3,kk,k)
11381       else
11382         s1=dip(2,jj,j)*dip(2,kk,l)
11383       endif
11384 #endif
11385       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11386       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11387       if (j.eq.l+1) then
11388         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11389         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11390       else
11391         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11392         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11393       endif
11394       call transpose2(EUg(1,1,k),auxmat(1,1))
11395       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11396       vv(1)=pizda(1,1)-pizda(2,2)
11397       vv(2)=pizda(2,1)+pizda(1,2)
11398       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11399 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11400 #ifdef MOMENT
11401       eello6_graph4=-(s1+s2+s3+s4)
11402 #else
11403       eello6_graph4=-(s2+s3+s4)
11404 #endif
11405 C Derivatives in gamma(i-1)
11406       if (i.gt.1) then
11407 #ifdef MOMENT
11408         if (imat.eq.1) then
11409           s1=dipderg(2,jj,i)*dip(3,kk,k)
11410         else
11411           s1=dipderg(4,jj,j)*dip(2,kk,l)
11412         endif
11413 #endif
11414         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11415         if (j.eq.l+1) then
11416           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11417           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11418         else
11419           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11420           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11421         endif
11422         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11423         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11424 cd          write (2,*) 'turn6 derivatives'
11425 #ifdef MOMENT
11426           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11427 #else
11428           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11429 #endif
11430         else
11431 #ifdef MOMENT
11432           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11433 #else
11434           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11435 #endif
11436         endif
11437       endif
11438 C Derivatives in gamma(k-1)
11439 #ifdef MOMENT
11440       if (imat.eq.1) then
11441         s1=dip(3,jj,i)*dipderg(2,kk,k)
11442       else
11443         s1=dip(2,jj,j)*dipderg(4,kk,l)
11444       endif
11445 #endif
11446       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11447       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11448       if (j.eq.l+1) then
11449         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11450         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11451       else
11452         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11453         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11454       endif
11455       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11456       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11457       vv(1)=pizda(1,1)-pizda(2,2)
11458       vv(2)=pizda(2,1)+pizda(1,2)
11459       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11460       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11461 #ifdef MOMENT
11462         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11463 #else
11464         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11465 #endif
11466       else
11467 #ifdef MOMENT
11468         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11469 #else
11470         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11471 #endif
11472       endif
11473 C Derivatives in gamma(j-1) or gamma(l-1)
11474       if (l.eq.j+1 .and. l.gt.1) then
11475         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11476         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11477         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11478         vv(1)=pizda(1,1)-pizda(2,2)
11479         vv(2)=pizda(2,1)+pizda(1,2)
11480         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11481         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11482       else if (j.gt.1) then
11483         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11484         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11485         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11486         vv(1)=pizda(1,1)-pizda(2,2)
11487         vv(2)=pizda(2,1)+pizda(1,2)
11488         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11489         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11490           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11491         else
11492           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11493         endif
11494       endif
11495 C Cartesian derivatives.
11496       do iii=1,2
11497         do kkk=1,5
11498           do lll=1,3
11499 #ifdef MOMENT
11500             if (iii.eq.1) then
11501               if (imat.eq.1) then
11502                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11503               else
11504                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11505               endif
11506             else
11507               if (imat.eq.1) then
11508                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11509               else
11510                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11511               endif
11512             endif
11513 #endif
11514             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11515      &        auxvec(1))
11516             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11517             if (j.eq.l+1) then
11518               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11519      &          b1(1,j+1),auxvec(1))
11520               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11521             else
11522               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11523      &          b1(1,l+1),auxvec(1))
11524               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11525             endif
11526             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11527      &        pizda(1,1))
11528             vv(1)=pizda(1,1)-pizda(2,2)
11529             vv(2)=pizda(2,1)+pizda(1,2)
11530             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11531             if (swap) then
11532               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11533 #ifdef MOMENT
11534                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11535      &             -(s1+s2+s4)
11536 #else
11537                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11538      &             -(s2+s4)
11539 #endif
11540                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11541               else
11542 #ifdef MOMENT
11543                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11544 #else
11545                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11546 #endif
11547                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11548               endif
11549             else
11550 #ifdef MOMENT
11551               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11552 #else
11553               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11554 #endif
11555               if (l.eq.j+1) then
11556                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11557               else
11558                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11559               endif
11560             endif
11561           enddo
11562         enddo
11563       enddo
11564       return
11565       end
11566 c----------------------------------------------------------------------------
11567       double precision function eello_turn6(i,jj,kk)
11568       implicit real*8 (a-h,o-z)
11569       include 'DIMENSIONS'
11570       include 'COMMON.IOUNITS'
11571       include 'COMMON.CHAIN'
11572       include 'COMMON.DERIV'
11573       include 'COMMON.INTERACT'
11574       include 'COMMON.CONTACTS'
11575       include 'COMMON.TORSION'
11576       include 'COMMON.VAR'
11577       include 'COMMON.GEO'
11578       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11579      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11580      &  ggg1(3),ggg2(3)
11581       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11582      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11583 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11584 C           the respective energy moment and not to the cluster cumulant.
11585       s1=0.0d0
11586       s8=0.0d0
11587       s13=0.0d0
11588 c
11589       eello_turn6=0.0d0
11590       j=i+4
11591       k=i+1
11592       l=i+3
11593       iti=itype2loc(itype(i))
11594       itk=itype2loc(itype(k))
11595       itk1=itype2loc(itype(k+1))
11596       itl=itype2loc(itype(l))
11597       itj=itype2loc(itype(j))
11598 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11599 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11600 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11601 cd        eello6=0.0d0
11602 cd        return
11603 cd      endif
11604 cd      write (iout,*)
11605 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11606 cd     &   ' and',k,l
11607 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11608       do iii=1,2
11609         do kkk=1,5
11610           do lll=1,3
11611             derx_turn(lll,kkk,iii)=0.0d0
11612           enddo
11613         enddo
11614       enddo
11615 cd      eij=1.0d0
11616 cd      ekl=1.0d0
11617 cd      ekont=1.0d0
11618       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11619 cd      eello6_5=0.0d0
11620 cd      write (2,*) 'eello6_5',eello6_5
11621 #ifdef MOMENT
11622       call transpose2(AEA(1,1,1),auxmat(1,1))
11623       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11624       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11625       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11626 #endif
11627       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11628       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11629       s2 = scalar2(b1(1,k),vtemp1(1))
11630 #ifdef MOMENT
11631       call transpose2(AEA(1,1,2),atemp(1,1))
11632       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11633       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11634       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11635 #endif
11636       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11637       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11638       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11639 #ifdef MOMENT
11640       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11641       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11642       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11643       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11644       ss13 = scalar2(b1(1,k),vtemp4(1))
11645       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11646 #endif
11647 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11648 c      s1=0.0d0
11649 c      s2=0.0d0
11650 c      s8=0.0d0
11651 c      s12=0.0d0
11652 c      s13=0.0d0
11653       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11654 C Derivatives in gamma(i+2)
11655       s1d =0.0d0
11656       s8d =0.0d0
11657 #ifdef MOMENT
11658       call transpose2(AEA(1,1,1),auxmatd(1,1))
11659       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11660       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11661       call transpose2(AEAderg(1,1,2),atempd(1,1))
11662       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11663       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11664 #endif
11665       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11666       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11667       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11668 c      s1d=0.0d0
11669 c      s2d=0.0d0
11670 c      s8d=0.0d0
11671 c      s12d=0.0d0
11672 c      s13d=0.0d0
11673       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11674 C Derivatives in gamma(i+3)
11675 #ifdef MOMENT
11676       call transpose2(AEA(1,1,1),auxmatd(1,1))
11677       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11678       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11679       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11680 #endif
11681       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11682       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11683       s2d = scalar2(b1(1,k),vtemp1d(1))
11684 #ifdef MOMENT
11685       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11686       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11687 #endif
11688       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11689 #ifdef MOMENT
11690       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11691       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11692       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11693 #endif
11694 c      s1d=0.0d0
11695 c      s2d=0.0d0
11696 c      s8d=0.0d0
11697 c      s12d=0.0d0
11698 c      s13d=0.0d0
11699 #ifdef MOMENT
11700       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11701      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11702 #else
11703       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11704      &               -0.5d0*ekont*(s2d+s12d)
11705 #endif
11706 C Derivatives in gamma(i+4)
11707       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11708       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11709       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11710 #ifdef MOMENT
11711       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11712       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11713       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11714 #endif
11715 c      s1d=0.0d0
11716 c      s2d=0.0d0
11717 c      s8d=0.0d0
11718 C      s12d=0.0d0
11719 c      s13d=0.0d0
11720 #ifdef MOMENT
11721       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11722 #else
11723       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11724 #endif
11725 C Derivatives in gamma(i+5)
11726 #ifdef MOMENT
11727       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11728       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11729       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11730 #endif
11731       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11732       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11733       s2d = scalar2(b1(1,k),vtemp1d(1))
11734 #ifdef MOMENT
11735       call transpose2(AEA(1,1,2),atempd(1,1))
11736       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11737       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11738 #endif
11739       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11740       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11741 #ifdef MOMENT
11742       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11743       ss13d = scalar2(b1(1,k),vtemp4d(1))
11744       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11745 #endif
11746 c      s1d=0.0d0
11747 c      s2d=0.0d0
11748 c      s8d=0.0d0
11749 c      s12d=0.0d0
11750 c      s13d=0.0d0
11751 #ifdef MOMENT
11752       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11753      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11754 #else
11755       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11756      &               -0.5d0*ekont*(s2d+s12d)
11757 #endif
11758 C Cartesian derivatives
11759       do iii=1,2
11760         do kkk=1,5
11761           do lll=1,3
11762 #ifdef MOMENT
11763             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11764             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11765             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11766 #endif
11767             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11768             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11769      &          vtemp1d(1))
11770             s2d = scalar2(b1(1,k),vtemp1d(1))
11771 #ifdef MOMENT
11772             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11773             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11774             s8d = -(atempd(1,1)+atempd(2,2))*
11775      &           scalar2(cc(1,1,l),vtemp2(1))
11776 #endif
11777             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11778      &           auxmatd(1,1))
11779             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11780             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11781 c      s1d=0.0d0
11782 c      s2d=0.0d0
11783 c      s8d=0.0d0
11784 c      s12d=0.0d0
11785 c      s13d=0.0d0
11786 #ifdef MOMENT
11787             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11788      &        - 0.5d0*(s1d+s2d)
11789 #else
11790             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11791      &        - 0.5d0*s2d
11792 #endif
11793 #ifdef MOMENT
11794             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11795      &        - 0.5d0*(s8d+s12d)
11796 #else
11797             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11798      &        - 0.5d0*s12d
11799 #endif
11800           enddo
11801         enddo
11802       enddo
11803 #ifdef MOMENT
11804       do kkk=1,5
11805         do lll=1,3
11806           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11807      &      achuj_tempd(1,1))
11808           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11809           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11810           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11811           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11812           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11813      &      vtemp4d(1))
11814           ss13d = scalar2(b1(1,k),vtemp4d(1))
11815           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11816           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11817         enddo
11818       enddo
11819 #endif
11820 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11821 cd     &  16*eel_turn6_num
11822 cd      goto 1112
11823       if (j.lt.nres-1) then
11824         j1=j+1
11825         j2=j-1
11826       else
11827         j1=j-1
11828         j2=j-2
11829       endif
11830       if (l.lt.nres-1) then
11831         l1=l+1
11832         l2=l-1
11833       else
11834         l1=l-1
11835         l2=l-2
11836       endif
11837       do ll=1,3
11838 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11839 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11840 cgrad        ghalf=0.5d0*ggg1(ll)
11841 cd        ghalf=0.0d0
11842         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11843         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11844         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11845      &    +ekont*derx_turn(ll,2,1)
11846         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11847         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11848      &    +ekont*derx_turn(ll,4,1)
11849         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11850         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11851         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11852 cgrad        ghalf=0.5d0*ggg2(ll)
11853 cd        ghalf=0.0d0
11854         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11855      &    +ekont*derx_turn(ll,2,2)
11856         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11857         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11858      &    +ekont*derx_turn(ll,4,2)
11859         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11860         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11861         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11862       enddo
11863 cd      goto 1112
11864 cgrad      do m=i+1,j-1
11865 cgrad        do ll=1,3
11866 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11867 cgrad        enddo
11868 cgrad      enddo
11869 cgrad      do m=k+1,l-1
11870 cgrad        do ll=1,3
11871 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11872 cgrad        enddo
11873 cgrad      enddo
11874 cgrad1112  continue
11875 cgrad      do m=i+2,j2
11876 cgrad        do ll=1,3
11877 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11878 cgrad        enddo
11879 cgrad      enddo
11880 cgrad      do m=k+2,l2
11881 cgrad        do ll=1,3
11882 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11883 cgrad        enddo
11884 cgrad      enddo
11885 cd      do iii=1,nres-3
11886 cd        write (2,*) iii,g_corr6_loc(iii)
11887 cd      enddo
11888       eello_turn6=ekont*eel_turn6
11889 cd      write (2,*) 'ekont',ekont
11890 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11891       return
11892       end
11893
11894 C-----------------------------------------------------------------------------
11895       double precision function scalar(u,v)
11896 !DIR$ INLINEALWAYS scalar
11897 #ifndef OSF
11898 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11899 #endif
11900       implicit none
11901       double precision u(3),v(3)
11902 cd      double precision sc
11903 cd      integer i
11904 cd      sc=0.0d0
11905 cd      do i=1,3
11906 cd        sc=sc+u(i)*v(i)
11907 cd      enddo
11908 cd      scalar=sc
11909
11910       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11911       return
11912       end
11913 crc-------------------------------------------------
11914       SUBROUTINE MATVEC2(A1,V1,V2)
11915 !DIR$ INLINEALWAYS MATVEC2
11916 #ifndef OSF
11917 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11918 #endif
11919       implicit real*8 (a-h,o-z)
11920       include 'DIMENSIONS'
11921       DIMENSION A1(2,2),V1(2),V2(2)
11922 c      DO 1 I=1,2
11923 c        VI=0.0
11924 c        DO 3 K=1,2
11925 c    3     VI=VI+A1(I,K)*V1(K)
11926 c        Vaux(I)=VI
11927 c    1 CONTINUE
11928
11929       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11930       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11931
11932       v2(1)=vaux1
11933       v2(2)=vaux2
11934       END
11935 C---------------------------------------
11936       SUBROUTINE MATMAT2(A1,A2,A3)
11937 #ifndef OSF
11938 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11939 #endif
11940       implicit real*8 (a-h,o-z)
11941       include 'DIMENSIONS'
11942       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11943 c      DIMENSION AI3(2,2)
11944 c        DO  J=1,2
11945 c          A3IJ=0.0
11946 c          DO K=1,2
11947 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11948 c          enddo
11949 c          A3(I,J)=A3IJ
11950 c       enddo
11951 c      enddo
11952
11953       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11954       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11955       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11956       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11957
11958       A3(1,1)=AI3_11
11959       A3(2,1)=AI3_21
11960       A3(1,2)=AI3_12
11961       A3(2,2)=AI3_22
11962       END
11963
11964 c-------------------------------------------------------------------------
11965       double precision function scalar2(u,v)
11966 !DIR$ INLINEALWAYS scalar2
11967       implicit none
11968       double precision u(2),v(2)
11969       double precision sc
11970       integer i
11971       scalar2=u(1)*v(1)+u(2)*v(2)
11972       return
11973       end
11974
11975 C-----------------------------------------------------------------------------
11976
11977       subroutine transpose2(a,at)
11978 !DIR$ INLINEALWAYS transpose2
11979 #ifndef OSF
11980 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11981 #endif
11982       implicit none
11983       double precision a(2,2),at(2,2)
11984       at(1,1)=a(1,1)
11985       at(1,2)=a(2,1)
11986       at(2,1)=a(1,2)
11987       at(2,2)=a(2,2)
11988       return
11989       end
11990 c--------------------------------------------------------------------------
11991       subroutine transpose(n,a,at)
11992       implicit none
11993       integer n,i,j
11994       double precision a(n,n),at(n,n)
11995       do i=1,n
11996         do j=1,n
11997           at(j,i)=a(i,j)
11998         enddo
11999       enddo
12000       return
12001       end
12002 C---------------------------------------------------------------------------
12003       subroutine prodmat3(a1,a2,kk,transp,prod)
12004 !DIR$ INLINEALWAYS prodmat3
12005 #ifndef OSF
12006 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12007 #endif
12008       implicit none
12009       integer i,j
12010       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12011       logical transp
12012 crc      double precision auxmat(2,2),prod_(2,2)
12013
12014       if (transp) then
12015 crc        call transpose2(kk(1,1),auxmat(1,1))
12016 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12017 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12018
12019            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12020      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12021            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12022      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12023            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12024      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12025            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12026      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12027
12028       else
12029 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12030 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12031
12032            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12033      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12034            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12035      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12036            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12037      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12038            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12039      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12040
12041       endif
12042 c      call transpose2(a2(1,1),a2t(1,1))
12043
12044 crc      print *,transp
12045 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12046 crc      print *,((prod(i,j),i=1,2),j=1,2)
12047
12048       return
12049       end
12050 CCC----------------------------------------------
12051       subroutine Eliptransfer(eliptran)
12052       implicit real*8 (a-h,o-z)
12053       include 'DIMENSIONS'
12054       include 'COMMON.GEO'
12055       include 'COMMON.VAR'
12056       include 'COMMON.LOCAL'
12057       include 'COMMON.CHAIN'
12058       include 'COMMON.DERIV'
12059       include 'COMMON.NAMES'
12060       include 'COMMON.INTERACT'
12061       include 'COMMON.IOUNITS'
12062       include 'COMMON.CALC'
12063       include 'COMMON.CONTROL'
12064       include 'COMMON.SPLITELE'
12065       include 'COMMON.SBRIDGE'
12066 C this is done by Adasko
12067 C      print *,"wchodze"
12068 C structure of box:
12069 C      water
12070 C--bordliptop-- buffore starts
12071 C--bufliptop--- here true lipid starts
12072 C      lipid
12073 C--buflipbot--- lipid ends buffore starts
12074 C--bordlipbot--buffore ends
12075       eliptran=0.0
12076       do i=ilip_start,ilip_end
12077 C       do i=1,1
12078         if (itype(i).eq.ntyp1) cycle
12079
12080         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12081         if (positi.le.0.0) positi=positi+boxzsize
12082 C        print *,i
12083 C first for peptide groups
12084 c for each residue check if it is in lipid or lipid water border area
12085        if ((positi.gt.bordlipbot)
12086      &.and.(positi.lt.bordliptop)) then
12087 C the energy transfer exist
12088         if (positi.lt.buflipbot) then
12089 C what fraction I am in
12090          fracinbuf=1.0d0-
12091      &        ((positi-bordlipbot)/lipbufthick)
12092 C lipbufthick is thickenes of lipid buffore
12093          sslip=sscalelip(fracinbuf)
12094          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12095          eliptran=eliptran+sslip*pepliptran
12096          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12097          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12098 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12099
12100 C        print *,"doing sccale for lower part"
12101 C         print *,i,sslip,fracinbuf,ssgradlip
12102         elseif (positi.gt.bufliptop) then
12103          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12104          sslip=sscalelip(fracinbuf)
12105          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12106          eliptran=eliptran+sslip*pepliptran
12107          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12108          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12109 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12110 C          print *, "doing sscalefor top part"
12111 C         print *,i,sslip,fracinbuf,ssgradlip
12112         else
12113          eliptran=eliptran+pepliptran
12114 C         print *,"I am in true lipid"
12115         endif
12116 C       else
12117 C       eliptran=elpitran+0.0 ! I am in water
12118        endif
12119        enddo
12120 C       print *, "nic nie bylo w lipidzie?"
12121 C now multiply all by the peptide group transfer factor
12122 C       eliptran=eliptran*pepliptran
12123 C now the same for side chains
12124 CV       do i=1,1
12125        do i=ilip_start,ilip_end
12126         if (itype(i).eq.ntyp1) cycle
12127         positi=(mod(c(3,i+nres),boxzsize))
12128         if (positi.le.0) positi=positi+boxzsize
12129 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12130 c for each residue check if it is in lipid or lipid water border area
12131 C       respos=mod(c(3,i+nres),boxzsize)
12132 C       print *,positi,bordlipbot,buflipbot
12133        if ((positi.gt.bordlipbot)
12134      & .and.(positi.lt.bordliptop)) then
12135 C the energy transfer exist
12136         if (positi.lt.buflipbot) then
12137          fracinbuf=1.0d0-
12138      &     ((positi-bordlipbot)/lipbufthick)
12139 C lipbufthick is thickenes of lipid buffore
12140          sslip=sscalelip(fracinbuf)
12141          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12142          eliptran=eliptran+sslip*liptranene(itype(i))
12143          gliptranx(3,i)=gliptranx(3,i)
12144      &+ssgradlip*liptranene(itype(i))
12145          gliptranc(3,i-1)= gliptranc(3,i-1)
12146      &+ssgradlip*liptranene(itype(i))
12147 C         print *,"doing sccale for lower part"
12148         elseif (positi.gt.bufliptop) then
12149          fracinbuf=1.0d0-
12150      &((bordliptop-positi)/lipbufthick)
12151          sslip=sscalelip(fracinbuf)
12152          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12153          eliptran=eliptran+sslip*liptranene(itype(i))
12154          gliptranx(3,i)=gliptranx(3,i)
12155      &+ssgradlip*liptranene(itype(i))
12156          gliptranc(3,i-1)= gliptranc(3,i-1)
12157      &+ssgradlip*liptranene(itype(i))
12158 C          print *, "doing sscalefor top part",sslip,fracinbuf
12159         else
12160          eliptran=eliptran+liptranene(itype(i))
12161 C         print *,"I am in true lipid"
12162         endif
12163         endif ! if in lipid or buffor
12164 C       else
12165 C       eliptran=elpitran+0.0 ! I am in water
12166        enddo
12167        return
12168        end
12169 C---------------------------------------------------------
12170 C AFM soubroutine for constant force
12171        subroutine AFMforce(Eafmforce)
12172        implicit real*8 (a-h,o-z)
12173       include 'DIMENSIONS'
12174       include 'COMMON.GEO'
12175       include 'COMMON.VAR'
12176       include 'COMMON.LOCAL'
12177       include 'COMMON.CHAIN'
12178       include 'COMMON.DERIV'
12179       include 'COMMON.NAMES'
12180       include 'COMMON.INTERACT'
12181       include 'COMMON.IOUNITS'
12182       include 'COMMON.CALC'
12183       include 'COMMON.CONTROL'
12184       include 'COMMON.SPLITELE'
12185       include 'COMMON.SBRIDGE'
12186       real*8 diffafm(3)
12187       dist=0.0d0
12188       Eafmforce=0.0d0
12189       do i=1,3
12190       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12191       dist=dist+diffafm(i)**2
12192       enddo
12193       dist=dsqrt(dist)
12194       Eafmforce=-forceAFMconst*(dist-distafminit)
12195       do i=1,3
12196       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12197       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12198       enddo
12199 C      print *,'AFM',Eafmforce
12200       return
12201       end
12202 C---------------------------------------------------------
12203 C AFM subroutine with pseudoconstant velocity
12204        subroutine AFMvel(Eafmforce)
12205        implicit real*8 (a-h,o-z)
12206       include 'DIMENSIONS'
12207       include 'COMMON.GEO'
12208       include 'COMMON.VAR'
12209       include 'COMMON.LOCAL'
12210       include 'COMMON.CHAIN'
12211       include 'COMMON.DERIV'
12212       include 'COMMON.NAMES'
12213       include 'COMMON.INTERACT'
12214       include 'COMMON.IOUNITS'
12215       include 'COMMON.CALC'
12216       include 'COMMON.CONTROL'
12217       include 'COMMON.SPLITELE'
12218       include 'COMMON.SBRIDGE'
12219       real*8 diffafm(3)
12220 C Only for check grad COMMENT if not used for checkgrad
12221 C      totT=3.0d0
12222 C--------------------------------------------------------
12223 C      print *,"wchodze"
12224       dist=0.0d0
12225       Eafmforce=0.0d0
12226       do i=1,3
12227       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12228       dist=dist+diffafm(i)**2
12229       enddo
12230       dist=dsqrt(dist)
12231       Eafmforce=0.5d0*forceAFMconst
12232      & *(distafminit+totTafm*velAFMconst-dist)**2
12233 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12234       do i=1,3
12235       gradafm(i,afmend-1)=-forceAFMconst*
12236      &(distafminit+totTafm*velAFMconst-dist)
12237      &*diffafm(i)/dist
12238       gradafm(i,afmbeg-1)=forceAFMconst*
12239      &(distafminit+totTafm*velAFMconst-dist)
12240      &*diffafm(i)/dist
12241       enddo
12242 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12243       return
12244       end
12245 C-----------------------------------------------------------
12246 C first for shielding is setting of function of side-chains
12247        subroutine set_shield_fac
12248       implicit real*8 (a-h,o-z)
12249       include 'DIMENSIONS'
12250       include 'COMMON.CHAIN'
12251       include 'COMMON.DERIV'
12252       include 'COMMON.IOUNITS'
12253       include 'COMMON.SHIELD'
12254       include 'COMMON.INTERACT'
12255 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12256       double precision div77_81/0.974996043d0/,
12257      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12258
12259 C the vector between center of side_chain and peptide group
12260        double precision pep_side(3),long,side_calf(3),
12261      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12262      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12263 C the line belowe needs to be changed for FGPROC>1
12264       do i=1,nres-1
12265       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12266       ishield_list(i)=0
12267 Cif there two consequtive dummy atoms there is no peptide group between them
12268 C the line below has to be changed for FGPROC>1
12269       VolumeTotal=0.0
12270       do k=1,nres
12271        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12272        dist_pep_side=0.0
12273        dist_side_calf=0.0
12274        do j=1,3
12275 C first lets set vector conecting the ithe side-chain with kth side-chain
12276       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12277 C      pep_side(j)=2.0d0
12278 C and vector conecting the side-chain with its proper calfa
12279       side_calf(j)=c(j,k+nres)-c(j,k)
12280 C      side_calf(j)=2.0d0
12281       pept_group(j)=c(j,i)-c(j,i+1)
12282 C lets have their lenght
12283       dist_pep_side=pep_side(j)**2+dist_pep_side
12284       dist_side_calf=dist_side_calf+side_calf(j)**2
12285       dist_pept_group=dist_pept_group+pept_group(j)**2
12286       enddo
12287        dist_pep_side=dsqrt(dist_pep_side)
12288        dist_pept_group=dsqrt(dist_pept_group)
12289        dist_side_calf=dsqrt(dist_side_calf)
12290       do j=1,3
12291         pep_side_norm(j)=pep_side(j)/dist_pep_side
12292         side_calf_norm(j)=dist_side_calf
12293       enddo
12294 C now sscale fraction
12295        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12296 C       print *,buff_shield,"buff"
12297 C now sscale
12298         if (sh_frac_dist.le.0.0) cycle
12299 C If we reach here it means that this side chain reaches the shielding sphere
12300 C Lets add him to the list for gradient
12301         ishield_list(i)=ishield_list(i)+1
12302 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12303 C this list is essential otherwise problem would be O3
12304         shield_list(ishield_list(i),i)=k
12305 C Lets have the sscale value
12306         if (sh_frac_dist.gt.1.0) then
12307          scale_fac_dist=1.0d0
12308          do j=1,3
12309          sh_frac_dist_grad(j)=0.0d0
12310          enddo
12311         else
12312          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12313      &                   *(2.0*sh_frac_dist-3.0d0)
12314          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12315      &                  /dist_pep_side/buff_shield*0.5
12316 C remember for the final gradient multiply sh_frac_dist_grad(j)
12317 C for side_chain by factor -2 !
12318          do j=1,3
12319          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12320 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12321 C     &                    sh_frac_dist_grad(j)
12322          enddo
12323         endif
12324 C        if ((i.eq.3).and.(k.eq.2)) then
12325 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12326 C     & ,"TU"
12327 C        endif
12328
12329 C this is what is now we have the distance scaling now volume...
12330       short=short_r_sidechain(itype(k))
12331       long=long_r_sidechain(itype(k))
12332       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12333 C now costhet_grad
12334 C       costhet=0.0d0
12335        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12336 C       costhet_fac=0.0d0
12337        do j=1,3
12338          costhet_grad(j)=costhet_fac*pep_side(j)
12339        enddo
12340 C remember for the final gradient multiply costhet_grad(j)
12341 C for side_chain by factor -2 !
12342 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12343 C pep_side0pept_group is vector multiplication
12344       pep_side0pept_group=0.0
12345       do j=1,3
12346       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12347       enddo
12348       cosalfa=(pep_side0pept_group/
12349      & (dist_pep_side*dist_side_calf))
12350       fac_alfa_sin=1.0-cosalfa**2
12351       fac_alfa_sin=dsqrt(fac_alfa_sin)
12352       rkprim=fac_alfa_sin*(long-short)+short
12353 C now costhet_grad
12354        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12355        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12356
12357        do j=1,3
12358          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12359      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12360      &*(long-short)/fac_alfa_sin*cosalfa/
12361      &((dist_pep_side*dist_side_calf))*
12362      &((side_calf(j))-cosalfa*
12363      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12364
12365         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12366      &*(long-short)/fac_alfa_sin*cosalfa
12367      &/((dist_pep_side*dist_side_calf))*
12368      &(pep_side(j)-
12369      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12370        enddo
12371
12372       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12373      &                    /VSolvSphere_div
12374      &                    *wshield
12375 C now the gradient...
12376 C grad_shield is gradient of Calfa for peptide groups
12377 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12378 C     &               costhet,cosphi
12379 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12380 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12381       do j=1,3
12382       grad_shield(j,i)=grad_shield(j,i)
12383 C gradient po skalowaniu
12384      &                +(sh_frac_dist_grad(j)
12385 C  gradient po costhet
12386      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12387      &-scale_fac_dist*(cosphi_grad_long(j))
12388      &/(1.0-cosphi) )*div77_81
12389      &*VofOverlap
12390 C grad_shield_side is Cbeta sidechain gradient
12391       grad_shield_side(j,ishield_list(i),i)=
12392      &        (sh_frac_dist_grad(j)*(-2.0d0)
12393      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12394      &       +scale_fac_dist*(cosphi_grad_long(j))
12395      &        *2.0d0/(1.0-cosphi))
12396      &        *div77_81*VofOverlap
12397
12398        grad_shield_loc(j,ishield_list(i),i)=
12399      &   scale_fac_dist*cosphi_grad_loc(j)
12400      &        *2.0d0/(1.0-cosphi)
12401      &        *div77_81*VofOverlap
12402       enddo
12403       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12404       enddo
12405       fac_shield(i)=VolumeTotal*div77_81+div4_81
12406 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12407       enddo
12408       return
12409       end
12410 C--------------------------------------------------------------------------
12411       double precision function tschebyshev(m,n,x,y)
12412       implicit none
12413       include "DIMENSIONS"
12414       integer i,m,n
12415       double precision x(n),y,yy(0:maxvar),aux
12416 c Tschebyshev polynomial. Note that the first term is omitted
12417 c m=0: the constant term is included
12418 c m=1: the constant term is not included
12419       yy(0)=1.0d0
12420       yy(1)=y
12421       do i=2,n
12422         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12423       enddo
12424       aux=0.0d0
12425       do i=m,n
12426         aux=aux+x(i)*yy(i)
12427       enddo
12428       tschebyshev=aux
12429       return
12430       end
12431 C--------------------------------------------------------------------------
12432       double precision function gradtschebyshev(m,n,x,y)
12433       implicit none
12434       include "DIMENSIONS"
12435       integer i,m,n
12436       double precision x(n+1),y,yy(0:maxvar),aux
12437 c Tschebyshev polynomial. Note that the first term is omitted
12438 c m=0: the constant term is included
12439 c m=1: the constant term is not included
12440       yy(0)=1.0d0
12441       yy(1)=2.0d0*y
12442       do i=2,n
12443         yy(i)=2*y*yy(i-1)-yy(i-2)
12444       enddo
12445       aux=0.0d0
12446       do i=m,n
12447         aux=aux+x(i+1)*yy(i)*(i+1)
12448 C        print *, x(i+1),yy(i),i
12449       enddo
12450       gradtschebyshev=aux
12451       return
12452       end
12453 C------------------------------------------------------------------------
12454 C first for shielding is setting of function of side-chains
12455        subroutine set_shield_fac2
12456       implicit real*8 (a-h,o-z)
12457       include 'DIMENSIONS'
12458       include 'COMMON.CHAIN'
12459       include 'COMMON.DERIV'
12460       include 'COMMON.IOUNITS'
12461       include 'COMMON.SHIELD'
12462       include 'COMMON.INTERACT'
12463 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12464       double precision div77_81/0.974996043d0/,
12465      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12466
12467 C the vector between center of side_chain and peptide group
12468        double precision pep_side(3),long,side_calf(3),
12469      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12470      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12471 C the line belowe needs to be changed for FGPROC>1
12472       do i=1,nres-1
12473       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12474       ishield_list(i)=0
12475 Cif there two consequtive dummy atoms there is no peptide group between them
12476 C the line below has to be changed for FGPROC>1
12477       VolumeTotal=0.0
12478       do k=1,nres
12479        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12480        dist_pep_side=0.0
12481        dist_side_calf=0.0
12482        do j=1,3
12483 C first lets set vector conecting the ithe side-chain with kth side-chain
12484       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12485 C      pep_side(j)=2.0d0
12486 C and vector conecting the side-chain with its proper calfa
12487       side_calf(j)=c(j,k+nres)-c(j,k)
12488 C      side_calf(j)=2.0d0
12489       pept_group(j)=c(j,i)-c(j,i+1)
12490 C lets have their lenght
12491       dist_pep_side=pep_side(j)**2+dist_pep_side
12492       dist_side_calf=dist_side_calf+side_calf(j)**2
12493       dist_pept_group=dist_pept_group+pept_group(j)**2
12494       enddo
12495        dist_pep_side=dsqrt(dist_pep_side)
12496        dist_pept_group=dsqrt(dist_pept_group)
12497        dist_side_calf=dsqrt(dist_side_calf)
12498       do j=1,3
12499         pep_side_norm(j)=pep_side(j)/dist_pep_side
12500         side_calf_norm(j)=dist_side_calf
12501       enddo
12502 C now sscale fraction
12503        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12504 C       print *,buff_shield,"buff"
12505 C now sscale
12506         if (sh_frac_dist.le.0.0) cycle
12507 C If we reach here it means that this side chain reaches the shielding sphere
12508 C Lets add him to the list for gradient
12509         ishield_list(i)=ishield_list(i)+1
12510 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12511 C this list is essential otherwise problem would be O3
12512         shield_list(ishield_list(i),i)=k
12513 C Lets have the sscale value
12514         if (sh_frac_dist.gt.1.0) then
12515          scale_fac_dist=1.0d0
12516          do j=1,3
12517          sh_frac_dist_grad(j)=0.0d0
12518          enddo
12519         else
12520          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12521      &                   *(2.0d0*sh_frac_dist-3.0d0)
12522          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12523      &                  /dist_pep_side/buff_shield*0.5d0
12524 C remember for the final gradient multiply sh_frac_dist_grad(j)
12525 C for side_chain by factor -2 !
12526          do j=1,3
12527          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12528 C         sh_frac_dist_grad(j)=0.0d0
12529 C         scale_fac_dist=1.0d0
12530 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12531 C     &                    sh_frac_dist_grad(j)
12532          enddo
12533         endif
12534 C this is what is now we have the distance scaling now volume...
12535       short=short_r_sidechain(itype(k))
12536       long=long_r_sidechain(itype(k))
12537       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12538       sinthet=short/dist_pep_side*costhet
12539 C now costhet_grad
12540 C       costhet=0.6d0
12541 C       sinthet=0.8
12542        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12543 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12544 C     &             -short/dist_pep_side**2/costhet)
12545 C       costhet_fac=0.0d0
12546        do j=1,3
12547          costhet_grad(j)=costhet_fac*pep_side(j)
12548        enddo
12549 C remember for the final gradient multiply costhet_grad(j)
12550 C for side_chain by factor -2 !
12551 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12552 C pep_side0pept_group is vector multiplication
12553       pep_side0pept_group=0.0d0
12554       do j=1,3
12555       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12556       enddo
12557       cosalfa=(pep_side0pept_group/
12558      & (dist_pep_side*dist_side_calf))
12559       fac_alfa_sin=1.0d0-cosalfa**2
12560       fac_alfa_sin=dsqrt(fac_alfa_sin)
12561       rkprim=fac_alfa_sin*(long-short)+short
12562 C      rkprim=short
12563
12564 C now costhet_grad
12565        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12566 C       cosphi=0.6
12567        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12568        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12569      &      dist_pep_side**2)
12570 C       sinphi=0.8
12571        do j=1,3
12572          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12573      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12574      &*(long-short)/fac_alfa_sin*cosalfa/
12575      &((dist_pep_side*dist_side_calf))*
12576      &((side_calf(j))-cosalfa*
12577      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12578 C       cosphi_grad_long(j)=0.0d0
12579         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12580      &*(long-short)/fac_alfa_sin*cosalfa
12581      &/((dist_pep_side*dist_side_calf))*
12582      &(pep_side(j)-
12583      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12584 C       cosphi_grad_loc(j)=0.0d0
12585        enddo
12586 C      print *,sinphi,sinthet
12587 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12588 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12589       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12590      &                    /VSolvSphere_div
12591 C     &                    *wshield
12592 C now the gradient...
12593       do j=1,3
12594       grad_shield(j,i)=grad_shield(j,i)
12595 C gradient po skalowaniu
12596      &                +(sh_frac_dist_grad(j)*VofOverlap
12597 C  gradient po costhet
12598      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12599      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12600      &       sinphi/sinthet*costhet*costhet_grad(j)
12601      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12602      & )*wshield
12603 C grad_shield_side is Cbeta sidechain gradient
12604       grad_shield_side(j,ishield_list(i),i)=
12605      &        (sh_frac_dist_grad(j)*(-2.0d0)
12606      &        *VofOverlap
12607      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12608      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12609      &       sinphi/sinthet*costhet*costhet_grad(j)
12610      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12611      &       )*wshield
12612
12613        grad_shield_loc(j,ishield_list(i),i)=
12614      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12615      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12616      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12617      &        ))
12618      &        *wshield
12619       enddo
12620 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12621 c     & scale_fac_dist
12622       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12623       enddo
12624       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12625 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12626 c     &  " wshield",wshield
12627 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12628       enddo
12629       return
12630       end
12631 C-----------------------------------------------------------------------
12632 C-----------------------------------------------------------
12633 C This subroutine is to mimic the histone like structure but as well can be
12634 C utilizet to nanostructures (infinit) small modification has to be used to
12635 C make it finite (z gradient at the ends has to be changes as well as the x,y
12636 C gradient has to be modified at the ends
12637 C The energy function is Kihara potential
12638 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12639 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12640 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12641 C simple Kihara potential
12642       subroutine calctube(Etube)
12643        implicit real*8 (a-h,o-z)
12644       include 'DIMENSIONS'
12645       include 'COMMON.GEO'
12646       include 'COMMON.VAR'
12647       include 'COMMON.LOCAL'
12648       include 'COMMON.CHAIN'
12649       include 'COMMON.DERIV'
12650       include 'COMMON.NAMES'
12651       include 'COMMON.INTERACT'
12652       include 'COMMON.IOUNITS'
12653       include 'COMMON.CALC'
12654       include 'COMMON.CONTROL'
12655       include 'COMMON.SPLITELE'
12656       include 'COMMON.SBRIDGE'
12657       double precision tub_r,vectube(3),enetube(maxres*2)
12658       Etube=0.0d0
12659       do i=1,2*nres
12660         enetube(i)=0.0d0
12661       enddo
12662 C first we calculate the distance from tube center
12663 C first sugare-phosphate group for NARES this would be peptide group
12664 C for UNRES
12665       do i=1,nres
12666 C lets ommit dummy atoms for now
12667        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12668 C now calculate distance from center of tube and direction vectors
12669       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12670           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12671       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12672           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12673       vectube(1)=vectube(1)-tubecenter(1)
12674       vectube(2)=vectube(2)-tubecenter(2)
12675
12676 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12677 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12678
12679 C as the tube is infinity we do not calculate the Z-vector use of Z
12680 C as chosen axis
12681       vectube(3)=0.0d0
12682 C now calculte the distance
12683        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12684 C now normalize vector
12685       vectube(1)=vectube(1)/tub_r
12686       vectube(2)=vectube(2)/tub_r
12687 C calculte rdiffrence between r and r0
12688       rdiff=tub_r-tubeR0
12689 C and its 6 power
12690       rdiff6=rdiff**6.0d0
12691 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12692        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12693 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12694 C       print *,rdiff,rdiff6,pep_aa_tube
12695 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12696 C now we calculate gradient
12697        fac=(-12.0d0*pep_aa_tube/rdiff6+
12698      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12699 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12700 C     &rdiff,fac
12701
12702 C now direction of gg_tube vector
12703         do j=1,3
12704         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12705         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12706         enddo
12707         enddo
12708 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12709         do i=1,nres
12710 C Lets not jump over memory as we use many times iti
12711          iti=itype(i)
12712 C lets ommit dummy atoms for now
12713          if ((iti.eq.ntyp1)
12714 C in UNRES uncomment the line below as GLY has no side-chain...
12715 C      .or.(iti.eq.10)
12716      &   ) cycle
12717           vectube(1)=c(1,i+nres)
12718           vectube(1)=mod(vectube(1),boxxsize)
12719           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12720           vectube(2)=c(2,i+nres)
12721           vectube(2)=mod(vectube(2),boxxsize)
12722           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12723
12724       vectube(1)=vectube(1)-tubecenter(1)
12725       vectube(2)=vectube(2)-tubecenter(2)
12726
12727 C as the tube is infinity we do not calculate the Z-vector use of Z
12728 C as chosen axis
12729       vectube(3)=0.0d0
12730 C now calculte the distance
12731        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12732 C now normalize vector
12733       vectube(1)=vectube(1)/tub_r
12734       vectube(2)=vectube(2)/tub_r
12735 C calculte rdiffrence between r and r0
12736       rdiff=tub_r-tubeR0
12737 C and its 6 power
12738       rdiff6=rdiff**6.0d0
12739 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12740        sc_aa_tube=sc_aa_tube_par(iti)
12741        sc_bb_tube=sc_bb_tube_par(iti)
12742        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12743 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12744 C now we calculate gradient
12745        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12746      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12747 C now direction of gg_tube vector
12748          do j=1,3
12749           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12750           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12751          enddo
12752         enddo
12753         do i=1,2*nres
12754           Etube=Etube+enetube(i)
12755         enddo
12756 C        print *,"ETUBE", etube
12757         return
12758         end
12759 C TO DO 1) add to total energy
12760 C       2) add to gradient summation
12761 C       3) add reading parameters (AND of course oppening of PARAM file)
12762 C       4) add reading the center of tube
12763 C       5) add COMMONs
12764 C       6) add to zerograd
12765
12766 C-----------------------------------------------------------------------
12767 C-----------------------------------------------------------
12768 C This subroutine is to mimic the histone like structure but as well can be
12769 C utilizet to nanostructures (infinit) small modification has to be used to
12770 C make it finite (z gradient at the ends has to be changes as well as the x,y
12771 C gradient has to be modified at the ends
12772 C The energy function is Kihara potential
12773 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12774 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12775 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12776 C simple Kihara potential
12777       subroutine calctube2(Etube)
12778        implicit real*8 (a-h,o-z)
12779       include 'DIMENSIONS'
12780       include 'COMMON.GEO'
12781       include 'COMMON.VAR'
12782       include 'COMMON.LOCAL'
12783       include 'COMMON.CHAIN'
12784       include 'COMMON.DERIV'
12785       include 'COMMON.NAMES'
12786       include 'COMMON.INTERACT'
12787       include 'COMMON.IOUNITS'
12788       include 'COMMON.CALC'
12789       include 'COMMON.CONTROL'
12790       include 'COMMON.SPLITELE'
12791       include 'COMMON.SBRIDGE'
12792       double precision tub_r,vectube(3),enetube(maxres*2)
12793       Etube=0.0d0
12794       do i=1,2*nres
12795         enetube(i)=0.0d0
12796       enddo
12797 C first we calculate the distance from tube center
12798 C first sugare-phosphate group for NARES this would be peptide group
12799 C for UNRES
12800       do i=1,nres
12801 C lets ommit dummy atoms for now
12802        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12803 C now calculate distance from center of tube and direction vectors
12804       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12805           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12806       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12807           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12808       vectube(1)=vectube(1)-tubecenter(1)
12809       vectube(2)=vectube(2)-tubecenter(2)
12810
12811 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12812 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12813
12814 C as the tube is infinity we do not calculate the Z-vector use of Z
12815 C as chosen axis
12816       vectube(3)=0.0d0
12817 C now calculte the distance
12818        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12819 C now normalize vector
12820       vectube(1)=vectube(1)/tub_r
12821       vectube(2)=vectube(2)/tub_r
12822 C calculte rdiffrence between r and r0
12823       rdiff=tub_r-tubeR0
12824 C and its 6 power
12825       rdiff6=rdiff**6.0d0
12826 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12827        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12828 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12829 C       print *,rdiff,rdiff6,pep_aa_tube
12830 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12831 C now we calculate gradient
12832        fac=(-12.0d0*pep_aa_tube/rdiff6+
12833      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12834 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12835 C     &rdiff,fac
12836
12837 C now direction of gg_tube vector
12838         do j=1,3
12839         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12840         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12841         enddo
12842         enddo
12843 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12844         do i=1,nres
12845 C Lets not jump over memory as we use many times iti
12846          iti=itype(i)
12847 C lets ommit dummy atoms for now
12848          if ((iti.eq.ntyp1)
12849 C in UNRES uncomment the line below as GLY has no side-chain...
12850      &      .or.(iti.eq.10)
12851      &   ) cycle
12852           vectube(1)=c(1,i+nres)
12853           vectube(1)=mod(vectube(1),boxxsize)
12854           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12855           vectube(2)=c(2,i+nres)
12856           vectube(2)=mod(vectube(2),boxxsize)
12857           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12858
12859       vectube(1)=vectube(1)-tubecenter(1)
12860       vectube(2)=vectube(2)-tubecenter(2)
12861 C THIS FRAGMENT MAKES TUBE FINITE
12862         positi=(mod(c(3,i+nres),boxzsize))
12863         if (positi.le.0) positi=positi+boxzsize
12864 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12865 c for each residue check if it is in lipid or lipid water border area
12866 C       respos=mod(c(3,i+nres),boxzsize)
12867        print *,positi,bordtubebot,buftubebot,bordtubetop
12868        if ((positi.gt.bordtubebot)
12869      & .and.(positi.lt.bordtubetop)) then
12870 C the energy transfer exist
12871         if (positi.lt.buftubebot) then
12872          fracinbuf=1.0d0-
12873      &     ((positi-bordtubebot)/tubebufthick)
12874 C lipbufthick is thickenes of lipid buffore
12875          sstube=sscalelip(fracinbuf)
12876          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12877          print *,ssgradtube, sstube,tubetranene(itype(i))
12878          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12879          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12880      &+ssgradtube*tubetranene(itype(i))
12881          gg_tube(3,i-1)= gg_tube(3,i-1)
12882      &+ssgradtube*tubetranene(itype(i))
12883 C         print *,"doing sccale for lower part"
12884         elseif (positi.gt.buftubetop) then
12885          fracinbuf=1.0d0-
12886      &((bordtubetop-positi)/tubebufthick)
12887          sstube=sscalelip(fracinbuf)
12888          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12889          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12890 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12891 C     &+ssgradtube*tubetranene(itype(i))
12892 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12893 C     &+ssgradtube*tubetranene(itype(i))
12894 C          print *, "doing sscalefor top part",sslip,fracinbuf
12895         else
12896          sstube=1.0d0
12897          ssgradtube=0.0d0
12898          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12899 C         print *,"I am in true lipid"
12900         endif
12901         else
12902 C          sstube=0.0d0
12903 C          ssgradtube=0.0d0
12904         cycle
12905         endif ! if in lipid or buffor
12906 CEND OF FINITE FRAGMENT
12907 C as the tube is infinity we do not calculate the Z-vector use of Z
12908 C as chosen axis
12909       vectube(3)=0.0d0
12910 C now calculte the distance
12911        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12912 C now normalize vector
12913       vectube(1)=vectube(1)/tub_r
12914       vectube(2)=vectube(2)/tub_r
12915 C calculte rdiffrence between r and r0
12916       rdiff=tub_r-tubeR0
12917 C and its 6 power
12918       rdiff6=rdiff**6.0d0
12919 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12920        sc_aa_tube=sc_aa_tube_par(iti)
12921        sc_bb_tube=sc_bb_tube_par(iti)
12922        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12923      &                 *sstube+enetube(i+nres)
12924 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12925 C now we calculate gradient
12926        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12927      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12928 C now direction of gg_tube vector
12929          do j=1,3
12930           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12931           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12932          enddo
12933          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12934      &+ssgradtube*enetube(i+nres)/sstube
12935          gg_tube(3,i-1)= gg_tube(3,i-1)
12936      &+ssgradtube*enetube(i+nres)/sstube
12937
12938         enddo
12939         do i=1,2*nres
12940           Etube=Etube+enetube(i)
12941         enddo
12942 C        print *,"ETUBE", etube
12943         return
12944         end
12945 C TO DO 1) add to total energy
12946 C       2) add to gradient summation
12947 C       3) add reading parameters (AND of course oppening of PARAM file)
12948 C       4) add reading the center of tube
12949 C       5) add COMMONs
12950 C       6) add to zerograd
12951 c----------------------------------------------------------------------------
12952       subroutine e_saxs(Esaxs_constr)
12953       implicit none
12954       include 'DIMENSIONS'
12955 #ifdef MPI
12956       include "mpif.h"
12957       include "COMMON.SETUP"
12958       integer IERR
12959 #endif
12960       include 'COMMON.SBRIDGE'
12961       include 'COMMON.CHAIN'
12962       include 'COMMON.GEO'
12963       include 'COMMON.DERIV'
12964       include 'COMMON.LOCAL'
12965       include 'COMMON.INTERACT'
12966       include 'COMMON.VAR'
12967       include 'COMMON.IOUNITS'
12968 c      include 'COMMON.MD'
12969 #ifdef LANG0
12970 #ifdef FIVEDIAG
12971       include 'COMMON.LANGEVIN.lang0.5diag'
12972 #else
12973       include 'COMMON.LANGEVIN.lang0'
12974 #endif
12975 #else
12976       include 'COMMON.LANGEVIN'
12977 #endif
12978       include 'COMMON.CONTROL'
12979       include 'COMMON.SAXS'
12980       include 'COMMON.NAMES'
12981       include 'COMMON.TIME1'
12982       include 'COMMON.FFIELD'
12983 c
12984       double precision Esaxs_constr
12985       integer i,iint,j,k,l
12986       double precision PgradC(maxSAXS,3,maxres),
12987      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12988 #ifdef MPI
12989       double precision PgradC_(maxSAXS,3,maxres),
12990      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12991 #endif
12992       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12993      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12994      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12995      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12996       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12997       double precision dist,mygauss,mygaussder
12998       external dist
12999       integer llicz,lllicz
13000       double precision time01
13001 c  SAXS restraint penalty function
13002 #ifdef DEBUG
13003       write(iout,*) "------- SAXS penalty function start -------"
13004       write (iout,*) "nsaxs",nsaxs
13005       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13006       write (iout,*) "Psaxs"
13007       do i=1,nsaxs
13008         write (iout,'(i5,e15.5)') i, Psaxs(i)
13009       enddo
13010 #endif
13011 #ifdef TIMING
13012       time01=MPI_Wtime()
13013 #endif
13014       Esaxs_constr = 0.0d0
13015       do k=1,nsaxs
13016         Pcalc(k)=0.0d0
13017         do j=1,nres
13018           do l=1,3
13019             PgradC(k,l,j)=0.0d0
13020             PgradX(k,l,j)=0.0d0
13021           enddo
13022         enddo
13023       enddo
13024 c      lllicz=0
13025       do i=iatsc_s,iatsc_e
13026        if (itype(i).eq.ntyp1) cycle
13027        do iint=1,nint_gr(i)
13028          do j=istart(i,iint),iend(i,iint)
13029            if (itype(j).eq.ntyp1) cycle
13030 #ifdef ALLSAXS
13031            dijCACA=dist(i,j)
13032            dijCASC=dist(i,j+nres)
13033            dijSCCA=dist(i+nres,j)
13034            dijSCSC=dist(i+nres,j+nres)
13035            sigma2CACA=2.0d0/(pstok**2)
13036            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13037            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13038            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13039            do k=1,nsaxs
13040              dk = distsaxs(k)
13041              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13042              if (itype(j).ne.10) then
13043              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13044              else
13045              endif
13046              expCASC = 0.0d0
13047              if (itype(i).ne.10) then
13048              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13049              else
13050              expSCCA = 0.0d0
13051              endif
13052              if (itype(i).ne.10 .and. itype(j).ne.10) then
13053              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13054              else
13055              expSCSC = 0.0d0
13056              endif
13057              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13058 #ifdef DEBUG
13059              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13060 #endif
13061              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13062              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13063              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13064              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13065              do l=1,3
13066 c CA CA
13067                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13068                PgradC(k,l,i) = PgradC(k,l,i)-aux
13069                PgradC(k,l,j) = PgradC(k,l,j)+aux
13070 c CA SC
13071                if (itype(j).ne.10) then
13072                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13073                PgradC(k,l,i) = PgradC(k,l,i)-aux
13074                PgradC(k,l,j) = PgradC(k,l,j)+aux
13075                PgradX(k,l,j) = PgradX(k,l,j)+aux
13076                endif
13077 c SC CA
13078                if (itype(i).ne.10) then
13079                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13080                PgradX(k,l,i) = PgradX(k,l,i)-aux
13081                PgradC(k,l,i) = PgradC(k,l,i)-aux
13082                PgradC(k,l,j) = PgradC(k,l,j)+aux
13083                endif
13084 c SC SC
13085                if (itype(i).ne.10 .and. itype(j).ne.10) then
13086                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13087                PgradC(k,l,i) = PgradC(k,l,i)-aux
13088                PgradC(k,l,j) = PgradC(k,l,j)+aux
13089                PgradX(k,l,i) = PgradX(k,l,i)-aux
13090                PgradX(k,l,j) = PgradX(k,l,j)+aux
13091                endif
13092              enddo ! l
13093            enddo ! k
13094 #else
13095            dijCACA=dist(i,j)
13096            sigma2CACA=scal_rad**2*0.25d0/
13097      &        (restok(itype(j))**2+restok(itype(i))**2)
13098 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13099 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13100 #ifdef MYGAUSS
13101            sigmaCACA=dsqrt(sigma2CACA)
13102            threesig=3.0d0/sigmaCACA
13103 c           llicz=0
13104            do k=1,nsaxs
13105              dk = distsaxs(k)
13106              if (dabs(dijCACA-dk).ge.threesig) cycle
13107 c             llicz=llicz+1
13108 c             lllicz=lllicz+1
13109              aux = sigmaCACA*(dijCACA-dk)
13110              expCACA = mygauss(aux)
13111 c             if (expcaca.eq.0.0d0) cycle
13112              Pcalc(k) = Pcalc(k)+expCACA
13113              CACAgrad = -sigmaCACA*mygaussder(aux)
13114 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13115              do l=1,3
13116                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13117                PgradC(k,l,i) = PgradC(k,l,i)-aux
13118                PgradC(k,l,j) = PgradC(k,l,j)+aux
13119              enddo ! l
13120            enddo ! k
13121 c           write (iout,*) "i",i," j",j," llicz",llicz
13122 #else
13123            IF (saxs_cutoff.eq.0) THEN
13124            do k=1,nsaxs
13125              dk = distsaxs(k)
13126              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13127              Pcalc(k) = Pcalc(k)+expCACA
13128              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13129              do l=1,3
13130                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13131                PgradC(k,l,i) = PgradC(k,l,i)-aux
13132                PgradC(k,l,j) = PgradC(k,l,j)+aux
13133              enddo ! l
13134            enddo ! k
13135            ELSE
13136            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13137            do k=1,nsaxs
13138              dk = distsaxs(k)
13139 c             write (2,*) "ijk",i,j,k
13140              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13141              if (sss2.eq.0.0d0) cycle
13142              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13143              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13144      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13145      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13146      &           sss2,ssgrad2
13147              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13148              Pcalc(k) = Pcalc(k)+expCACA
13149 #ifdef DEBUG
13150              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13151 #endif
13152              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13153      &             ssgrad2*expCACA/sss2
13154              do l=1,3
13155 c CA CA
13156                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13157                PgradC(k,l,i) = PgradC(k,l,i)+aux
13158                PgradC(k,l,j) = PgradC(k,l,j)-aux
13159              enddo ! l
13160            enddo ! k
13161            ENDIF
13162 #endif
13163 #endif
13164          enddo ! j
13165        enddo ! iint
13166       enddo ! i
13167 c#ifdef TIMING
13168 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13169 c#endif
13170 c      write (iout,*) "lllicz",lllicz
13171 c#ifdef TIMING
13172 c      time01=MPI_Wtime()
13173 c#endif
13174 #ifdef MPI
13175       if (nfgtasks.gt.1) then
13176        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13177      &    MPI_SUM,FG_COMM,IERR)
13178 c        if (fg_rank.eq.king) then
13179           do k=1,nsaxs
13180             Pcalc(k) = Pcalc_(k)
13181           enddo
13182 c        endif
13183 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13184 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13185 c        if (fg_rank.eq.king) then
13186 c          do i=1,nres
13187 c            do l=1,3
13188 c              do k=1,nsaxs
13189 c                PgradC(k,l,i) = PgradC_(k,l,i)
13190 c              enddo
13191 c            enddo
13192 c          enddo
13193 c        endif
13194 #ifdef ALLSAXS
13195 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13196 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13197 c        if (fg_rank.eq.king) then
13198 c          do i=1,nres
13199 c            do l=1,3
13200 c              do k=1,nsaxs
13201 c                PgradX(k,l,i) = PgradX_(k,l,i)
13202 c              enddo
13203 c            enddo
13204 c          enddo
13205 c        endif
13206 #endif
13207       endif
13208 #endif
13209       Cnorm = 0.0d0
13210       do k=1,nsaxs
13211         Cnorm = Cnorm + Pcalc(k)
13212       enddo
13213 #ifdef MPI
13214       if (fg_rank.eq.king) then
13215 #endif
13216       Esaxs_constr = dlog(Cnorm)-wsaxs0
13217       do k=1,nsaxs
13218         if (Pcalc(k).gt.0.0d0)
13219      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13220 #ifdef DEBUG
13221         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13222 #endif
13223       enddo
13224 #ifdef DEBUG
13225       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13226 #endif
13227 #ifdef MPI
13228       endif
13229 #endif
13230       gsaxsC=0.0d0
13231       gsaxsX=0.0d0
13232       do i=nnt,nct
13233         do l=1,3
13234           auxC=0.0d0
13235           auxC1=0.0d0
13236           auxX=0.0d0
13237           auxX1=0.d0
13238           do k=1,nsaxs
13239             if (Pcalc(k).gt.0)
13240      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13241             auxC1 = auxC1+PgradC(k,l,i)
13242 #ifdef ALLSAXS
13243             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13244             auxX1 = auxX1+PgradX(k,l,i)
13245 #endif
13246           enddo
13247           gsaxsC(l,i) = auxC - auxC1/Cnorm
13248 #ifdef ALLSAXS
13249           gsaxsX(l,i) = auxX - auxX1/Cnorm
13250 #endif
13251 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13252 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13253 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13254 c     *     " gradX",wsaxs*gsaxsX(l,i)
13255         enddo
13256       enddo
13257 #ifdef TIMING
13258       time_SAXS=time_SAXS+MPI_Wtime()-time01
13259 #endif
13260 #ifdef DEBUG
13261       write (iout,*) "gsaxsc"
13262       do i=nnt,nct
13263         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13264       enddo
13265 #endif
13266 #ifdef MPI
13267 c      endif
13268 #endif
13269       return
13270       end
13271 c----------------------------------------------------------------------------
13272       subroutine e_saxsC(Esaxs_constr)
13273       implicit none
13274       include 'DIMENSIONS'
13275 #ifdef MPI
13276       include "mpif.h"
13277       include "COMMON.SETUP"
13278       integer IERR
13279 #endif
13280       include 'COMMON.SBRIDGE'
13281       include 'COMMON.CHAIN'
13282       include 'COMMON.GEO'
13283       include 'COMMON.DERIV'
13284       include 'COMMON.LOCAL'
13285       include 'COMMON.INTERACT'
13286       include 'COMMON.VAR'
13287       include 'COMMON.IOUNITS'
13288 c      include 'COMMON.MD'
13289 #ifdef LANG0
13290 #ifdef FIVEDIAG
13291       include 'COMMON.LANGEVIN.lang0.5diag'
13292 #else
13293       include 'COMMON.LANGEVIN.lang0'
13294 #endif
13295 #else
13296       include 'COMMON.LANGEVIN'
13297 #endif
13298       include 'COMMON.CONTROL'
13299       include 'COMMON.SAXS'
13300       include 'COMMON.NAMES'
13301       include 'COMMON.TIME1'
13302       include 'COMMON.FFIELD'
13303 c
13304       double precision Esaxs_constr
13305       integer i,iint,j,k,l
13306       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13307 #ifdef MPI
13308       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13309 #endif
13310       double precision dk,dijCASPH,dijSCSPH,
13311      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13312      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13313      & auxX,auxX1,Cnorm
13314 c  SAXS restraint penalty function
13315 #ifdef DEBUG
13316       write(iout,*) "------- SAXS penalty function start -------"
13317       write (iout,*) "nsaxs",nsaxs
13318
13319       do i=nnt,nct
13320         print *,MyRank,"C",i,(C(j,i),j=1,3)
13321       enddo
13322       do i=nnt,nct
13323         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13324       enddo
13325 #endif
13326       Esaxs_constr = 0.0d0
13327       logPtot=0.0d0
13328       do j=isaxs_start,isaxs_end
13329         Pcalc=0.0d0
13330         do i=1,nres
13331           do l=1,3
13332             PgradC(l,i)=0.0d0
13333             PgradX(l,i)=0.0d0
13334           enddo
13335         enddo
13336         do i=nnt,nct
13337           if (itype(i).eq.ntyp1) cycle
13338           dijCASPH=0.0d0
13339           dijSCSPH=0.0d0
13340           do l=1,3
13341             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13342           enddo
13343           if (itype(i).ne.10) then
13344           do l=1,3
13345             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13346           enddo
13347           endif
13348           sigma2CA=2.0d0/pstok**2
13349           sigma2SC=4.0d0/restok(itype(i))**2
13350           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13351           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13352           Pcalc = Pcalc+expCASPH+expSCSPH
13353 #ifdef DEBUG
13354           write(*,*) "processor i j Pcalc",
13355      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13356 #endif
13357           CASPHgrad = sigma2CA*expCASPH
13358           SCSPHgrad = sigma2SC*expSCSPH
13359           do l=1,3
13360             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13361             PgradX(l,i) = PgradX(l,i) + aux
13362             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13363           enddo ! l
13364         enddo ! i
13365         do i=nnt,nct
13366           do l=1,3
13367             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13368             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13369           enddo
13370         enddo
13371         logPtot = logPtot - dlog(Pcalc)
13372 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13373 c     &    " logPtot",logPtot
13374       enddo ! j
13375 #ifdef MPI
13376       if (nfgtasks.gt.1) then
13377 c        write (iout,*) "logPtot before reduction",logPtot
13378         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13379      &    MPI_SUM,king,FG_COMM,IERR)
13380         logPtot = logPtot_
13381 c        write (iout,*) "logPtot after reduction",logPtot
13382         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13383      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13384         if (fg_rank.eq.king) then
13385           do i=1,nres
13386             do l=1,3
13387               gsaxsC(l,i) = gsaxsC_(l,i)
13388             enddo
13389           enddo
13390         endif
13391         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13392      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13393         if (fg_rank.eq.king) then
13394           do i=1,nres
13395             do l=1,3
13396               gsaxsX(l,i) = gsaxsX_(l,i)
13397             enddo
13398           enddo
13399         endif
13400       endif
13401 #endif
13402       Esaxs_constr = logPtot
13403       return
13404       end
13405 c----------------------------------------------------------------------------
13406       double precision function sscale2(r,r_cut,r0,rlamb)
13407       implicit none
13408       double precision r,gamm,r_cut,r0,rlamb,rr
13409       rr = dabs(r-r0)
13410 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13411 c      write (2,*) "rr",rr
13412       if(rr.lt.r_cut-rlamb) then
13413         sscale2=1.0d0
13414       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13415         gamm=(rr-(r_cut-rlamb))/rlamb
13416         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13417       else
13418         sscale2=0d0
13419       endif
13420       return
13421       end
13422 C-----------------------------------------------------------------------
13423       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13424       implicit none
13425       double precision r,gamm,r_cut,r0,rlamb,rr
13426       rr = dabs(r-r0)
13427       if(rr.lt.r_cut-rlamb) then
13428         sscalgrad2=0.0d0
13429       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13430         gamm=(rr-(r_cut-rlamb))/rlamb
13431         if (r.ge.r0) then
13432           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13433         else
13434           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13435         endif
13436       else
13437         sscalgrad2=0.0d0
13438       endif
13439       return
13440       end