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

   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       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       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,gsccorr_norm,gscloc_norm,gvdwx_norm,
 649      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 650      &gsclocx_norm,gradcorr6_max,gsccorr_max,gsccorrx_max
 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       gsccorc_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       gsccorx_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         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1135         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_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,gsccorc_max,
1162      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1163      &     gsccorx_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 kfac /2.4d0/
1202       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1203       double precision facT,facT2,facT3,facT4,facT5
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.MD'
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,uconst,
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       include 'DIMENSIONS'
1416       double precision accur
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
1432       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2
1433 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1434       evdw=0.0D0
1435       do i=iatsc_s,iatsc_e
1436         itypi=iabs(itype(i))
1437         if (itypi.eq.ntyp1) cycle
1438         itypi1=iabs(itype(i+1))
1439         xi=c(1,nres+i)
1440         yi=c(2,nres+i)
1441         zi=c(3,nres+i)
1442 C Change 12/1/95
1443         num_conti=0
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1449 cd   &                  'iend=',iend(i,iint)
1450           do j=istart(i,iint),iend(i,iint)
1451             itypj=iabs(itype(j))
1452             if (itypj.eq.ntyp1) cycle
1453             xj=c(1,nres+j)-xi
1454             yj=c(2,nres+j)-yi
1455             zj=c(3,nres+j)-zi
1456 C Change 12/1/95 to calculate four-body interactions
1457             rij=xj*xj+yj*yj+zj*zj
1458             rrij=1.0D0/rij
1459 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1460             eps0ij=eps(itypi,itypj)
1461             fac=rrij**expon2
1462 C have you changed here?
1463             e1=fac*fac*aa
1464             e2=fac*bb
1465             evdwij=e1+e2
1466 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1467 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1468 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1469 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1470 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1471 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1472             evdw=evdw+evdwij
1473 C
1474 C Calculate the components of the gradient in DC and X
1475 C
1476             fac=-rrij*(e1+evdwij)
1477             gg(1)=xj*fac
1478             gg(2)=yj*fac
1479             gg(3)=zj*fac
1480             do k=1,3
1481               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1482               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1483               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1484               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1485             enddo
1486 cgrad            do k=i,j-1
1487 cgrad              do l=1,3
1488 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1489 cgrad              enddo
1490 cgrad            enddo
1491 C
1492 C 12/1/95, revised on 5/20/97
1493 C
1494 C Calculate the contact function. The ith column of the array JCONT will
1495 C contain the numbers of atoms that make contacts with the atom I (of numbers
1496 C greater than I). The arrays FACONT and GACONT will contain the values of
1497 C the contact function and its derivative.
1498 C
1499 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1500 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1501 C Uncomment next line, if the correlation interactions are contact function only
1502             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1503               rij=dsqrt(rij)
1504               sigij=sigma(itypi,itypj)
1505               r0ij=rs0(itypi,itypj)
1506 C
1507 C Check whether the SC's are not too far to make a contact.
1508 C
1509               rcut=1.5d0*r0ij
1510               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1511 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1512 C
1513               if (fcont.gt.0.0D0) then
1514 C If the SC-SC distance if close to sigma, apply spline.
1515 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1516 cAdam &             fcont1,fprimcont1)
1517 cAdam           fcont1=1.0d0-fcont1
1518 cAdam           if (fcont1.gt.0.0d0) then
1519 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1520 cAdam             fcont=fcont*fcont1
1521 cAdam           endif
1522 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1523 cga             do k=1,3
1524 cga               gg(k)=gg(k)*eps0ij
1525 cga             enddo
1526 cga             eps0ij=-evdwij*eps0ij
1527 C Uncomment for AL's type of SC correlation interactions.
1528 cadam           eps0ij=-evdwij
1529                 num_conti=num_conti+1
1530                 jcont(num_conti,i)=j
1531                 facont(num_conti,i)=fcont*eps0ij
1532                 fprimcont=eps0ij*fprimcont/rij
1533                 fcont=expon*fcont
1534 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1535 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1536 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1537 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1538                 gacont(1,num_conti,i)=-fprimcont*xj
1539                 gacont(2,num_conti,i)=-fprimcont*yj
1540                 gacont(3,num_conti,i)=-fprimcont*zj
1541 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1542 cd              write (iout,'(2i3,3f10.5)')
1543 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1544               endif
1545             endif
1546           enddo      ! j
1547         enddo        ! iint
1548 C Change 12/1/95
1549         num_cont(i)=num_conti
1550       enddo          ! i
1551       do i=1,nct
1552         do j=1,3
1553           gvdwc(j,i)=expon*gvdwc(j,i)
1554           gvdwx(j,i)=expon*gvdwx(j,i)
1555         enddo
1556       enddo
1557 C******************************************************************************
1558 C
1559 C                              N O T E !!!
1560 C
1561 C To save time, the factor of EXPON has been extracted from ALL components
1562 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1563 C use!
1564 C
1565 C******************************************************************************
1566       return
1567       end
1568 C-----------------------------------------------------------------------------
1569       subroutine eljk(evdw)
1570 C
1571 C This subroutine calculates the interaction energy of nonbonded side chains
1572 C assuming the LJK potential of interaction.
1573 C
1574       implicit none
1575       include 'DIMENSIONS'
1576       include 'COMMON.GEO'
1577       include 'COMMON.VAR'
1578       include 'COMMON.LOCAL'
1579       include 'COMMON.CHAIN'
1580       include 'COMMON.DERIV'
1581       include 'COMMON.INTERACT'
1582       include 'COMMON.IOUNITS'
1583       include 'COMMON.NAMES'
1584       dimension gg(3)
1585       logical scheck
1586 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1587       evdw=0.0D0
1588       do i=iatsc_s,iatsc_e
1589         itypi=iabs(itype(i))
1590         if (itypi.eq.ntyp1) cycle
1591         itypi1=iabs(itype(i+1))
1592         xi=c(1,nres+i)
1593         yi=c(2,nres+i)
1594         zi=c(3,nres+i)
1595 C
1596 C Calculate SC interaction energy.
1597 C
1598         do iint=1,nint_gr(i)
1599           do j=istart(i,iint),iend(i,iint)
1600             itypj=iabs(itype(j))
1601             if (itypj.eq.ntyp1) cycle
1602             xj=c(1,nres+j)-xi
1603             yj=c(2,nres+j)-yi
1604             zj=c(3,nres+j)-zi
1605             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1606             fac_augm=rrij**expon
1607             e_augm=augm(itypi,itypj)*fac_augm
1608             r_inv_ij=dsqrt(rrij)
1609             rij=1.0D0/r_inv_ij
1610             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1611             fac=r_shift_inv**expon
1612 C have you changed here?
1613             e1=fac*fac*aa
1614             e2=fac*bb
1615             evdwij=e_augm+e1+e2
1616 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1617 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1618 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1619 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1620 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1621 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1622 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1623             evdw=evdw+evdwij
1624 C
1625 C Calculate the components of the gradient in DC and X
1626 C
1627             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1628             gg(1)=xj*fac
1629             gg(2)=yj*fac
1630             gg(3)=zj*fac
1631             do k=1,3
1632               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1633               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1634               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1635               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1636             enddo
1637 cgrad            do k=i,j-1
1638 cgrad              do l=1,3
1639 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1640 cgrad              enddo
1641 cgrad            enddo
1642           enddo      ! j
1643         enddo        ! iint
1644       enddo          ! i
1645       do i=1,nct
1646         do j=1,3
1647           gvdwc(j,i)=expon*gvdwc(j,i)
1648           gvdwx(j,i)=expon*gvdwx(j,i)
1649         enddo
1650       enddo
1651       return
1652       end
1653 C-----------------------------------------------------------------------------
1654       subroutine ebp(evdw)
1655 C
1656 C This subroutine calculates the interaction energy of nonbonded side chains
1657 C assuming the Berne-Pechukas potential of interaction.
1658 C
1659       implicit none
1660       include 'DIMENSIONS'
1661       include 'COMMON.GEO'
1662       include 'COMMON.VAR'
1663       include 'COMMON.LOCAL'
1664       include 'COMMON.CHAIN'
1665       include 'COMMON.DERIV'
1666       include 'COMMON.NAMES'
1667       include 'COMMON.INTERACT'
1668       include 'COMMON.IOUNITS'
1669       include 'COMMON.CALC'
1670       integer icall
1671       common /srutu/ icall
1672 c     double precision rrsave(maxdim)
1673       logical lprn
1674       evdw=0.0D0
1675 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1676       evdw=0.0D0
1677 c     if (icall.eq.0) then
1678 c       lprn=.true.
1679 c     else
1680         lprn=.false.
1681 c     endif
1682       ind=0
1683       do i=iatsc_s,iatsc_e
1684         itypi=iabs(itype(i))
1685         if (itypi.eq.ntyp1) cycle
1686         itypi1=iabs(itype(i+1))
1687         xi=c(1,nres+i)
1688         yi=c(2,nres+i)
1689         zi=c(3,nres+i)
1690         dxi=dc_norm(1,nres+i)
1691         dyi=dc_norm(2,nres+i)
1692         dzi=dc_norm(3,nres+i)
1693 c        dsci_inv=dsc_inv(itypi)
1694         dsci_inv=vbld_inv(i+nres)
1695 C
1696 C Calculate SC interaction energy.
1697 C
1698         do iint=1,nint_gr(i)
1699           do j=istart(i,iint),iend(i,iint)
1700             ind=ind+1
1701             itypj=iabs(itype(j))
1702             if (itypj.eq.ntyp1) cycle
1703 c            dscj_inv=dsc_inv(itypj)
1704             dscj_inv=vbld_inv(j+nres)
1705             chi1=chi(itypi,itypj)
1706             chi2=chi(itypj,itypi)
1707             chi12=chi1*chi2
1708             chip1=chip(itypi)
1709             chip2=chip(itypj)
1710             chip12=chip1*chip2
1711             alf1=alp(itypi)
1712             alf2=alp(itypj)
1713             alf12=0.5D0*(alf1+alf2)
1714 C For diagnostics only!!!
1715 c           chi1=0.0D0
1716 c           chi2=0.0D0
1717 c           chi12=0.0D0
1718 c           chip1=0.0D0
1719 c           chip2=0.0D0
1720 c           chip12=0.0D0
1721 c           alf1=0.0D0
1722 c           alf2=0.0D0
1723 c           alf12=0.0D0
1724             xj=c(1,nres+j)-xi
1725             yj=c(2,nres+j)-yi
1726             zj=c(3,nres+j)-zi
1727             dxj=dc_norm(1,nres+j)
1728             dyj=dc_norm(2,nres+j)
1729             dzj=dc_norm(3,nres+j)
1730             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1731 cd          if (icall.eq.0) then
1732 cd            rrsave(ind)=rrij
1733 cd          else
1734 cd            rrij=rrsave(ind)
1735 cd          endif
1736             rij=dsqrt(rrij)
1737 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1738             call sc_angular
1739 C Calculate whole angle-dependent part of epsilon and contributions
1740 C to its derivatives
1741 C have you changed here?
1742             fac=(rrij*sigsq)**expon2
1743             e1=fac*fac*aa
1744             e2=fac*bb
1745             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1746             eps2der=evdwij*eps3rt
1747             eps3der=evdwij*eps2rt
1748             evdwij=evdwij*eps2rt*eps3rt
1749             evdw=evdw+evdwij
1750             if (lprn) then
1751             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1752             epsi=bb**2/aa
1753 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1754 cd     &        restyp(itypi),i,restyp(itypj),j,
1755 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1756 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1757 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1758 cd     &        evdwij
1759             endif
1760 C Calculate gradient components.
1761             e1=e1*eps1*eps2rt**2*eps3rt**2
1762             fac=-expon*(e1+evdwij)
1763             sigder=fac/sigsq
1764             fac=rrij*fac
1765 C Calculate radial part of the gradient
1766             gg(1)=xj*fac
1767             gg(2)=yj*fac
1768             gg(3)=zj*fac
1769 C Calculate the angular part of the gradient and sum add the contributions
1770 C to the appropriate components of the Cartesian gradient.
1771             call sc_grad
1772           enddo      ! j
1773         enddo        ! iint
1774       enddo          ! i
1775 c     stop
1776       return
1777       end
1778 C-----------------------------------------------------------------------------
1779       subroutine egb(evdw)
1780 C
1781 C This subroutine calculates the interaction energy of nonbonded side chains
1782 C assuming the Gay-Berne potential of interaction.
1783 C
1784       implicit none
1785       include 'DIMENSIONS'
1786       include 'COMMON.GEO'
1787       include 'COMMON.VAR'
1788       include 'COMMON.LOCAL'
1789       include 'COMMON.CHAIN'
1790       include 'COMMON.DERIV'
1791       include 'COMMON.NAMES'
1792       include 'COMMON.INTERACT'
1793       include 'COMMON.IOUNITS'
1794       include 'COMMON.CALC'
1795       include 'COMMON.CONTROL'
1796       include 'COMMON.SPLITELE'
1797       include 'COMMON.SBRIDGE'
1798       logical lprn
1799       integer xshift,yshift,zshift
1800
1801       evdw=0.0D0
1802 ccccc      energy_dec=.false.
1803 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1804       evdw=0.0D0
1805       lprn=.false.
1806 c     if (icall.eq.0) lprn=.false.
1807       ind=0
1808 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1809 C we have the original box)
1810 C      do xshift=-1,1
1811 C      do yshift=-1,1
1812 C      do zshift=-1,1
1813       do i=iatsc_s,iatsc_e
1814         itypi=iabs(itype(i))
1815         if (itypi.eq.ntyp1) cycle
1816         itypi1=iabs(itype(i+1))
1817         xi=c(1,nres+i)
1818         yi=c(2,nres+i)
1819         zi=c(3,nres+i)
1820 C Return atom into box, boxxsize is size of box in x dimension
1821 c  134   continue
1822 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1823 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1824 C Condition for being inside the proper box
1825 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1826 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1827 c        go to 134
1828 c        endif
1829 c  135   continue
1830 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1831 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1832 C Condition for being inside the proper box
1833 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1834 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1835 c        go to 135
1836 c        endif
1837 c  136   continue
1838 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1839 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1840 C Condition for being inside the proper box
1841 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1842 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1843 c        go to 136
1844 c        endif
1845           xi=mod(xi,boxxsize)
1846           if (xi.lt.0) xi=xi+boxxsize
1847           yi=mod(yi,boxysize)
1848           if (yi.lt.0) yi=yi+boxysize
1849           zi=mod(zi,boxzsize)
1850           if (zi.lt.0) zi=zi+boxzsize
1851 C define scaling factor for lipids
1852
1853 C        if (positi.le.0) positi=positi+boxzsize
1854 C        print *,i
1855 C first for peptide groups
1856 c for each residue check if it is in lipid or lipid water border area
1857        if ((zi.gt.bordlipbot)
1858      &.and.(zi.lt.bordliptop)) then
1859 C the energy transfer exist
1860         if (zi.lt.buflipbot) then
1861 C what fraction I am in
1862          fracinbuf=1.0d0-
1863      &        ((zi-bordlipbot)/lipbufthick)
1864 C lipbufthick is thickenes of lipid buffore
1865          sslipi=sscalelip(fracinbuf)
1866          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1867         elseif (zi.gt.bufliptop) then
1868          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1869          sslipi=sscalelip(fracinbuf)
1870          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1871         else
1872          sslipi=1.0d0
1873          ssgradlipi=0.0
1874         endif
1875        else
1876          sslipi=0.0d0
1877          ssgradlipi=0.0
1878        endif
1879
1880 C          xi=xi+xshift*boxxsize
1881 C          yi=yi+yshift*boxysize
1882 C          zi=zi+zshift*boxzsize
1883
1884         dxi=dc_norm(1,nres+i)
1885         dyi=dc_norm(2,nres+i)
1886         dzi=dc_norm(3,nres+i)
1887 c        dsci_inv=dsc_inv(itypi)
1888         dsci_inv=vbld_inv(i+nres)
1889 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1890 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1891 C
1892 C Calculate SC interaction energy.
1893 C
1894         do iint=1,nint_gr(i)
1895           do j=istart(i,iint),iend(i,iint)
1896             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1897
1898 c              write(iout,*) "PRZED ZWYKLE", evdwij
1899               call dyn_ssbond_ene(i,j,evdwij)
1900 c              write(iout,*) "PO ZWYKLE", evdwij
1901
1902               evdw=evdw+evdwij
1903               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1904      &                        'evdw',i,j,evdwij,' ss'
1905 C triple bond artifac removal
1906              do k=j+1,iend(i,iint)
1907 C search over all next residues
1908               if (dyn_ss_mask(k)) then
1909 C check if they are cysteins
1910 C              write(iout,*) 'k=',k
1911
1912 c              write(iout,*) "PRZED TRI", evdwij
1913                evdwij_przed_tri=evdwij
1914               call triple_ssbond_ene(i,j,k,evdwij)
1915 c               if(evdwij_przed_tri.ne.evdwij) then
1916 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1917 c               endif
1918
1919 c              write(iout,*) "PO TRI", evdwij
1920 C call the energy function that removes the artifical triple disulfide
1921 C bond the soubroutine is located in ssMD.F
1922               evdw=evdw+evdwij
1923               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1924      &                        'evdw',i,j,evdwij,'tss'
1925               endif!dyn_ss_mask(k)
1926              enddo! k
1927             ELSE
1928             ind=ind+1
1929             itypj=iabs(itype(j))
1930             if (itypj.eq.ntyp1) cycle
1931 c            dscj_inv=dsc_inv(itypj)
1932             dscj_inv=vbld_inv(j+nres)
1933 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1934 c     &       1.0d0/vbld(j+nres)
1935 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1936             sig0ij=sigma(itypi,itypj)
1937             chi1=chi(itypi,itypj)
1938             chi2=chi(itypj,itypi)
1939             chi12=chi1*chi2
1940             chip1=chip(itypi)
1941             chip2=chip(itypj)
1942             chip12=chip1*chip2
1943             alf1=alp(itypi)
1944             alf2=alp(itypj)
1945             alf12=0.5D0*(alf1+alf2)
1946 C For diagnostics only!!!
1947 c           chi1=0.0D0
1948 c           chi2=0.0D0
1949 c           chi12=0.0D0
1950 c           chip1=0.0D0
1951 c           chip2=0.0D0
1952 c           chip12=0.0D0
1953 c           alf1=0.0D0
1954 c           alf2=0.0D0
1955 c           alf12=0.0D0
1956             xj=c(1,nres+j)
1957             yj=c(2,nres+j)
1958             zj=c(3,nres+j)
1959 C Return atom J into box the original box
1960 c  137   continue
1961 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1962 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1963 C Condition for being inside the proper box
1964 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1965 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1966 c        go to 137
1967 c        endif
1968 c  138   continue
1969 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1970 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1971 C Condition for being inside the proper box
1972 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1973 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1974 c        go to 138
1975 c        endif
1976 c  139   continue
1977 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1978 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1979 C Condition for being inside the proper box
1980 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1981 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1982 c        go to 139
1983 c        endif
1984           xj=mod(xj,boxxsize)
1985           if (xj.lt.0) xj=xj+boxxsize
1986           yj=mod(yj,boxysize)
1987           if (yj.lt.0) yj=yj+boxysize
1988           zj=mod(zj,boxzsize)
1989           if (zj.lt.0) zj=zj+boxzsize
1990        if ((zj.gt.bordlipbot)
1991      &.and.(zj.lt.bordliptop)) then
1992 C the energy transfer exist
1993         if (zj.lt.buflipbot) then
1994 C what fraction I am in
1995          fracinbuf=1.0d0-
1996      &        ((zj-bordlipbot)/lipbufthick)
1997 C lipbufthick is thickenes of lipid buffore
1998          sslipj=sscalelip(fracinbuf)
1999          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2000         elseif (zj.gt.bufliptop) then
2001          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2002          sslipj=sscalelip(fracinbuf)
2003          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2004         else
2005          sslipj=1.0d0
2006          ssgradlipj=0.0
2007         endif
2008        else
2009          sslipj=0.0d0
2010          ssgradlipj=0.0
2011        endif
2012       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2013      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2014       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2015      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2016 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2017 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2018 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2019 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2020 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2021       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2022       xj_safe=xj
2023       yj_safe=yj
2024       zj_safe=zj
2025       subchap=0
2026       do xshift=-1,1
2027       do yshift=-1,1
2028       do zshift=-1,1
2029           xj=xj_safe+xshift*boxxsize
2030           yj=yj_safe+yshift*boxysize
2031           zj=zj_safe+zshift*boxzsize
2032           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2033           if(dist_temp.lt.dist_init) then
2034             dist_init=dist_temp
2035             xj_temp=xj
2036             yj_temp=yj
2037             zj_temp=zj
2038             subchap=1
2039           endif
2040        enddo
2041        enddo
2042        enddo
2043        if (subchap.eq.1) then
2044           xj=xj_temp-xi
2045           yj=yj_temp-yi
2046           zj=zj_temp-zi
2047        else
2048           xj=xj_safe-xi
2049           yj=yj_safe-yi
2050           zj=zj_safe-zi
2051        endif
2052             dxj=dc_norm(1,nres+j)
2053             dyj=dc_norm(2,nres+j)
2054             dzj=dc_norm(3,nres+j)
2055 C            xj=xj-xi
2056 C            yj=yj-yi
2057 C            zj=zj-zi
2058 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2059 c            write (iout,*) "j",j," dc_norm",
2060 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2061             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2062             rij=dsqrt(rrij)
2063             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2064             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2065
2066 c            write (iout,'(a7,4f8.3)')
2067 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2068             if (sss.gt.0.0d0) then
2069 C Calculate angle-dependent terms of energy and contributions to their
2070 C derivatives.
2071             call sc_angular
2072             sigsq=1.0D0/sigsq
2073             sig=sig0ij*dsqrt(sigsq)
2074             rij_shift=1.0D0/rij-sig+sig0ij
2075 c for diagnostics; uncomment
2076 c            rij_shift=1.2*sig0ij
2077 C I hate to put IF's in the loops, but here don't have another choice!!!!
2078             if (rij_shift.le.0.0D0) then
2079               evdw=1.0D20
2080 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2081 cd     &        restyp(itypi),i,restyp(itypj),j,
2082 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2083               return
2084             endif
2085             sigder=-sig*sigsq
2086 c---------------------------------------------------------------
2087             rij_shift=1.0D0/rij_shift
2088             fac=rij_shift**expon
2089 C here to start with
2090 C            if (c(i,3).gt.
2091             faclip=fac
2092             e1=fac*fac*aa
2093             e2=fac*bb
2094             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2095             eps2der=evdwij*eps3rt
2096             eps3der=evdwij*eps2rt
2097 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2098 C     &((sslipi+sslipj)/2.0d0+
2099 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2100 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2101 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2102             evdwij=evdwij*eps2rt*eps3rt
2103             evdw=evdw+evdwij*sss
2104             if (lprn) then
2105             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2106             epsi=bb**2/aa
2107             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2108      &        restyp(itypi),i,restyp(itypj),j,
2109      &        epsi,sigm,chi1,chi2,chip1,chip2,
2110      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2111      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2112      &        evdwij
2113             endif
2114
2115             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2116      &                        'evdw',i,j,evdwij
2117
2118 C Calculate gradient components.
2119             e1=e1*eps1*eps2rt**2*eps3rt**2
2120             fac=-expon*(e1+evdwij)*rij_shift
2121             sigder=fac*sigder
2122             fac=rij*fac
2123 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2124 c     &      evdwij,fac,sigma(itypi,itypj),expon
2125             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2126 c            fac=0.0d0
2127 C Calculate the radial part of the gradient
2128             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2129      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2130      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2131      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2132             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2133             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2134 C            gg_lipi(3)=0.0d0
2135 C            gg_lipj(3)=0.0d0
2136             gg(1)=xj*fac
2137             gg(2)=yj*fac
2138             gg(3)=zj*fac
2139 C Calculate angular part of the gradient.
2140             call sc_grad
2141             endif
2142             ENDIF    ! dyn_ss
2143           enddo      ! j
2144         enddo        ! iint
2145       enddo          ! i
2146 C      enddo          ! zshift
2147 C      enddo          ! yshift
2148 C      enddo          ! xshift
2149 c      write (iout,*) "Number of loop steps in EGB:",ind
2150 cccc      energy_dec=.false.
2151       return
2152       end
2153 C-----------------------------------------------------------------------------
2154       subroutine egbv(evdw)
2155 C
2156 C This subroutine calculates the interaction energy of nonbonded side chains
2157 C assuming the Gay-Berne-Vorobjev potential of interaction.
2158 C
2159       implicit none
2160       include 'DIMENSIONS'
2161       include 'COMMON.GEO'
2162       include 'COMMON.VAR'
2163       include 'COMMON.LOCAL'
2164       include 'COMMON.CHAIN'
2165       include 'COMMON.DERIV'
2166       include 'COMMON.NAMES'
2167       include 'COMMON.INTERACT'
2168       include 'COMMON.IOUNITS'
2169       include 'COMMON.CALC'
2170       integer xshift,yshift,zshift
2171       integer icall
2172       common /srutu/ icall
2173       logical lprn
2174       evdw=0.0D0
2175 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2176       evdw=0.0D0
2177       lprn=.false.
2178 c     if (icall.eq.0) lprn=.true.
2179       ind=0
2180       do i=iatsc_s,iatsc_e
2181         itypi=iabs(itype(i))
2182         if (itypi.eq.ntyp1) cycle
2183         itypi1=iabs(itype(i+1))
2184         xi=c(1,nres+i)
2185         yi=c(2,nres+i)
2186         zi=c(3,nres+i)
2187           xi=mod(xi,boxxsize)
2188           if (xi.lt.0) xi=xi+boxxsize
2189           yi=mod(yi,boxysize)
2190           if (yi.lt.0) yi=yi+boxysize
2191           zi=mod(zi,boxzsize)
2192           if (zi.lt.0) zi=zi+boxzsize
2193 C define scaling factor for lipids
2194
2195 C        if (positi.le.0) positi=positi+boxzsize
2196 C        print *,i
2197 C first for peptide groups
2198 c for each residue check if it is in lipid or lipid water border area
2199        if ((zi.gt.bordlipbot)
2200      &.and.(zi.lt.bordliptop)) then
2201 C the energy transfer exist
2202         if (zi.lt.buflipbot) then
2203 C what fraction I am in
2204          fracinbuf=1.0d0-
2205      &        ((zi-bordlipbot)/lipbufthick)
2206 C lipbufthick is thickenes of lipid buffore
2207          sslipi=sscalelip(fracinbuf)
2208          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2209         elseif (zi.gt.bufliptop) then
2210          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2211          sslipi=sscalelip(fracinbuf)
2212          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2213         else
2214          sslipi=1.0d0
2215          ssgradlipi=0.0
2216         endif
2217        else
2218          sslipi=0.0d0
2219          ssgradlipi=0.0
2220        endif
2221
2222         dxi=dc_norm(1,nres+i)
2223         dyi=dc_norm(2,nres+i)
2224         dzi=dc_norm(3,nres+i)
2225 c        dsci_inv=dsc_inv(itypi)
2226         dsci_inv=vbld_inv(i+nres)
2227 C
2228 C Calculate SC interaction energy.
2229 C
2230         do iint=1,nint_gr(i)
2231           do j=istart(i,iint),iend(i,iint)
2232             ind=ind+1
2233             itypj=iabs(itype(j))
2234             if (itypj.eq.ntyp1) cycle
2235 c            dscj_inv=dsc_inv(itypj)
2236             dscj_inv=vbld_inv(j+nres)
2237             sig0ij=sigma(itypi,itypj)
2238             r0ij=r0(itypi,itypj)
2239             chi1=chi(itypi,itypj)
2240             chi2=chi(itypj,itypi)
2241             chi12=chi1*chi2
2242             chip1=chip(itypi)
2243             chip2=chip(itypj)
2244             chip12=chip1*chip2
2245             alf1=alp(itypi)
2246             alf2=alp(itypj)
2247             alf12=0.5D0*(alf1+alf2)
2248 C For diagnostics only!!!
2249 c           chi1=0.0D0
2250 c           chi2=0.0D0
2251 c           chi12=0.0D0
2252 c           chip1=0.0D0
2253 c           chip2=0.0D0
2254 c           chip12=0.0D0
2255 c           alf1=0.0D0
2256 c           alf2=0.0D0
2257 c           alf12=0.0D0
2258 C            xj=c(1,nres+j)-xi
2259 C            yj=c(2,nres+j)-yi
2260 C            zj=c(3,nres+j)-zi
2261           xj=mod(xj,boxxsize)
2262           if (xj.lt.0) xj=xj+boxxsize
2263           yj=mod(yj,boxysize)
2264           if (yj.lt.0) yj=yj+boxysize
2265           zj=mod(zj,boxzsize)
2266           if (zj.lt.0) zj=zj+boxzsize
2267        if ((zj.gt.bordlipbot)
2268      &.and.(zj.lt.bordliptop)) then
2269 C the energy transfer exist
2270         if (zj.lt.buflipbot) then
2271 C what fraction I am in
2272          fracinbuf=1.0d0-
2273      &        ((zj-bordlipbot)/lipbufthick)
2274 C lipbufthick is thickenes of lipid buffore
2275          sslipj=sscalelip(fracinbuf)
2276          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2277         elseif (zj.gt.bufliptop) then
2278          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2279          sslipj=sscalelip(fracinbuf)
2280          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2281         else
2282          sslipj=1.0d0
2283          ssgradlipj=0.0
2284         endif
2285        else
2286          sslipj=0.0d0
2287          ssgradlipj=0.0
2288        endif
2289       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2290      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2291       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2292      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2293 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2294 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2295 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2296       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2297       xj_safe=xj
2298       yj_safe=yj
2299       zj_safe=zj
2300       subchap=0
2301       do xshift=-1,1
2302       do yshift=-1,1
2303       do zshift=-1,1
2304           xj=xj_safe+xshift*boxxsize
2305           yj=yj_safe+yshift*boxysize
2306           zj=zj_safe+zshift*boxzsize
2307           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2308           if(dist_temp.lt.dist_init) then
2309             dist_init=dist_temp
2310             xj_temp=xj
2311             yj_temp=yj
2312             zj_temp=zj
2313             subchap=1
2314           endif
2315        enddo
2316        enddo
2317        enddo
2318        if (subchap.eq.1) then
2319           xj=xj_temp-xi
2320           yj=yj_temp-yi
2321           zj=zj_temp-zi
2322        else
2323           xj=xj_safe-xi
2324           yj=yj_safe-yi
2325           zj=zj_safe-zi
2326        endif
2327             dxj=dc_norm(1,nres+j)
2328             dyj=dc_norm(2,nres+j)
2329             dzj=dc_norm(3,nres+j)
2330             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2331             rij=dsqrt(rrij)
2332 C Calculate angle-dependent terms of energy and contributions to their
2333 C derivatives.
2334             call sc_angular
2335             sigsq=1.0D0/sigsq
2336             sig=sig0ij*dsqrt(sigsq)
2337             rij_shift=1.0D0/rij-sig+r0ij
2338 C I hate to put IF's in the loops, but here don't have another choice!!!!
2339             if (rij_shift.le.0.0D0) then
2340               evdw=1.0D20
2341               return
2342             endif
2343             sigder=-sig*sigsq
2344 c---------------------------------------------------------------
2345             rij_shift=1.0D0/rij_shift
2346             fac=rij_shift**expon
2347             e1=fac*fac*aa
2348             e2=fac*bb
2349             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2350             eps2der=evdwij*eps3rt
2351             eps3der=evdwij*eps2rt
2352             fac_augm=rrij**expon
2353             e_augm=augm(itypi,itypj)*fac_augm
2354             evdwij=evdwij*eps2rt*eps3rt
2355             evdw=evdw+evdwij+e_augm
2356             if (lprn) then
2357             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2358             epsi=bb**2/aa
2359             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2360      &        restyp(itypi),i,restyp(itypj),j,
2361      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2362      &        chi1,chi2,chip1,chip2,
2363      &        eps1,eps2rt**2,eps3rt**2,
2364      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2365      &        evdwij+e_augm
2366             endif
2367 C Calculate gradient components.
2368             e1=e1*eps1*eps2rt**2*eps3rt**2
2369             fac=-expon*(e1+evdwij)*rij_shift
2370             sigder=fac*sigder
2371             fac=rij*fac-2*expon*rrij*e_augm
2372             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2373 C Calculate the radial part of the gradient
2374             gg(1)=xj*fac
2375             gg(2)=yj*fac
2376             gg(3)=zj*fac
2377 C Calculate angular part of the gradient.
2378             call sc_grad
2379           enddo      ! j
2380         enddo        ! iint
2381       enddo          ! i
2382       end
2383 C-----------------------------------------------------------------------------
2384       subroutine sc_angular
2385 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2386 C om12. Called by ebp, egb, and egbv.
2387       implicit none
2388       include 'COMMON.CALC'
2389       include 'COMMON.IOUNITS'
2390       erij(1)=xj*rij
2391       erij(2)=yj*rij
2392       erij(3)=zj*rij
2393       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2394       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2395       om12=dxi*dxj+dyi*dyj+dzi*dzj
2396       chiom12=chi12*om12
2397 C Calculate eps1(om12) and its derivative in om12
2398       faceps1=1.0D0-om12*chiom12
2399       faceps1_inv=1.0D0/faceps1
2400       eps1=dsqrt(faceps1_inv)
2401 C Following variable is eps1*deps1/dom12
2402       eps1_om12=faceps1_inv*chiom12
2403 c diagnostics only
2404 c      faceps1_inv=om12
2405 c      eps1=om12
2406 c      eps1_om12=1.0d0
2407 c      write (iout,*) "om12",om12," eps1",eps1
2408 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2409 C and om12.
2410       om1om2=om1*om2
2411       chiom1=chi1*om1
2412       chiom2=chi2*om2
2413       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2414       sigsq=1.0D0-facsig*faceps1_inv
2415       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2416       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2417       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2418 c diagnostics only
2419 c      sigsq=1.0d0
2420 c      sigsq_om1=0.0d0
2421 c      sigsq_om2=0.0d0
2422 c      sigsq_om12=0.0d0
2423 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2424 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2425 c     &    " eps1",eps1
2426 C Calculate eps2 and its derivatives in om1, om2, and om12.
2427       chipom1=chip1*om1
2428       chipom2=chip2*om2
2429       chipom12=chip12*om12
2430       facp=1.0D0-om12*chipom12
2431       facp_inv=1.0D0/facp
2432       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2433 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2434 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2435 C Following variable is the square root of eps2
2436       eps2rt=1.0D0-facp1*facp_inv
2437 C Following three variables are the derivatives of the square root of eps
2438 C in om1, om2, and om12.
2439       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2440       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2441       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2442 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2443       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2444 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2445 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2446 c     &  " eps2rt_om12",eps2rt_om12
2447 C Calculate whole angle-dependent part of epsilon and contributions
2448 C to its derivatives
2449       return
2450       end
2451 C----------------------------------------------------------------------------
2452       subroutine sc_grad
2453       implicit none
2454       include 'DIMENSIONS'
2455       include 'COMMON.CHAIN'
2456       include 'COMMON.DERIV'
2457       include 'COMMON.CALC'
2458       include 'COMMON.IOUNITS'
2459       double precision dcosom1(3),dcosom2(3)
2460 cc      print *,'sss=',sss
2461       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2462       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2463       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2464      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2465 c diagnostics only
2466 c      eom1=0.0d0
2467 c      eom2=0.0d0
2468 c      eom12=evdwij*eps1_om12
2469 c end diagnostics
2470 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2471 c     &  " sigder",sigder
2472 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2473 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2474       do k=1,3
2475         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2476         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2477       enddo
2478       do k=1,3
2479         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2480       enddo
2481 c      write (iout,*) "gg",(gg(k),k=1,3)
2482       do k=1,3
2483         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2484      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2485      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2486         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2487      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2488      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2489 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2490 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2491 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2492 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2493       enddo
2494 C
2495 C Calculate the components of the gradient in DC and X
2496 C
2497 cgrad      do k=i,j-1
2498 cgrad        do l=1,3
2499 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2500 cgrad        enddo
2501 cgrad      enddo
2502       do l=1,3
2503         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2504         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2505       enddo
2506       return
2507       end
2508 C-----------------------------------------------------------------------
2509       subroutine e_softsphere(evdw)
2510 C
2511 C This subroutine calculates the interaction energy of nonbonded side chains
2512 C assuming the LJ potential of interaction.
2513 C
2514       implicit none
2515       include 'DIMENSIONS'
2516       parameter (accur=1.0d-10)
2517       include 'COMMON.GEO'
2518       include 'COMMON.VAR'
2519       include 'COMMON.LOCAL'
2520       include 'COMMON.CHAIN'
2521       include 'COMMON.DERIV'
2522       include 'COMMON.INTERACT'
2523       include 'COMMON.TORSION'
2524       include 'COMMON.SBRIDGE'
2525       include 'COMMON.NAMES'
2526       include 'COMMON.IOUNITS'
2527       include 'COMMON.CONTACTS'
2528       dimension gg(3)
2529 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2530       evdw=0.0D0
2531       do i=iatsc_s,iatsc_e
2532         itypi=iabs(itype(i))
2533         if (itypi.eq.ntyp1) cycle
2534         itypi1=iabs(itype(i+1))
2535         xi=c(1,nres+i)
2536         yi=c(2,nres+i)
2537         zi=c(3,nres+i)
2538 C
2539 C Calculate SC interaction energy.
2540 C
2541         do iint=1,nint_gr(i)
2542 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2543 cd   &                  'iend=',iend(i,iint)
2544           do j=istart(i,iint),iend(i,iint)
2545             itypj=iabs(itype(j))
2546             if (itypj.eq.ntyp1) cycle
2547             xj=c(1,nres+j)-xi
2548             yj=c(2,nres+j)-yi
2549             zj=c(3,nres+j)-zi
2550             rij=xj*xj+yj*yj+zj*zj
2551 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2552             r0ij=r0(itypi,itypj)
2553             r0ijsq=r0ij*r0ij
2554 c            print *,i,j,r0ij,dsqrt(rij)
2555             if (rij.lt.r0ijsq) then
2556               evdwij=0.25d0*(rij-r0ijsq)**2
2557               fac=rij-r0ijsq
2558             else
2559               evdwij=0.0d0
2560               fac=0.0d0
2561             endif
2562             evdw=evdw+evdwij
2563 C
2564 C Calculate the components of the gradient in DC and X
2565 C
2566             gg(1)=xj*fac
2567             gg(2)=yj*fac
2568             gg(3)=zj*fac
2569             do k=1,3
2570               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2571               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2572               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2573               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2574             enddo
2575 cgrad            do k=i,j-1
2576 cgrad              do l=1,3
2577 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2578 cgrad              enddo
2579 cgrad            enddo
2580           enddo ! j
2581         enddo ! iint
2582       enddo ! i
2583       return
2584       end
2585 C--------------------------------------------------------------------------
2586       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2587      &              eello_turn4)
2588 C
2589 C Soft-sphere potential of p-p interaction
2590 C
2591       implicit none
2592       include 'DIMENSIONS'
2593       include 'COMMON.CONTROL'
2594       include 'COMMON.IOUNITS'
2595       include 'COMMON.GEO'
2596       include 'COMMON.VAR'
2597       include 'COMMON.LOCAL'
2598       include 'COMMON.CHAIN'
2599       include 'COMMON.DERIV'
2600       include 'COMMON.INTERACT'
2601       include 'COMMON.CONTACTS'
2602       include 'COMMON.TORSION'
2603       include 'COMMON.VECTORS'
2604       include 'COMMON.FFIELD'
2605       dimension ggg(3)
2606       integer xshift,yshift,zshift
2607 C      write(iout,*) 'In EELEC_soft_sphere'
2608       ees=0.0D0
2609       evdw1=0.0D0
2610       eel_loc=0.0d0
2611       eello_turn3=0.0d0
2612       eello_turn4=0.0d0
2613       ind=0
2614       do i=iatel_s,iatel_e
2615         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2616         dxi=dc(1,i)
2617         dyi=dc(2,i)
2618         dzi=dc(3,i)
2619         xmedi=c(1,i)+0.5d0*dxi
2620         ymedi=c(2,i)+0.5d0*dyi
2621         zmedi=c(3,i)+0.5d0*dzi
2622           xmedi=mod(xmedi,boxxsize)
2623           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2624           ymedi=mod(ymedi,boxysize)
2625           if (ymedi.lt.0) ymedi=ymedi+boxysize
2626           zmedi=mod(zmedi,boxzsize)
2627           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2628         num_conti=0
2629 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2630         do j=ielstart(i),ielend(i)
2631           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2632           ind=ind+1
2633           iteli=itel(i)
2634           itelj=itel(j)
2635           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2636           r0ij=rpp(iteli,itelj)
2637           r0ijsq=r0ij*r0ij
2638           dxj=dc(1,j)
2639           dyj=dc(2,j)
2640           dzj=dc(3,j)
2641           xj=c(1,j)+0.5D0*dxj
2642           yj=c(2,j)+0.5D0*dyj
2643           zj=c(3,j)+0.5D0*dzj
2644           xj=mod(xj,boxxsize)
2645           if (xj.lt.0) xj=xj+boxxsize
2646           yj=mod(yj,boxysize)
2647           if (yj.lt.0) yj=yj+boxysize
2648           zj=mod(zj,boxzsize)
2649           if (zj.lt.0) zj=zj+boxzsize
2650       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2651       xj_safe=xj
2652       yj_safe=yj
2653       zj_safe=zj
2654       isubchap=0
2655       do xshift=-1,1
2656       do yshift=-1,1
2657       do zshift=-1,1
2658           xj=xj_safe+xshift*boxxsize
2659           yj=yj_safe+yshift*boxysize
2660           zj=zj_safe+zshift*boxzsize
2661           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2662           if(dist_temp.lt.dist_init) then
2663             dist_init=dist_temp
2664             xj_temp=xj
2665             yj_temp=yj
2666             zj_temp=zj
2667             isubchap=1
2668           endif
2669        enddo
2670        enddo
2671        enddo
2672        if (isubchap.eq.1) then
2673           xj=xj_temp-xmedi
2674           yj=yj_temp-ymedi
2675           zj=zj_temp-zmedi
2676        else
2677           xj=xj_safe-xmedi
2678           yj=yj_safe-ymedi
2679           zj=zj_safe-zmedi
2680        endif
2681           rij=xj*xj+yj*yj+zj*zj
2682             sss=sscale(sqrt(rij))
2683             sssgrad=sscagrad(sqrt(rij))
2684           if (rij.lt.r0ijsq) then
2685             evdw1ij=0.25d0*(rij-r0ijsq)**2
2686             fac=rij-r0ijsq
2687           else
2688             evdw1ij=0.0d0
2689             fac=0.0d0
2690           endif
2691           evdw1=evdw1+evdw1ij*sss
2692 C
2693 C Calculate contributions to the Cartesian gradient.
2694 C
2695           ggg(1)=fac*xj*sssgrad
2696           ggg(2)=fac*yj*sssgrad
2697           ggg(3)=fac*zj*sssgrad
2698           do k=1,3
2699             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2700             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2701           enddo
2702 *
2703 * Loop over residues i+1 thru j-1.
2704 *
2705 cgrad          do k=i+1,j-1
2706 cgrad            do l=1,3
2707 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2708 cgrad            enddo
2709 cgrad          enddo
2710         enddo ! j
2711       enddo   ! i
2712 cgrad      do i=nnt,nct-1
2713 cgrad        do k=1,3
2714 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2715 cgrad        enddo
2716 cgrad        do j=i+1,nct-1
2717 cgrad          do k=1,3
2718 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2719 cgrad          enddo
2720 cgrad        enddo
2721 cgrad      enddo
2722       return
2723       end
2724 c------------------------------------------------------------------------------
2725       subroutine vec_and_deriv
2726       implicit none
2727       include 'DIMENSIONS'
2728 #ifdef MPI
2729       include 'mpif.h'
2730 #endif
2731       include 'COMMON.IOUNITS'
2732       include 'COMMON.GEO'
2733       include 'COMMON.VAR'
2734       include 'COMMON.LOCAL'
2735       include 'COMMON.CHAIN'
2736       include 'COMMON.VECTORS'
2737       include 'COMMON.SETUP'
2738       include 'COMMON.TIME1'
2739       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2740 C Compute the local reference systems. For reference system (i), the
2741 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2742 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2743 #ifdef PARVEC
2744       do i=ivec_start,ivec_end
2745 #else
2746       do i=1,nres-1
2747 #endif
2748           if (i.eq.nres-1) then
2749 C Case of the last full residue
2750 C Compute the Z-axis
2751             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2752             costh=dcos(pi-theta(nres))
2753             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2754             do k=1,3
2755               uz(k,i)=fac*uz(k,i)
2756             enddo
2757 C Compute the derivatives of uz
2758             uzder(1,1,1)= 0.0d0
2759             uzder(2,1,1)=-dc_norm(3,i-1)
2760             uzder(3,1,1)= dc_norm(2,i-1)
2761             uzder(1,2,1)= dc_norm(3,i-1)
2762             uzder(2,2,1)= 0.0d0
2763             uzder(3,2,1)=-dc_norm(1,i-1)
2764             uzder(1,3,1)=-dc_norm(2,i-1)
2765             uzder(2,3,1)= dc_norm(1,i-1)
2766             uzder(3,3,1)= 0.0d0
2767             uzder(1,1,2)= 0.0d0
2768             uzder(2,1,2)= dc_norm(3,i)
2769             uzder(3,1,2)=-dc_norm(2,i)
2770             uzder(1,2,2)=-dc_norm(3,i)
2771             uzder(2,2,2)= 0.0d0
2772             uzder(3,2,2)= dc_norm(1,i)
2773             uzder(1,3,2)= dc_norm(2,i)
2774             uzder(2,3,2)=-dc_norm(1,i)
2775             uzder(3,3,2)= 0.0d0
2776 C Compute the Y-axis
2777             facy=fac
2778             do k=1,3
2779               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2780             enddo
2781 C Compute the derivatives of uy
2782             do j=1,3
2783               do k=1,3
2784                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2785      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2786                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2787               enddo
2788               uyder(j,j,1)=uyder(j,j,1)-costh
2789               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2790             enddo
2791             do j=1,2
2792               do k=1,3
2793                 do l=1,3
2794                   uygrad(l,k,j,i)=uyder(l,k,j)
2795                   uzgrad(l,k,j,i)=uzder(l,k,j)
2796                 enddo
2797               enddo
2798             enddo
2799             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2800             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2801             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2802             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2803           else
2804 C Other residues
2805 C Compute the Z-axis
2806             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2807             costh=dcos(pi-theta(i+2))
2808             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2809             do k=1,3
2810               uz(k,i)=fac*uz(k,i)
2811             enddo
2812 C Compute the derivatives of uz
2813             uzder(1,1,1)= 0.0d0
2814             uzder(2,1,1)=-dc_norm(3,i+1)
2815             uzder(3,1,1)= dc_norm(2,i+1)
2816             uzder(1,2,1)= dc_norm(3,i+1)
2817             uzder(2,2,1)= 0.0d0
2818             uzder(3,2,1)=-dc_norm(1,i+1)
2819             uzder(1,3,1)=-dc_norm(2,i+1)
2820             uzder(2,3,1)= dc_norm(1,i+1)
2821             uzder(3,3,1)= 0.0d0
2822             uzder(1,1,2)= 0.0d0
2823             uzder(2,1,2)= dc_norm(3,i)
2824             uzder(3,1,2)=-dc_norm(2,i)
2825             uzder(1,2,2)=-dc_norm(3,i)
2826             uzder(2,2,2)= 0.0d0
2827             uzder(3,2,2)= dc_norm(1,i)
2828             uzder(1,3,2)= dc_norm(2,i)
2829             uzder(2,3,2)=-dc_norm(1,i)
2830             uzder(3,3,2)= 0.0d0
2831 C Compute the Y-axis
2832             facy=fac
2833             do k=1,3
2834               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2835             enddo
2836 C Compute the derivatives of uy
2837             do j=1,3
2838               do k=1,3
2839                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2840      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2841                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2842               enddo
2843               uyder(j,j,1)=uyder(j,j,1)-costh
2844               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2845             enddo
2846             do j=1,2
2847               do k=1,3
2848                 do l=1,3
2849                   uygrad(l,k,j,i)=uyder(l,k,j)
2850                   uzgrad(l,k,j,i)=uzder(l,k,j)
2851                 enddo
2852               enddo
2853             enddo
2854             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2855             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2856             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2857             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2858           endif
2859       enddo
2860       do i=1,nres-1
2861         vbld_inv_temp(1)=vbld_inv(i+1)
2862         if (i.lt.nres-1) then
2863           vbld_inv_temp(2)=vbld_inv(i+2)
2864           else
2865           vbld_inv_temp(2)=vbld_inv(i)
2866           endif
2867         do j=1,2
2868           do k=1,3
2869             do l=1,3
2870               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2871               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2872             enddo
2873           enddo
2874         enddo
2875       enddo
2876 #if defined(PARVEC) && defined(MPI)
2877       if (nfgtasks1.gt.1) then
2878         time00=MPI_Wtime()
2879 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2880 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2881 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2882         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2883      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2884      &   FG_COMM1,IERR)
2885         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2886      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2887      &   FG_COMM1,IERR)
2888         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2889      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2890      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2891         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2892      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2893      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2894         time_gather=time_gather+MPI_Wtime()-time00
2895       endif
2896 #endif
2897 #ifdef DEBUG
2898       if (fg_rank.eq.0) then
2899         write (iout,*) "Arrays UY and UZ"
2900         do i=1,nres-1
2901           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2902      &     (uz(k,i),k=1,3)
2903         enddo
2904       endif
2905 #endif
2906       return
2907       end
2908 C-----------------------------------------------------------------------------
2909       subroutine check_vecgrad
2910       implicit none
2911       include 'DIMENSIONS'
2912       include 'COMMON.IOUNITS'
2913       include 'COMMON.GEO'
2914       include 'COMMON.VAR'
2915       include 'COMMON.LOCAL'
2916       include 'COMMON.CHAIN'
2917       include 'COMMON.VECTORS'
2918       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2919       dimension uyt(3,maxres),uzt(3,maxres)
2920       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2921       double precision delta /1.0d-7/
2922       call vec_and_deriv
2923 cd      do i=1,nres
2924 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2925 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2926 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2927 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2928 cd     &     (dc_norm(if90,i),if90=1,3)
2929 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2930 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2931 cd          write(iout,'(a)')
2932 cd      enddo
2933       do i=1,nres
2934         do j=1,2
2935           do k=1,3
2936             do l=1,3
2937               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2938               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2939             enddo
2940           enddo
2941         enddo
2942       enddo
2943       call vec_and_deriv
2944       do i=1,nres
2945         do j=1,3
2946           uyt(j,i)=uy(j,i)
2947           uzt(j,i)=uz(j,i)
2948         enddo
2949       enddo
2950       do i=1,nres
2951 cd        write (iout,*) 'i=',i
2952         do k=1,3
2953           erij(k)=dc_norm(k,i)
2954         enddo
2955         do j=1,3
2956           do k=1,3
2957             dc_norm(k,i)=erij(k)
2958           enddo
2959           dc_norm(j,i)=dc_norm(j,i)+delta
2960 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2961 c          do k=1,3
2962 c            dc_norm(k,i)=dc_norm(k,i)/fac
2963 c          enddo
2964 c          write (iout,*) (dc_norm(k,i),k=1,3)
2965 c          write (iout,*) (erij(k),k=1,3)
2966           call vec_and_deriv
2967           do k=1,3
2968             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2969             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2970             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2971             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2972           enddo
2973 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2974 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2975 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2976         enddo
2977         do k=1,3
2978           dc_norm(k,i)=erij(k)
2979         enddo
2980 cd        do k=1,3
2981 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2982 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2983 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2984 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2985 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2986 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2987 cd          write (iout,'(a)')
2988 cd        enddo
2989       enddo
2990       return
2991       end
2992 C--------------------------------------------------------------------------
2993       subroutine set_matrices
2994       implicit none
2995       include 'DIMENSIONS'
2996 #ifdef MPI
2997       include "mpif.h"
2998       include "COMMON.SETUP"
2999       integer IERR
3000       integer status(MPI_STATUS_SIZE)
3001 #endif
3002       include 'COMMON.IOUNITS'
3003       include 'COMMON.GEO'
3004       include 'COMMON.VAR'
3005       include 'COMMON.LOCAL'
3006       include 'COMMON.CHAIN'
3007       include 'COMMON.DERIV'
3008       include 'COMMON.INTERACT'
3009       include 'COMMON.CONTACTS'
3010       include 'COMMON.TORSION'
3011       include 'COMMON.VECTORS'
3012       include 'COMMON.FFIELD'
3013       double precision auxvec(2),auxmat(2,2)
3014 C
3015 C Compute the virtual-bond-torsional-angle dependent quantities needed
3016 C to calculate the el-loc multibody terms of various order.
3017 C
3018 c      write(iout,*) 'nphi=',nphi,nres
3019 c      write(iout,*) "itype2loc",itype2loc
3020 #ifdef PARMAT
3021       do i=ivec_start+2,ivec_end+2
3022 #else
3023       do i=3,nres+1
3024 #endif
3025         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3026           iti = itype2loc(itype(i-2))
3027         else
3028           iti=nloctyp
3029         endif
3030 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3031         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3032           iti1 = itype2loc(itype(i-1))
3033         else
3034           iti1=nloctyp
3035         endif
3036 c        write(iout,*),i
3037 #ifdef NEWCORR
3038         cost1=dcos(theta(i-1))
3039         sint1=dsin(theta(i-1))
3040         sint1sq=sint1*sint1
3041         sint1cub=sint1sq*sint1
3042         sint1cost1=2*sint1*cost1
3043 c        write (iout,*) "bnew1",i,iti
3044 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
3045 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3046 c        write (iout,*) "bnew2",i,iti
3047 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3048 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3049         do k=1,2
3050           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3051           b1(k,i-2)=sint1*b1k
3052           gtb1(k,i-2)=cost1*b1k-sint1sq*
3053      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3054           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3055           b2(k,i-2)=sint1*b2k
3056           gtb2(k,i-2)=cost1*b2k-sint1sq*
3057      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3058         enddo
3059         do k=1,2
3060           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3061           cc(1,k,i-2)=sint1sq*aux
3062           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3063      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3064           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3065           dd(1,k,i-2)=sint1sq*aux
3066           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3067      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3068         enddo
3069         cc(2,1,i-2)=cc(1,2,i-2)
3070         cc(2,2,i-2)=-cc(1,1,i-2)
3071         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3072         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3073         dd(2,1,i-2)=dd(1,2,i-2)
3074         dd(2,2,i-2)=-dd(1,1,i-2)
3075         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3076         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3077         do k=1,2
3078           do l=1,2
3079             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3080             EE(l,k,i-2)=sint1sq*aux
3081             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3082           enddo
3083         enddo
3084         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3085         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3086         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3087         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3088         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3089         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3090         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3091 c        b1tilde(1,i-2)=b1(1,i-2)
3092 c        b1tilde(2,i-2)=-b1(2,i-2)
3093 c        b2tilde(1,i-2)=b2(1,i-2)
3094 c        b2tilde(2,i-2)=-b2(2,i-2)
3095 #ifdef DEBUG
3096         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3097         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3098         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3099         write (iout,*) 'theta=', theta(i-1)
3100 #endif
3101 #else
3102         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3103           iti = itype2loc(itype(i-2))
3104         else
3105           iti=nloctyp
3106         endif
3107 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3108 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3109         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3110           iti1 = itype2loc(itype(i-1))
3111         else
3112           iti1=nloctyp
3113         endif
3114         b1(1,i-2)=b(3,iti)
3115         b1(2,i-2)=b(5,iti)
3116         b2(1,i-2)=b(2,iti)
3117         b2(2,i-2)=b(4,iti)
3118         do k=1,2
3119           do l=1,2
3120            CC(k,l,i-2)=ccold(k,l,iti)
3121            DD(k,l,i-2)=ddold(k,l,iti)
3122            EE(k,l,i-2)=eeold(k,l,iti)
3123            gtEE(k,l,i-2)=0.0d0
3124           enddo
3125         enddo
3126 #endif
3127         b1tilde(1,i-2)= b1(1,i-2)
3128         b1tilde(2,i-2)=-b1(2,i-2)
3129         b2tilde(1,i-2)= b2(1,i-2)
3130         b2tilde(2,i-2)=-b2(2,i-2)
3131 c
3132         Ctilde(1,1,i-2)= CC(1,1,i-2)
3133         Ctilde(1,2,i-2)= CC(1,2,i-2)
3134         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3135         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3136 c
3137         Dtilde(1,1,i-2)= DD(1,1,i-2)
3138         Dtilde(1,2,i-2)= DD(1,2,i-2)
3139         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3140         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3141 #ifdef DEBUG
3142         write(iout,*) "i",i," iti",iti
3143         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3144         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3145 #endif
3146       enddo
3147 #ifdef PARMAT
3148       do i=ivec_start+2,ivec_end+2
3149 #else
3150       do i=3,nres+1
3151 #endif
3152         if (i .lt. nres+1) then
3153           sin1=dsin(phi(i))
3154           cos1=dcos(phi(i))
3155           sintab(i-2)=sin1
3156           costab(i-2)=cos1
3157           obrot(1,i-2)=cos1
3158           obrot(2,i-2)=sin1
3159           sin2=dsin(2*phi(i))
3160           cos2=dcos(2*phi(i))
3161           sintab2(i-2)=sin2
3162           costab2(i-2)=cos2
3163           obrot2(1,i-2)=cos2
3164           obrot2(2,i-2)=sin2
3165           Ug(1,1,i-2)=-cos1
3166           Ug(1,2,i-2)=-sin1
3167           Ug(2,1,i-2)=-sin1
3168           Ug(2,2,i-2)= cos1
3169           Ug2(1,1,i-2)=-cos2
3170           Ug2(1,2,i-2)=-sin2
3171           Ug2(2,1,i-2)=-sin2
3172           Ug2(2,2,i-2)= cos2
3173         else
3174           costab(i-2)=1.0d0
3175           sintab(i-2)=0.0d0
3176           obrot(1,i-2)=1.0d0
3177           obrot(2,i-2)=0.0d0
3178           obrot2(1,i-2)=0.0d0
3179           obrot2(2,i-2)=0.0d0
3180           Ug(1,1,i-2)=1.0d0
3181           Ug(1,2,i-2)=0.0d0
3182           Ug(2,1,i-2)=0.0d0
3183           Ug(2,2,i-2)=1.0d0
3184           Ug2(1,1,i-2)=0.0d0
3185           Ug2(1,2,i-2)=0.0d0
3186           Ug2(2,1,i-2)=0.0d0
3187           Ug2(2,2,i-2)=0.0d0
3188         endif
3189         if (i .gt. 3 .and. i .lt. nres+1) then
3190           obrot_der(1,i-2)=-sin1
3191           obrot_der(2,i-2)= cos1
3192           Ugder(1,1,i-2)= sin1
3193           Ugder(1,2,i-2)=-cos1
3194           Ugder(2,1,i-2)=-cos1
3195           Ugder(2,2,i-2)=-sin1
3196           dwacos2=cos2+cos2
3197           dwasin2=sin2+sin2
3198           obrot2_der(1,i-2)=-dwasin2
3199           obrot2_der(2,i-2)= dwacos2
3200           Ug2der(1,1,i-2)= dwasin2
3201           Ug2der(1,2,i-2)=-dwacos2
3202           Ug2der(2,1,i-2)=-dwacos2
3203           Ug2der(2,2,i-2)=-dwasin2
3204         else
3205           obrot_der(1,i-2)=0.0d0
3206           obrot_der(2,i-2)=0.0d0
3207           Ugder(1,1,i-2)=0.0d0
3208           Ugder(1,2,i-2)=0.0d0
3209           Ugder(2,1,i-2)=0.0d0
3210           Ugder(2,2,i-2)=0.0d0
3211           obrot2_der(1,i-2)=0.0d0
3212           obrot2_der(2,i-2)=0.0d0
3213           Ug2der(1,1,i-2)=0.0d0
3214           Ug2der(1,2,i-2)=0.0d0
3215           Ug2der(2,1,i-2)=0.0d0
3216           Ug2der(2,2,i-2)=0.0d0
3217         endif
3218 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3219         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3220           iti = itype2loc(itype(i-2))
3221         else
3222           iti=nloctyp
3223         endif
3224 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3225         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3226           iti1 = itype2loc(itype(i-1))
3227         else
3228           iti1=nloctyp
3229         endif
3230 cd        write (iout,*) '*******i',i,' iti1',iti
3231 cd        write (iout,*) 'b1',b1(:,iti)
3232 cd        write (iout,*) 'b2',b2(:,iti)
3233 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3234 c        if (i .gt. iatel_s+2) then
3235         if (i .gt. nnt+2) then
3236           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3237 #ifdef NEWCORR
3238           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3239 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3240 #endif
3241 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3242 c     &    EE(1,2,iti),EE(2,2,i)
3243           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3244           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3245 c          write(iout,*) "Macierz EUG",
3246 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3247 c     &    eug(2,2,i-2)
3248           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3249      &    then
3250           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3251           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3252           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3253           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3254           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3255           endif
3256         else
3257           do k=1,2
3258             Ub2(k,i-2)=0.0d0
3259             Ctobr(k,i-2)=0.0d0
3260             Dtobr2(k,i-2)=0.0d0
3261             do l=1,2
3262               EUg(l,k,i-2)=0.0d0
3263               CUg(l,k,i-2)=0.0d0
3264               DUg(l,k,i-2)=0.0d0
3265               DtUg2(l,k,i-2)=0.0d0
3266             enddo
3267           enddo
3268         endif
3269         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3270         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3271         do k=1,2
3272           muder(k,i-2)=Ub2der(k,i-2)
3273         enddo
3274 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3275         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3276           if (itype(i-1).le.ntyp) then
3277             iti1 = itype2loc(itype(i-1))
3278           else
3279             iti1=nloctyp
3280           endif
3281         else
3282           iti1=nloctyp
3283         endif
3284         do k=1,2
3285           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3286 c          mu(k,i-2)=b1(k,i-1)
3287 c          mu(k,i-2)=Ub2(k,i-2)
3288         enddo
3289 #ifdef MUOUT
3290         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3291      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3292      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3293      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3294      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3295      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3296 #endif
3297 cd        write (iout,*) 'mu1',mu1(:,i-2)
3298 cd        write (iout,*) 'mu2',mu2(:,i-2)
3299 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3300         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3301      &  then
3302         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3303         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3304         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3305         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3306         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3307 C Vectors and matrices dependent on a single virtual-bond dihedral.
3308         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3309         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3310         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3311         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3312         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3313         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3314         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3315         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3316         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3317         endif
3318       enddo
3319 C Matrices dependent on two consecutive virtual-bond dihedrals.
3320 C The order of matrices is from left to right.
3321       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3322      &then
3323 c      do i=max0(ivec_start,2),ivec_end
3324       do i=2,nres-1
3325         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3326         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3327         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3328         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3329         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3330         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3331         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3332         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3333       enddo
3334       endif
3335 #if defined(MPI) && defined(PARMAT)
3336 #ifdef DEBUG
3337 c      if (fg_rank.eq.0) then
3338         write (iout,*) "Arrays UG and UGDER before GATHER"
3339         do i=1,nres-1
3340           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3341      &     ((ug(l,k,i),l=1,2),k=1,2),
3342      &     ((ugder(l,k,i),l=1,2),k=1,2)
3343         enddo
3344         write (iout,*) "Arrays UG2 and UG2DER"
3345         do i=1,nres-1
3346           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3347      &     ((ug2(l,k,i),l=1,2),k=1,2),
3348      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3349         enddo
3350         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3351         do i=1,nres-1
3352           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3353      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3354      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3355         enddo
3356         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3357         do i=1,nres-1
3358           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3359      &     costab(i),sintab(i),costab2(i),sintab2(i)
3360         enddo
3361         write (iout,*) "Array MUDER"
3362         do i=1,nres-1
3363           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3364         enddo
3365 c      endif
3366 #endif
3367       if (nfgtasks.gt.1) then
3368         time00=MPI_Wtime()
3369 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3370 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3371 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3372 #ifdef MATGATHER
3373         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3374      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3375      &   FG_COMM1,IERR)
3376         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3377      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3378      &   FG_COMM1,IERR)
3379         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3380      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3381      &   FG_COMM1,IERR)
3382         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3383      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3384      &   FG_COMM1,IERR)
3385         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3386      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3387      &   FG_COMM1,IERR)
3388         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3389      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3390      &   FG_COMM1,IERR)
3391         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3392      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3393      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3394         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3395      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3396      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3397         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3398      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3399      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3400         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3401      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3402      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3403         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3404      &  then
3405         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3406      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3407      &   FG_COMM1,IERR)
3408         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3409      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3410      &   FG_COMM1,IERR)
3411         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3412      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3413      &   FG_COMM1,IERR)
3414        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3415      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3416      &   FG_COMM1,IERR)
3417         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3418      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3419      &   FG_COMM1,IERR)
3420         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3421      &   ivec_count(fg_rank1),
3422      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3423      &   FG_COMM1,IERR)
3424         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3425      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3426      &   FG_COMM1,IERR)
3427         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3428      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3429      &   FG_COMM1,IERR)
3430         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3431      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3432      &   FG_COMM1,IERR)
3433         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3434      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3435      &   FG_COMM1,IERR)
3436         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3437      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3438      &   FG_COMM1,IERR)
3439         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3440      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3441      &   FG_COMM1,IERR)
3442         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3443      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3444      &   FG_COMM1,IERR)
3445         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3446      &   ivec_count(fg_rank1),
3447      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3448      &   FG_COMM1,IERR)
3449         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3450      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3451      &   FG_COMM1,IERR)
3452        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3453      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3454      &   FG_COMM1,IERR)
3455         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3456      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3457      &   FG_COMM1,IERR)
3458        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3459      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3460      &   FG_COMM1,IERR)
3461         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3462      &   ivec_count(fg_rank1),
3463      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3464      &   FG_COMM1,IERR)
3465         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3466      &   ivec_count(fg_rank1),
3467      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3468      &   FG_COMM1,IERR)
3469         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3470      &   ivec_count(fg_rank1),
3471      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3472      &   MPI_MAT2,FG_COMM1,IERR)
3473         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3474      &   ivec_count(fg_rank1),
3475      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3476      &   MPI_MAT2,FG_COMM1,IERR)
3477         endif
3478 #else
3479 c Passes matrix info through the ring
3480       isend=fg_rank1
3481       irecv=fg_rank1-1
3482       if (irecv.lt.0) irecv=nfgtasks1-1
3483       iprev=irecv
3484       inext=fg_rank1+1
3485       if (inext.ge.nfgtasks1) inext=0
3486       do i=1,nfgtasks1-1
3487 c        write (iout,*) "isend",isend," irecv",irecv
3488 c        call flush(iout)
3489         lensend=lentyp(isend)
3490         lenrecv=lentyp(irecv)
3491 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3492 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3493 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3494 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3495 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3496 c        write (iout,*) "Gather ROTAT1"
3497 c        call flush(iout)
3498 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3499 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3500 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3501 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3502 c        write (iout,*) "Gather ROTAT2"
3503 c        call flush(iout)
3504         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3505      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3506      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3507      &   iprev,4400+irecv,FG_COMM,status,IERR)
3508 c        write (iout,*) "Gather ROTAT_OLD"
3509 c        call flush(iout)
3510         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3511      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3512      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3513      &   iprev,5500+irecv,FG_COMM,status,IERR)
3514 c        write (iout,*) "Gather PRECOMP11"
3515 c        call flush(iout)
3516         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3517      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3518      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3519      &   iprev,6600+irecv,FG_COMM,status,IERR)
3520 c        write (iout,*) "Gather PRECOMP12"
3521 c        call flush(iout)
3522         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3523      &  then
3524         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3525      &   MPI_ROTAT2(lensend),inext,7700+isend,
3526      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3527      &   iprev,7700+irecv,FG_COMM,status,IERR)
3528 c        write (iout,*) "Gather PRECOMP21"
3529 c        call flush(iout)
3530         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3531      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3532      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3533      &   iprev,8800+irecv,FG_COMM,status,IERR)
3534 c        write (iout,*) "Gather PRECOMP22"
3535 c        call flush(iout)
3536         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3537      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3538      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3539      &   MPI_PRECOMP23(lenrecv),
3540      &   iprev,9900+irecv,FG_COMM,status,IERR)
3541 c        write (iout,*) "Gather PRECOMP23"
3542 c        call flush(iout)
3543         endif
3544         isend=irecv
3545         irecv=irecv-1
3546         if (irecv.lt.0) irecv=nfgtasks1-1
3547       enddo
3548 #endif
3549         time_gather=time_gather+MPI_Wtime()-time00
3550       endif
3551 #ifdef DEBUG
3552 c      if (fg_rank.eq.0) then
3553         write (iout,*) "Arrays UG and UGDER"
3554         do i=1,nres-1
3555           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3556      &     ((ug(l,k,i),l=1,2),k=1,2),
3557      &     ((ugder(l,k,i),l=1,2),k=1,2)
3558         enddo
3559         write (iout,*) "Arrays UG2 and UG2DER"
3560         do i=1,nres-1
3561           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3562      &     ((ug2(l,k,i),l=1,2),k=1,2),
3563      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3564         enddo
3565         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3566         do i=1,nres-1
3567           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3568      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3569      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3570         enddo
3571         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3572         do i=1,nres-1
3573           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3574      &     costab(i),sintab(i),costab2(i),sintab2(i)
3575         enddo
3576         write (iout,*) "Array MUDER"
3577         do i=1,nres-1
3578           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3579         enddo
3580 c      endif
3581 #endif
3582 #endif
3583 cd      do i=1,nres
3584 cd        iti = itype2loc(itype(i))
3585 cd        write (iout,*) i
3586 cd        do j=1,2
3587 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3588 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3589 cd        enddo
3590 cd      enddo
3591       return
3592       end
3593 C--------------------------------------------------------------------------
3594       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3595 C
3596 C This subroutine calculates the average interaction energy and its gradient
3597 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3598 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3599 C The potential depends both on the distance of peptide-group centers and on
3600 C the orientation of the CA-CA virtual bonds.
3601 C
3602       implicit none
3603 #ifdef MPI
3604       include 'mpif.h'
3605 #endif
3606       include 'DIMENSIONS'
3607       include 'COMMON.CONTROL'
3608       include 'COMMON.SETUP'
3609       include 'COMMON.IOUNITS'
3610       include 'COMMON.GEO'
3611       include 'COMMON.VAR'
3612       include 'COMMON.LOCAL'
3613       include 'COMMON.CHAIN'
3614       include 'COMMON.DERIV'
3615       include 'COMMON.INTERACT'
3616       include 'COMMON.CONTACTS'
3617       include 'COMMON.TORSION'
3618       include 'COMMON.VECTORS'
3619       include 'COMMON.FFIELD'
3620       include 'COMMON.TIME1'
3621       include 'COMMON.SPLITELE'
3622       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3623      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3624       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3625      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3626       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3627      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3628      &    num_conti,j1,j2
3629 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3630 #ifdef MOMENT
3631       double precision scal_el /1.0d0/
3632 #else
3633       double precision scal_el /0.5d0/
3634 #endif
3635 C 12/13/98
3636 C 13-go grudnia roku pamietnego...
3637       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3638      &                   0.0d0,1.0d0,0.0d0,
3639      &                   0.0d0,0.0d0,1.0d0/
3640 cd      write(iout,*) 'In EELEC'
3641 cd      do i=1,nloctyp
3642 cd        write(iout,*) 'Type',i
3643 cd        write(iout,*) 'B1',B1(:,i)
3644 cd        write(iout,*) 'B2',B2(:,i)
3645 cd        write(iout,*) 'CC',CC(:,:,i)
3646 cd        write(iout,*) 'DD',DD(:,:,i)
3647 cd        write(iout,*) 'EE',EE(:,:,i)
3648 cd      enddo
3649 cd      call check_vecgrad
3650 cd      stop
3651       if (icheckgrad.eq.1) then
3652         do i=1,nres-1
3653           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3654           do k=1,3
3655             dc_norm(k,i)=dc(k,i)*fac
3656           enddo
3657 c          write (iout,*) 'i',i,' fac',fac
3658         enddo
3659       endif
3660       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3661      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3662      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3663 c        call vec_and_deriv
3664 #ifdef TIMING
3665         time01=MPI_Wtime()
3666 #endif
3667         call set_matrices
3668 #ifdef TIMING
3669         time_mat=time_mat+MPI_Wtime()-time01
3670 #endif
3671       endif
3672 cd      do i=1,nres-1
3673 cd        write (iout,*) 'i=',i
3674 cd        do k=1,3
3675 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3676 cd        enddo
3677 cd        do k=1,3
3678 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3679 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3680 cd        enddo
3681 cd      enddo
3682       t_eelecij=0.0d0
3683       ees=0.0D0
3684       evdw1=0.0D0
3685       eel_loc=0.0d0
3686       eello_turn3=0.0d0
3687       eello_turn4=0.0d0
3688       ind=0
3689       do i=1,nres
3690         num_cont_hb(i)=0
3691       enddo
3692 cd      print '(a)','Enter EELEC'
3693 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3694       do i=1,nres
3695         gel_loc_loc(i)=0.0d0
3696         gcorr_loc(i)=0.0d0
3697       enddo
3698 c
3699 c
3700 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3701 C
3702 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3703 C
3704 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3705       do i=iturn3_start,iturn3_end
3706 c        if (i.le.1) cycle
3707 C        write(iout,*) "tu jest i",i
3708         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3709 C changes suggested by Ana to avoid out of bounds
3710 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3711 c     & .or.((i+4).gt.nres)
3712 c     & .or.((i-1).le.0)
3713 C end of changes by Ana
3714      &  .or. itype(i+2).eq.ntyp1
3715      &  .or. itype(i+3).eq.ntyp1) cycle
3716 C Adam: Instructions below will switch off existing interactions
3717 c        if(i.gt.1)then
3718 c          if(itype(i-1).eq.ntyp1)cycle
3719 c        end if
3720 c        if(i.LT.nres-3)then
3721 c          if (itype(i+4).eq.ntyp1) cycle
3722 c        end if
3723         dxi=dc(1,i)
3724         dyi=dc(2,i)
3725         dzi=dc(3,i)
3726         dx_normi=dc_norm(1,i)
3727         dy_normi=dc_norm(2,i)
3728         dz_normi=dc_norm(3,i)
3729         xmedi=c(1,i)+0.5d0*dxi
3730         ymedi=c(2,i)+0.5d0*dyi
3731         zmedi=c(3,i)+0.5d0*dzi
3732           xmedi=mod(xmedi,boxxsize)
3733           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3734           ymedi=mod(ymedi,boxysize)
3735           if (ymedi.lt.0) ymedi=ymedi+boxysize
3736           zmedi=mod(zmedi,boxzsize)
3737           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3738         num_conti=0
3739         call eelecij(i,i+2,ees,evdw1,eel_loc)
3740         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3741         num_cont_hb(i)=num_conti
3742       enddo
3743       do i=iturn4_start,iturn4_end
3744         if (i.lt.1) cycle
3745         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3746 C changes suggested by Ana to avoid out of bounds
3747 c     & .or.((i+5).gt.nres)
3748 c     & .or.((i-1).le.0)
3749 C end of changes suggested by Ana
3750      &    .or. itype(i+3).eq.ntyp1
3751      &    .or. itype(i+4).eq.ntyp1
3752 c     &    .or. itype(i+5).eq.ntyp1
3753 c     &    .or. itype(i).eq.ntyp1
3754 c     &    .or. itype(i-1).eq.ntyp1
3755      &                             ) cycle
3756         dxi=dc(1,i)
3757         dyi=dc(2,i)
3758         dzi=dc(3,i)
3759         dx_normi=dc_norm(1,i)
3760         dy_normi=dc_norm(2,i)
3761         dz_normi=dc_norm(3,i)
3762         xmedi=c(1,i)+0.5d0*dxi
3763         ymedi=c(2,i)+0.5d0*dyi
3764         zmedi=c(3,i)+0.5d0*dzi
3765 C Return atom into box, boxxsize is size of box in x dimension
3766 c  194   continue
3767 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3768 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3769 C Condition for being inside the proper box
3770 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3771 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3772 c        go to 194
3773 c        endif
3774 c  195   continue
3775 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3776 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3777 C Condition for being inside the proper box
3778 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3779 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3780 c        go to 195
3781 c        endif
3782 c  196   continue
3783 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3784 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3785 C Condition for being inside the proper box
3786 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3787 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3788 c        go to 196
3789 c        endif
3790           xmedi=mod(xmedi,boxxsize)
3791           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3792           ymedi=mod(ymedi,boxysize)
3793           if (ymedi.lt.0) ymedi=ymedi+boxysize
3794           zmedi=mod(zmedi,boxzsize)
3795           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3796
3797         num_conti=num_cont_hb(i)
3798 c        write(iout,*) "JESTEM W PETLI"
3799         call eelecij(i,i+3,ees,evdw1,eel_loc)
3800         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3801      &   call eturn4(i,eello_turn4)
3802         num_cont_hb(i)=num_conti
3803       enddo   ! i
3804 C Loop over all neighbouring boxes
3805 C      do xshift=-1,1
3806 C      do yshift=-1,1
3807 C      do zshift=-1,1
3808 c
3809 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3810 c
3811 CTU KURWA
3812       do i=iatel_s,iatel_e
3813 C        do i=75,75
3814 c        if (i.le.1) cycle
3815         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3816 C changes suggested by Ana to avoid out of bounds
3817 c     & .or.((i+2).gt.nres)
3818 c     & .or.((i-1).le.0)
3819 C end of changes by Ana
3820 c     &  .or. itype(i+2).eq.ntyp1
3821 c     &  .or. itype(i-1).eq.ntyp1
3822      &                ) cycle
3823         dxi=dc(1,i)
3824         dyi=dc(2,i)
3825         dzi=dc(3,i)
3826         dx_normi=dc_norm(1,i)
3827         dy_normi=dc_norm(2,i)
3828         dz_normi=dc_norm(3,i)
3829         xmedi=c(1,i)+0.5d0*dxi
3830         ymedi=c(2,i)+0.5d0*dyi
3831         zmedi=c(3,i)+0.5d0*dzi
3832           xmedi=mod(xmedi,boxxsize)
3833           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3834           ymedi=mod(ymedi,boxysize)
3835           if (ymedi.lt.0) ymedi=ymedi+boxysize
3836           zmedi=mod(zmedi,boxzsize)
3837           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3838 C          xmedi=xmedi+xshift*boxxsize
3839 C          ymedi=ymedi+yshift*boxysize
3840 C          zmedi=zmedi+zshift*boxzsize
3841
3842 C Return tom into box, boxxsize is size of box in x dimension
3843 c  164   continue
3844 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3845 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3846 C Condition for being inside the proper box
3847 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3848 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3849 c        go to 164
3850 c        endif
3851 c  165   continue
3852 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3853 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3854 C Condition for being inside the proper box
3855 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3856 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3857 c        go to 165
3858 c        endif
3859 c  166   continue
3860 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3861 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3862 cC Condition for being inside the proper box
3863 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3864 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3865 c        go to 166
3866 c        endif
3867
3868 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3869         num_conti=num_cont_hb(i)
3870 C I TU KURWA
3871         do j=ielstart(i),ielend(i)
3872 C          do j=16,17
3873 C          write (iout,*) i,j
3874 C         if (j.le.1) cycle
3875           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3876 C changes suggested by Ana to avoid out of bounds
3877 c     & .or.((j+2).gt.nres)
3878 c     & .or.((j-1).le.0)
3879 C end of changes by Ana
3880 c     & .or.itype(j+2).eq.ntyp1
3881 c     & .or.itype(j-1).eq.ntyp1
3882      &) cycle
3883           call eelecij(i,j,ees,evdw1,eel_loc)
3884         enddo ! j
3885         num_cont_hb(i)=num_conti
3886       enddo   ! i
3887 C     enddo   ! zshift
3888 C      enddo   ! yshift
3889 C      enddo   ! xshift
3890
3891 c      write (iout,*) "Number of loop steps in EELEC:",ind
3892 cd      do i=1,nres
3893 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3894 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3895 cd      enddo
3896 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3897 ccc      eel_loc=eel_loc+eello_turn3
3898 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3899       return
3900       end
3901 C-------------------------------------------------------------------------------
3902       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3903       implicit none
3904       include 'DIMENSIONS'
3905 #ifdef MPI
3906       include "mpif.h"
3907 #endif
3908       include 'COMMON.CONTROL'
3909       include 'COMMON.IOUNITS'
3910       include 'COMMON.GEO'
3911       include 'COMMON.VAR'
3912       include 'COMMON.LOCAL'
3913       include 'COMMON.CHAIN'
3914       include 'COMMON.DERIV'
3915       include 'COMMON.INTERACT'
3916       include 'COMMON.CONTACTS'
3917       include 'COMMON.TORSION'
3918       include 'COMMON.VECTORS'
3919       include 'COMMON.FFIELD'
3920       include 'COMMON.TIME1'
3921       include 'COMMON.SPLITELE'
3922       include 'COMMON.SHIELD'
3923       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3924      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3925       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3926      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3927      &    gmuij2(4),gmuji2(4)
3928       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3929      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3930      &    num_conti,j1,j2
3931 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3932 #ifdef MOMENT
3933       double precision scal_el /1.0d0/
3934 #else
3935       double precision scal_el /0.5d0/
3936 #endif
3937 C 12/13/98
3938 C 13-go grudnia roku pamietnego...
3939       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3940      &                   0.0d0,1.0d0,0.0d0,
3941      &                   0.0d0,0.0d0,1.0d0/
3942        integer xshift,yshift,zshift
3943 c          time00=MPI_Wtime()
3944 cd      write (iout,*) "eelecij",i,j
3945 c          ind=ind+1
3946           iteli=itel(i)
3947           itelj=itel(j)
3948           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3949           aaa=app(iteli,itelj)
3950           bbb=bpp(iteli,itelj)
3951           ael6i=ael6(iteli,itelj)
3952           ael3i=ael3(iteli,itelj)
3953           dxj=dc(1,j)
3954           dyj=dc(2,j)
3955           dzj=dc(3,j)
3956           dx_normj=dc_norm(1,j)
3957           dy_normj=dc_norm(2,j)
3958           dz_normj=dc_norm(3,j)
3959 C          xj=c(1,j)+0.5D0*dxj-xmedi
3960 C          yj=c(2,j)+0.5D0*dyj-ymedi
3961 C          zj=c(3,j)+0.5D0*dzj-zmedi
3962           xj=c(1,j)+0.5D0*dxj
3963           yj=c(2,j)+0.5D0*dyj
3964           zj=c(3,j)+0.5D0*dzj
3965           xj=mod(xj,boxxsize)
3966           if (xj.lt.0) xj=xj+boxxsize
3967           yj=mod(yj,boxysize)
3968           if (yj.lt.0) yj=yj+boxysize
3969           zj=mod(zj,boxzsize)
3970           if (zj.lt.0) zj=zj+boxzsize
3971           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3972       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3973       xj_safe=xj
3974       yj_safe=yj
3975       zj_safe=zj
3976       isubchap=0
3977       do xshift=-1,1
3978       do yshift=-1,1
3979       do zshift=-1,1
3980           xj=xj_safe+xshift*boxxsize
3981           yj=yj_safe+yshift*boxysize
3982           zj=zj_safe+zshift*boxzsize
3983           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3984           if(dist_temp.lt.dist_init) then
3985             dist_init=dist_temp
3986             xj_temp=xj
3987             yj_temp=yj
3988             zj_temp=zj
3989             isubchap=1
3990           endif
3991        enddo
3992        enddo
3993        enddo
3994        if (isubchap.eq.1) then
3995           xj=xj_temp-xmedi
3996           yj=yj_temp-ymedi
3997           zj=zj_temp-zmedi
3998        else
3999           xj=xj_safe-xmedi
4000           yj=yj_safe-ymedi
4001           zj=zj_safe-zmedi
4002        endif
4003 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4004 c  174   continue
4005 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4006 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4007 C Condition for being inside the proper box
4008 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4009 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4010 c        go to 174
4011 c        endif
4012 c  175   continue
4013 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4014 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4015 C Condition for being inside the proper box
4016 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4017 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4018 c        go to 175
4019 c        endif
4020 c  176   continue
4021 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4022 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4023 C Condition for being inside the proper box
4024 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4025 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4026 c        go to 176
4027 c        endif
4028 C        endif !endPBC condintion
4029 C        xj=xj-xmedi
4030 C        yj=yj-ymedi
4031 C        zj=zj-zmedi
4032           rij=xj*xj+yj*yj+zj*zj
4033
4034             sss=sscale(sqrt(rij))
4035             sssgrad=sscagrad(sqrt(rij))
4036 c            if (sss.gt.0.0d0) then
4037           rrmij=1.0D0/rij
4038           rij=dsqrt(rij)
4039           rmij=1.0D0/rij
4040           r3ij=rrmij*rmij
4041           r6ij=r3ij*r3ij
4042           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4043           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4044           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4045           fac=cosa-3.0D0*cosb*cosg
4046           ev1=aaa*r6ij*r6ij
4047 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4048           if (j.eq.i+2) ev1=scal_el*ev1
4049           ev2=bbb*r6ij
4050           fac3=ael6i*r6ij
4051           fac4=ael3i*r3ij
4052           evdwij=(ev1+ev2)
4053           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4054           el2=fac4*fac
4055 C MARYSIA
4056 C          eesij=(el1+el2)
4057 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4058           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4059           if (shield_mode.gt.0) then
4060 C          fac_shield(i)=0.4
4061 C          fac_shield(j)=0.6
4062           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4063           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4064           eesij=(el1+el2)
4065           ees=ees+eesij
4066           else
4067           fac_shield(i)=1.0
4068           fac_shield(j)=1.0
4069           eesij=(el1+el2)
4070           ees=ees+eesij
4071           endif
4072           evdw1=evdw1+evdwij*sss
4073 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4074 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4075 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4076 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4077
4078           if (energy_dec) then
4079               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4080      &'evdw1',i,j,evdwij
4081      &,iteli,itelj,aaa,evdw1,sss
4082               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4083      &fac_shield(i),fac_shield(j)
4084           endif
4085
4086 C
4087 C Calculate contributions to the Cartesian gradient.
4088 C
4089 #ifdef SPLITELE
4090           facvdw=-6*rrmij*(ev1+evdwij)*sss
4091           facel=-3*rrmij*(el1+eesij)
4092           fac1=fac
4093           erij(1)=xj*rmij
4094           erij(2)=yj*rmij
4095           erij(3)=zj*rmij
4096
4097 *
4098 * Radial derivatives. First process both termini of the fragment (i,j)
4099 *
4100           ggg(1)=facel*xj
4101           ggg(2)=facel*yj
4102           ggg(3)=facel*zj
4103           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4104      &  (shield_mode.gt.0)) then
4105 C          print *,i,j
4106           do ilist=1,ishield_list(i)
4107            iresshield=shield_list(ilist,i)
4108            do k=1,3
4109            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4110      &      *2.0
4111            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4112      &              rlocshield
4113      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4114             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4115 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4116 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4117 C             if (iresshield.gt.i) then
4118 C               do ishi=i+1,iresshield-1
4119 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4120 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4121 C
4122 C              enddo
4123 C             else
4124 C               do ishi=iresshield,i
4125 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4126 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4127 C
4128 C               enddo
4129 C              endif
4130            enddo
4131           enddo
4132           do ilist=1,ishield_list(j)
4133            iresshield=shield_list(ilist,j)
4134            do k=1,3
4135            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4136      &     *2.0
4137            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4138      &              rlocshield
4139      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4140            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4141
4142 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4143 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4144 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4145 C             if (iresshield.gt.j) then
4146 C               do ishi=j+1,iresshield-1
4147 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4148 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4149 C
4150 C               enddo
4151 C            else
4152 C               do ishi=iresshield,j
4153 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4154 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4155 C               enddo
4156 C              endif
4157            enddo
4158           enddo
4159
4160           do k=1,3
4161             gshieldc(k,i)=gshieldc(k,i)+
4162      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4163             gshieldc(k,j)=gshieldc(k,j)+
4164      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4165             gshieldc(k,i-1)=gshieldc(k,i-1)+
4166      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4167             gshieldc(k,j-1)=gshieldc(k,j-1)+
4168      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4169
4170            enddo
4171            endif
4172 c          do k=1,3
4173 c            ghalf=0.5D0*ggg(k)
4174 c            gelc(k,i)=gelc(k,i)+ghalf
4175 c            gelc(k,j)=gelc(k,j)+ghalf
4176 c          enddo
4177 c 9/28/08 AL Gradient compotents will be summed only at the end
4178 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4179           do k=1,3
4180             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4181 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4182             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4183 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4184 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4185 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4186 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4187 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4188           enddo
4189 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4190
4191 *
4192 * Loop over residues i+1 thru j-1.
4193 *
4194 cgrad          do k=i+1,j-1
4195 cgrad            do l=1,3
4196 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4197 cgrad            enddo
4198 cgrad          enddo
4199           if (sss.gt.0.0) then
4200           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4201           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4202           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4203           else
4204           ggg(1)=0.0
4205           ggg(2)=0.0
4206           ggg(3)=0.0
4207           endif
4208 c          do k=1,3
4209 c            ghalf=0.5D0*ggg(k)
4210 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4211 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4212 c          enddo
4213 c 9/28/08 AL Gradient compotents will be summed only at the end
4214           do k=1,3
4215             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4216             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4217           enddo
4218 *
4219 * Loop over residues i+1 thru j-1.
4220 *
4221 cgrad          do k=i+1,j-1
4222 cgrad            do l=1,3
4223 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4224 cgrad            enddo
4225 cgrad          enddo
4226 #else
4227 C MARYSIA
4228           facvdw=(ev1+evdwij)*sss
4229           facel=(el1+eesij)
4230           fac1=fac
4231           fac=-3*rrmij*(facvdw+facvdw+facel)
4232           erij(1)=xj*rmij
4233           erij(2)=yj*rmij
4234           erij(3)=zj*rmij
4235 *
4236 * Radial derivatives. First process both termini of the fragment (i,j)
4237 *
4238           ggg(1)=fac*xj
4239 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4240           ggg(2)=fac*yj
4241 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4242           ggg(3)=fac*zj
4243 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4244 c          do k=1,3
4245 c            ghalf=0.5D0*ggg(k)
4246 c            gelc(k,i)=gelc(k,i)+ghalf
4247 c            gelc(k,j)=gelc(k,j)+ghalf
4248 c          enddo
4249 c 9/28/08 AL Gradient compotents will be summed only at the end
4250           do k=1,3
4251             gelc_long(k,j)=gelc(k,j)+ggg(k)
4252             gelc_long(k,i)=gelc(k,i)-ggg(k)
4253           enddo
4254 *
4255 * Loop over residues i+1 thru j-1.
4256 *
4257 cgrad          do k=i+1,j-1
4258 cgrad            do l=1,3
4259 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4260 cgrad            enddo
4261 cgrad          enddo
4262 c 9/28/08 AL Gradient compotents will be summed only at the end
4263           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4264           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4265           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4266           do k=1,3
4267             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4268             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4269           enddo
4270 #endif
4271 *
4272 * Angular part
4273 *
4274           ecosa=2.0D0*fac3*fac1+fac4
4275           fac4=-3.0D0*fac4
4276           fac3=-6.0D0*fac3
4277           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4278           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4279           do k=1,3
4280             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4281             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4282           enddo
4283 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4284 cd   &          (dcosg(k),k=1,3)
4285           do k=1,3
4286             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4287      &      fac_shield(i)**2*fac_shield(j)**2
4288           enddo
4289 c          do k=1,3
4290 c            ghalf=0.5D0*ggg(k)
4291 c            gelc(k,i)=gelc(k,i)+ghalf
4292 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4293 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4294 c            gelc(k,j)=gelc(k,j)+ghalf
4295 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4296 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4297 c          enddo
4298 cgrad          do k=i+1,j-1
4299 cgrad            do l=1,3
4300 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4301 cgrad            enddo
4302 cgrad          enddo
4303 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4304           do k=1,3
4305             gelc(k,i)=gelc(k,i)
4306      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4307      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4308      &           *fac_shield(i)**2*fac_shield(j)**2
4309             gelc(k,j)=gelc(k,j)
4310      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4311      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4312      &           *fac_shield(i)**2*fac_shield(j)**2
4313             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4314             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4315           enddo
4316 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4317
4318 C MARYSIA
4319 c          endif !sscale
4320           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4321      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4322      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4323 C
4324 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4325 C   energy of a peptide unit is assumed in the form of a second-order
4326 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4327 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4328 C   are computed for EVERY pair of non-contiguous peptide groups.
4329 C
4330
4331           if (j.lt.nres-1) then
4332             j1=j+1
4333             j2=j-1
4334           else
4335             j1=j-1
4336             j2=j-2
4337           endif
4338           kkk=0
4339           lll=0
4340           do k=1,2
4341             do l=1,2
4342               kkk=kkk+1
4343               muij(kkk)=mu(k,i)*mu(l,j)
4344 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4345 #ifdef NEWCORR
4346              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4347 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4348              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4349              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4350 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4351              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4352 #endif
4353             enddo
4354           enddo
4355 #ifdef DEBUG
4356           write (iout,*) 'EELEC: i',i,' j',j
4357           write (iout,*) 'j',j,' j1',j1,' j2',j2
4358           write(iout,*) 'muij',muij
4359 #endif
4360           ury=scalar(uy(1,i),erij)
4361           urz=scalar(uz(1,i),erij)
4362           vry=scalar(uy(1,j),erij)
4363           vrz=scalar(uz(1,j),erij)
4364           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4365           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4366           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4367           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4368           fac=dsqrt(-ael6i)*r3ij
4369 #ifdef DEBUG
4370           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4371           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4372      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4373      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4374      &      "uzvz",scalar(uz(1,i),uz(1,j))
4375           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4376           write (iout,*) "fac",fac
4377 #endif
4378           a22=a22*fac
4379           a23=a23*fac
4380           a32=a32*fac
4381           a33=a33*fac
4382 #ifdef DEBUG
4383           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4384 #endif
4385 #undef DEBUG
4386 cd          write (iout,'(4i5,4f10.5)')
4387 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4388 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4389 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4390 cd     &      uy(:,j),uz(:,j)
4391 cd          write (iout,'(4f10.5)')
4392 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4393 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4394 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4395 cd           write (iout,'(9f10.5/)')
4396 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4397 C Derivatives of the elements of A in virtual-bond vectors
4398           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4399           do k=1,3
4400             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4401             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4402             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4403             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4404             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4405             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4406             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4407             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4408             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4409             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4410             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4411             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4412           enddo
4413 C Compute radial contributions to the gradient
4414           facr=-3.0d0*rrmij
4415           a22der=a22*facr
4416           a23der=a23*facr
4417           a32der=a32*facr
4418           a33der=a33*facr
4419           agg(1,1)=a22der*xj
4420           agg(2,1)=a22der*yj
4421           agg(3,1)=a22der*zj
4422           agg(1,2)=a23der*xj
4423           agg(2,2)=a23der*yj
4424           agg(3,2)=a23der*zj
4425           agg(1,3)=a32der*xj
4426           agg(2,3)=a32der*yj
4427           agg(3,3)=a32der*zj
4428           agg(1,4)=a33der*xj
4429           agg(2,4)=a33der*yj
4430           agg(3,4)=a33der*zj
4431 C Add the contributions coming from er
4432           fac3=-3.0d0*fac
4433           do k=1,3
4434             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4435             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4436             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4437             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4438           enddo
4439           do k=1,3
4440 C Derivatives in DC(i)
4441 cgrad            ghalf1=0.5d0*agg(k,1)
4442 cgrad            ghalf2=0.5d0*agg(k,2)
4443 cgrad            ghalf3=0.5d0*agg(k,3)
4444 cgrad            ghalf4=0.5d0*agg(k,4)
4445             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4446      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4447             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4448      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4449             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4450      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4451             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4452      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4453 C Derivatives in DC(i+1)
4454             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4455      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4456             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4457      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4458             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4459      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4460             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4461      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4462 C Derivatives in DC(j)
4463             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4464      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4465             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4466      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4467             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4468      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4469             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4470      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4471 C Derivatives in DC(j+1) or DC(nres-1)
4472             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4473      &      -3.0d0*vryg(k,3)*ury)
4474             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4475      &      -3.0d0*vrzg(k,3)*ury)
4476             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4477      &      -3.0d0*vryg(k,3)*urz)
4478             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4479      &      -3.0d0*vrzg(k,3)*urz)
4480 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4481 cgrad              do l=1,4
4482 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4483 cgrad              enddo
4484 cgrad            endif
4485           enddo
4486           acipa(1,1)=a22
4487           acipa(1,2)=a23
4488           acipa(2,1)=a32
4489           acipa(2,2)=a33
4490           a22=-a22
4491           a23=-a23
4492           do l=1,2
4493             do k=1,3
4494               agg(k,l)=-agg(k,l)
4495               aggi(k,l)=-aggi(k,l)
4496               aggi1(k,l)=-aggi1(k,l)
4497               aggj(k,l)=-aggj(k,l)
4498               aggj1(k,l)=-aggj1(k,l)
4499             enddo
4500           enddo
4501           if (j.lt.nres-1) then
4502             a22=-a22
4503             a32=-a32
4504             do l=1,3,2
4505               do k=1,3
4506                 agg(k,l)=-agg(k,l)
4507                 aggi(k,l)=-aggi(k,l)
4508                 aggi1(k,l)=-aggi1(k,l)
4509                 aggj(k,l)=-aggj(k,l)
4510                 aggj1(k,l)=-aggj1(k,l)
4511               enddo
4512             enddo
4513           else
4514             a22=-a22
4515             a23=-a23
4516             a32=-a32
4517             a33=-a33
4518             do l=1,4
4519               do k=1,3
4520                 agg(k,l)=-agg(k,l)
4521                 aggi(k,l)=-aggi(k,l)
4522                 aggi1(k,l)=-aggi1(k,l)
4523                 aggj(k,l)=-aggj(k,l)
4524                 aggj1(k,l)=-aggj1(k,l)
4525               enddo
4526             enddo
4527           endif
4528           ENDIF ! WCORR
4529           IF (wel_loc.gt.0.0d0) THEN
4530 C Contribution to the local-electrostatic energy coming from the i-j pair
4531           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4532      &     +a33*muij(4)
4533 #ifdef DEBUG
4534           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4535      &     " a33",a33
4536           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4537      &     " wel_loc",wel_loc
4538 #endif
4539           if (shield_mode.eq.0) then
4540            fac_shield(i)=1.0
4541            fac_shield(j)=1.0
4542 C          else
4543 C           fac_shield(i)=0.4
4544 C           fac_shield(j)=0.6
4545           endif
4546           eel_loc_ij=eel_loc_ij
4547      &    *fac_shield(i)*fac_shield(j)
4548 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4549 c     &            'eelloc',i,j,eel_loc_ij
4550 C Now derivative over eel_loc
4551           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4552      &  (shield_mode.gt.0)) then
4553 C          print *,i,j
4554
4555           do ilist=1,ishield_list(i)
4556            iresshield=shield_list(ilist,i)
4557            do k=1,3
4558            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4559      &                                          /fac_shield(i)
4560 C     &      *2.0
4561            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4562      &              rlocshield
4563      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4564             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4565      &      +rlocshield
4566            enddo
4567           enddo
4568           do ilist=1,ishield_list(j)
4569            iresshield=shield_list(ilist,j)
4570            do k=1,3
4571            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4572      &                                       /fac_shield(j)
4573 C     &     *2.0
4574            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4575      &              rlocshield
4576      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4577            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4578      &             +rlocshield
4579
4580            enddo
4581           enddo
4582
4583           do k=1,3
4584             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4585      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4586             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4587      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4588             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4589      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4590             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4591      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4592            enddo
4593            endif
4594
4595
4596 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4597 c     &                     ' eel_loc_ij',eel_loc_ij
4598 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4599 C Calculate patrial derivative for theta angle
4600 #ifdef NEWCORR
4601          geel_loc_ij=(a22*gmuij1(1)
4602      &     +a23*gmuij1(2)
4603      &     +a32*gmuij1(3)
4604      &     +a33*gmuij1(4))
4605      &    *fac_shield(i)*fac_shield(j)
4606 c         write(iout,*) "derivative over thatai"
4607 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4608 c     &   a33*gmuij1(4)
4609          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4610      &      geel_loc_ij*wel_loc
4611 c         write(iout,*) "derivative over thatai-1"
4612 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4613 c     &   a33*gmuij2(4)
4614          geel_loc_ij=
4615      &     a22*gmuij2(1)
4616      &     +a23*gmuij2(2)
4617      &     +a32*gmuij2(3)
4618      &     +a33*gmuij2(4)
4619          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4620      &      geel_loc_ij*wel_loc
4621      &    *fac_shield(i)*fac_shield(j)
4622
4623 c  Derivative over j residue
4624          geel_loc_ji=a22*gmuji1(1)
4625      &     +a23*gmuji1(2)
4626      &     +a32*gmuji1(3)
4627      &     +a33*gmuji1(4)
4628 c         write(iout,*) "derivative over thataj"
4629 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4630 c     &   a33*gmuji1(4)
4631
4632         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4633      &      geel_loc_ji*wel_loc
4634      &    *fac_shield(i)*fac_shield(j)
4635
4636          geel_loc_ji=
4637      &     +a22*gmuji2(1)
4638      &     +a23*gmuji2(2)
4639      &     +a32*gmuji2(3)
4640      &     +a33*gmuji2(4)
4641 c         write(iout,*) "derivative over thataj-1"
4642 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4643 c     &   a33*gmuji2(4)
4644          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4645      &      geel_loc_ji*wel_loc
4646      &    *fac_shield(i)*fac_shield(j)
4647 #endif
4648 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4649
4650           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4651      &            'eelloc',i,j,eel_loc_ij
4652 c           if (eel_loc_ij.ne.0)
4653 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4654 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4655
4656           eel_loc=eel_loc+eel_loc_ij
4657 C Partial derivatives in virtual-bond dihedral angles gamma
4658           if (i.gt.1)
4659      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4660      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4661      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4662      &    *fac_shield(i)*fac_shield(j)
4663
4664           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4665      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4666      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4667      &    *fac_shield(i)*fac_shield(j)
4668 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4669           do l=1,3
4670             ggg(l)=(agg(l,1)*muij(1)+
4671      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4672      &    *fac_shield(i)*fac_shield(j)
4673             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4674             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4675 cgrad            ghalf=0.5d0*ggg(l)
4676 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4677 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4678           enddo
4679 cgrad          do k=i+1,j2
4680 cgrad            do l=1,3
4681 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4682 cgrad            enddo
4683 cgrad          enddo
4684 C Remaining derivatives of eello
4685           do l=1,3
4686             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4687      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4688      &    *fac_shield(i)*fac_shield(j)
4689
4690             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4691      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4692      &    *fac_shield(i)*fac_shield(j)
4693
4694             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4695      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4696      &    *fac_shield(i)*fac_shield(j)
4697
4698             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4699      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4700      &    *fac_shield(i)*fac_shield(j)
4701
4702           enddo
4703           ENDIF
4704 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4705 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4706           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4707      &       .and. num_conti.le.maxconts) then
4708 c            write (iout,*) i,j," entered corr"
4709 C
4710 C Calculate the contact function. The ith column of the array JCONT will
4711 C contain the numbers of atoms that make contacts with the atom I (of numbers
4712 C greater than I). The arrays FACONT and GACONT will contain the values of
4713 C the contact function and its derivative.
4714 c           r0ij=1.02D0*rpp(iteli,itelj)
4715 c           r0ij=1.11D0*rpp(iteli,itelj)
4716             r0ij=2.20D0*rpp(iteli,itelj)
4717 c           r0ij=1.55D0*rpp(iteli,itelj)
4718             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4719             if (fcont.gt.0.0D0) then
4720               num_conti=num_conti+1
4721               if (num_conti.gt.maxconts) then
4722                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4723      &                         ' will skip next contacts for this conf.'
4724               else
4725                 jcont_hb(num_conti,i)=j
4726 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4727 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4728                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4729      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4730 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4731 C  terms.
4732                 d_cont(num_conti,i)=rij
4733 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4734 C     --- Electrostatic-interaction matrix ---
4735                 a_chuj(1,1,num_conti,i)=a22
4736                 a_chuj(1,2,num_conti,i)=a23
4737                 a_chuj(2,1,num_conti,i)=a32
4738                 a_chuj(2,2,num_conti,i)=a33
4739 C     --- Gradient of rij
4740                 do kkk=1,3
4741                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4742                 enddo
4743                 kkll=0
4744                 do k=1,2
4745                   do l=1,2
4746                     kkll=kkll+1
4747                     do m=1,3
4748                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4749                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4750                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4751                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4752                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4753                     enddo
4754                   enddo
4755                 enddo
4756                 ENDIF
4757                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4758 C Calculate contact energies
4759                 cosa4=4.0D0*cosa
4760                 wij=cosa-3.0D0*cosb*cosg
4761                 cosbg1=cosb+cosg
4762                 cosbg2=cosb-cosg
4763 c               fac3=dsqrt(-ael6i)/r0ij**3
4764                 fac3=dsqrt(-ael6i)*r3ij
4765 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4766                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4767                 if (ees0tmp.gt.0) then
4768                   ees0pij=dsqrt(ees0tmp)
4769                 else
4770                   ees0pij=0
4771                 endif
4772 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4773                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4774                 if (ees0tmp.gt.0) then
4775                   ees0mij=dsqrt(ees0tmp)
4776                 else
4777                   ees0mij=0
4778                 endif
4779 c               ees0mij=0.0D0
4780                 if (shield_mode.eq.0) then
4781                 fac_shield(i)=1.0d0
4782                 fac_shield(j)=1.0d0
4783                 else
4784                 ees0plist(num_conti,i)=j
4785 C                fac_shield(i)=0.4d0
4786 C                fac_shield(j)=0.6d0
4787                 endif
4788                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4789      &          *fac_shield(i)*fac_shield(j)
4790                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4791      &          *fac_shield(i)*fac_shield(j)
4792 C Diagnostics. Comment out or remove after debugging!
4793 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4794 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4795 c               ees0m(num_conti,i)=0.0D0
4796 C End diagnostics.
4797 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4798 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4799 C Angular derivatives of the contact function
4800                 ees0pij1=fac3/ees0pij
4801                 ees0mij1=fac3/ees0mij
4802                 fac3p=-3.0D0*fac3*rrmij
4803                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4804                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4805 c               ees0mij1=0.0D0
4806                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4807                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4808                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4809                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4810                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4811                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4812                 ecosap=ecosa1+ecosa2
4813                 ecosbp=ecosb1+ecosb2
4814                 ecosgp=ecosg1+ecosg2
4815                 ecosam=ecosa1-ecosa2
4816                 ecosbm=ecosb1-ecosb2
4817                 ecosgm=ecosg1-ecosg2
4818 C Diagnostics
4819 c               ecosap=ecosa1
4820 c               ecosbp=ecosb1
4821 c               ecosgp=ecosg1
4822 c               ecosam=0.0D0
4823 c               ecosbm=0.0D0
4824 c               ecosgm=0.0D0
4825 C End diagnostics
4826                 facont_hb(num_conti,i)=fcont
4827                 fprimcont=fprimcont/rij
4828 cd              facont_hb(num_conti,i)=1.0D0
4829 C Following line is for diagnostics.
4830 cd              fprimcont=0.0D0
4831                 do k=1,3
4832                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4833                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4834                 enddo
4835                 do k=1,3
4836                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4837                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4838                 enddo
4839                 gggp(1)=gggp(1)+ees0pijp*xj
4840                 gggp(2)=gggp(2)+ees0pijp*yj
4841                 gggp(3)=gggp(3)+ees0pijp*zj
4842                 gggm(1)=gggm(1)+ees0mijp*xj
4843                 gggm(2)=gggm(2)+ees0mijp*yj
4844                 gggm(3)=gggm(3)+ees0mijp*zj
4845 C Derivatives due to the contact function
4846                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4847                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4848                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4849                 do k=1,3
4850 c
4851 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4852 c          following the change of gradient-summation algorithm.
4853 c
4854 cgrad                  ghalfp=0.5D0*gggp(k)
4855 cgrad                  ghalfm=0.5D0*gggm(k)
4856                   gacontp_hb1(k,num_conti,i)=!ghalfp
4857      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4858      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4859      &          *fac_shield(i)*fac_shield(j)
4860
4861                   gacontp_hb2(k,num_conti,i)=!ghalfp
4862      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4863      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4864      &          *fac_shield(i)*fac_shield(j)
4865
4866                   gacontp_hb3(k,num_conti,i)=gggp(k)
4867      &          *fac_shield(i)*fac_shield(j)
4868
4869                   gacontm_hb1(k,num_conti,i)=!ghalfm
4870      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4871      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4872      &          *fac_shield(i)*fac_shield(j)
4873
4874                   gacontm_hb2(k,num_conti,i)=!ghalfm
4875      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4876      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4877      &          *fac_shield(i)*fac_shield(j)
4878
4879                   gacontm_hb3(k,num_conti,i)=gggm(k)
4880      &          *fac_shield(i)*fac_shield(j)
4881
4882                 enddo
4883 C Diagnostics. Comment out or remove after debugging!
4884 cdiag           do k=1,3
4885 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4886 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4887 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4888 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4889 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4890 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4891 cdiag           enddo
4892               ENDIF ! wcorr
4893               endif  ! num_conti.le.maxconts
4894             endif  ! fcont.gt.0
4895           endif    ! j.gt.i+1
4896           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4897             do k=1,4
4898               do l=1,3
4899                 ghalf=0.5d0*agg(l,k)
4900                 aggi(l,k)=aggi(l,k)+ghalf
4901                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4902                 aggj(l,k)=aggj(l,k)+ghalf
4903               enddo
4904             enddo
4905             if (j.eq.nres-1 .and. i.lt.j-2) then
4906               do k=1,4
4907                 do l=1,3
4908                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4909                 enddo
4910               enddo
4911             endif
4912           endif
4913 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4914       return
4915       end
4916 C-----------------------------------------------------------------------------
4917       subroutine eturn3(i,eello_turn3)
4918 C Third- and fourth-order contributions from turns
4919       implicit none
4920       include 'DIMENSIONS'
4921       include 'COMMON.IOUNITS'
4922       include 'COMMON.GEO'
4923       include 'COMMON.VAR'
4924       include 'COMMON.LOCAL'
4925       include 'COMMON.CHAIN'
4926       include 'COMMON.DERIV'
4927       include 'COMMON.INTERACT'
4928       include 'COMMON.CONTACTS'
4929       include 'COMMON.TORSION'
4930       include 'COMMON.VECTORS'
4931       include 'COMMON.FFIELD'
4932       include 'COMMON.CONTROL'
4933       include 'COMMON.SHIELD'
4934       dimension ggg(3)
4935       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4936      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4937      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4938      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4939      &  auxgmat2(2,2),auxgmatt2(2,2)
4940       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4941      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4942       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4943      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4944      &    num_conti,j1,j2
4945       j=i+2
4946 c      write (iout,*) "eturn3",i,j,j1,j2
4947       a_temp(1,1)=a22
4948       a_temp(1,2)=a23
4949       a_temp(2,1)=a32
4950       a_temp(2,2)=a33
4951 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4952 C
4953 C               Third-order contributions
4954 C
4955 C                 (i+2)o----(i+3)
4956 C                      | |
4957 C                      | |
4958 C                 (i+1)o----i
4959 C
4960 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4961 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4962         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4963 c auxalary matices for theta gradient
4964 c auxalary matrix for i+1 and constant i+2
4965         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4966 c auxalary matrix for i+2 and constant i+1
4967         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4968         call transpose2(auxmat(1,1),auxmat1(1,1))
4969         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4970         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4971         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4972         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4973         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4974         if (shield_mode.eq.0) then
4975         fac_shield(i)=1.0
4976         fac_shield(j)=1.0
4977 C        else
4978 C        fac_shield(i)=0.4
4979 C        fac_shield(j)=0.6
4980         endif
4981         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4982      &  *fac_shield(i)*fac_shield(j)
4983         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4984      &  *fac_shield(i)*fac_shield(j)
4985         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4986      &    eello_t3
4987 C#ifdef NEWCORR
4988 C Derivatives in theta
4989         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4990      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4991      &   *fac_shield(i)*fac_shield(j)
4992         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4993      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4994      &   *fac_shield(i)*fac_shield(j)
4995 C#endif
4996
4997 C Derivatives in shield mode
4998           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4999      &  (shield_mode.gt.0)) then
5000 C          print *,i,j
5001
5002           do ilist=1,ishield_list(i)
5003            iresshield=shield_list(ilist,i)
5004            do k=1,3
5005            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5006 C     &      *2.0
5007            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5008      &              rlocshield
5009      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5010             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5011      &      +rlocshield
5012            enddo
5013           enddo
5014           do ilist=1,ishield_list(j)
5015            iresshield=shield_list(ilist,j)
5016            do k=1,3
5017            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5018 C     &     *2.0
5019            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5020      &              rlocshield
5021      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5022            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5023      &             +rlocshield
5024
5025            enddo
5026           enddo
5027
5028           do k=1,3
5029             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5030      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5031             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5032      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5033             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5034      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5035             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5036      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5037            enddo
5038            endif
5039
5040 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5041 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5042 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5043 cd     &    ' eello_turn3_num',4*eello_turn3_num
5044 C Derivatives in gamma(i)
5045         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5046         call transpose2(auxmat2(1,1),auxmat3(1,1))
5047         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5048         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5049      &   *fac_shield(i)*fac_shield(j)
5050 C Derivatives in gamma(i+1)
5051         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5052         call transpose2(auxmat2(1,1),auxmat3(1,1))
5053         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5054         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5055      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5056      &   *fac_shield(i)*fac_shield(j)
5057 C Cartesian derivatives
5058         do l=1,3
5059 c            ghalf1=0.5d0*agg(l,1)
5060 c            ghalf2=0.5d0*agg(l,2)
5061 c            ghalf3=0.5d0*agg(l,3)
5062 c            ghalf4=0.5d0*agg(l,4)
5063           a_temp(1,1)=aggi(l,1)!+ghalf1
5064           a_temp(1,2)=aggi(l,2)!+ghalf2
5065           a_temp(2,1)=aggi(l,3)!+ghalf3
5066           a_temp(2,2)=aggi(l,4)!+ghalf4
5067           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5068           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5069      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5070      &   *fac_shield(i)*fac_shield(j)
5071
5072           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5073           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5074           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5075           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5076           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5077           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5078      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5079      &   *fac_shield(i)*fac_shield(j)
5080           a_temp(1,1)=aggj(l,1)!+ghalf1
5081           a_temp(1,2)=aggj(l,2)!+ghalf2
5082           a_temp(2,1)=aggj(l,3)!+ghalf3
5083           a_temp(2,2)=aggj(l,4)!+ghalf4
5084           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5085           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5086      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5087      &   *fac_shield(i)*fac_shield(j)
5088           a_temp(1,1)=aggj1(l,1)
5089           a_temp(1,2)=aggj1(l,2)
5090           a_temp(2,1)=aggj1(l,3)
5091           a_temp(2,2)=aggj1(l,4)
5092           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5093           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5094      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5095      &   *fac_shield(i)*fac_shield(j)
5096         enddo
5097       return
5098       end
5099 C-------------------------------------------------------------------------------
5100       subroutine eturn4(i,eello_turn4)
5101 C Third- and fourth-order contributions from turns
5102       implicit none
5103       include 'DIMENSIONS'
5104       include 'COMMON.IOUNITS'
5105       include 'COMMON.GEO'
5106       include 'COMMON.VAR'
5107       include 'COMMON.LOCAL'
5108       include 'COMMON.CHAIN'
5109       include 'COMMON.DERIV'
5110       include 'COMMON.INTERACT'
5111       include 'COMMON.CONTACTS'
5112       include 'COMMON.TORSION'
5113       include 'COMMON.VECTORS'
5114       include 'COMMON.FFIELD'
5115       include 'COMMON.CONTROL'
5116       include 'COMMON.SHIELD'
5117       dimension ggg(3)
5118       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5119      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5120      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5121      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5122      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5123      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5124      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5125       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5126      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5127       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5128      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5129      &    num_conti,j1,j2
5130       j=i+3
5131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5132 C
5133 C               Fourth-order contributions
5134 C
5135 C                 (i+3)o----(i+4)
5136 C                     /  |
5137 C               (i+2)o   |
5138 C                     \  |
5139 C                 (i+1)o----i
5140 C
5141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5142 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5143 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5144 c        write(iout,*)"WCHODZE W PROGRAM"
5145         a_temp(1,1)=a22
5146         a_temp(1,2)=a23
5147         a_temp(2,1)=a32
5148         a_temp(2,2)=a33
5149         iti1=itype2loc(itype(i+1))
5150         iti2=itype2loc(itype(i+2))
5151         iti3=itype2loc(itype(i+3))
5152 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5153         call transpose2(EUg(1,1,i+1),e1t(1,1))
5154         call transpose2(Eug(1,1,i+2),e2t(1,1))
5155         call transpose2(Eug(1,1,i+3),e3t(1,1))
5156 C Ematrix derivative in theta
5157         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5158         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5159         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5160         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5161 c       eta1 in derivative theta
5162         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5163         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5164 c       auxgvec is derivative of Ub2 so i+3 theta
5165         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5166 c       auxalary matrix of E i+1
5167         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5168 c        s1=0.0
5169 c        gs1=0.0
5170         s1=scalar2(b1(1,i+2),auxvec(1))
5171 c derivative of theta i+2 with constant i+3
5172         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5173 c derivative of theta i+2 with constant i+2
5174         gs32=scalar2(b1(1,i+2),auxgvec(1))
5175 c derivative of E matix in theta of i+1
5176         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5177
5178         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5179 c       ea31 in derivative theta
5180         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5181         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5182 c auxilary matrix auxgvec of Ub2 with constant E matirx
5183         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5184 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5185         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5186
5187 c        s2=0.0
5188 c        gs2=0.0
5189         s2=scalar2(b1(1,i+1),auxvec(1))
5190 c derivative of theta i+1 with constant i+3
5191         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5192 c derivative of theta i+2 with constant i+1
5193         gs21=scalar2(b1(1,i+1),auxgvec(1))
5194 c derivative of theta i+3 with constant i+1
5195         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5196 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5197 c     &  gtb1(1,i+1)
5198         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5199 c two derivatives over diffetent matrices
5200 c gtae3e2 is derivative over i+3
5201         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5202 c ae3gte2 is derivative over i+2
5203         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5204         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5205 c three possible derivative over theta E matices
5206 c i+1
5207         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5208 c i+2
5209         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5210 c i+3
5211         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5212         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5213
5214         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5215         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5216         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5217         if (shield_mode.eq.0) then
5218         fac_shield(i)=1.0
5219         fac_shield(j)=1.0
5220 C        else
5221 C        fac_shield(i)=0.6
5222 C        fac_shield(j)=0.4
5223         endif
5224         eello_turn4=eello_turn4-(s1+s2+s3)
5225      &  *fac_shield(i)*fac_shield(j)
5226         eello_t4=-(s1+s2+s3)
5227      &  *fac_shield(i)*fac_shield(j)
5228 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5229         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5230      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5231 C Now derivative over shield:
5232           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5233      &  (shield_mode.gt.0)) then
5234 C          print *,i,j
5235
5236           do ilist=1,ishield_list(i)
5237            iresshield=shield_list(ilist,i)
5238            do k=1,3
5239            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5240 C     &      *2.0
5241            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5242      &              rlocshield
5243      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5244             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5245      &      +rlocshield
5246            enddo
5247           enddo
5248           do ilist=1,ishield_list(j)
5249            iresshield=shield_list(ilist,j)
5250            do k=1,3
5251            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5252 C     &     *2.0
5253            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5254      &              rlocshield
5255      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5256            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5257      &             +rlocshield
5258
5259            enddo
5260           enddo
5261
5262           do k=1,3
5263             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5264      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5265             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5266      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5267             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5268      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5269             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5270      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5271            enddo
5272            endif
5273
5274 #ifdef NEWCORR
5275         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5276      &                  -(gs13+gsE13+gsEE1)*wturn4
5277      &  *fac_shield(i)*fac_shield(j)
5278         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5279      &                    -(gs23+gs21+gsEE2)*wturn4
5280      &  *fac_shield(i)*fac_shield(j)
5281
5282         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5283      &                    -(gs32+gsE31+gsEE3)*wturn4
5284      &  *fac_shield(i)*fac_shield(j)
5285
5286 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5287 c     &   gs2
5288 #endif
5289         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5290      &      'eturn4',i,j,-(s1+s2+s3)
5291 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5292 c     &    ' eello_turn4_num',8*eello_turn4_num
5293 C Derivatives in gamma(i)
5294         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5295         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5296         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5297         s1=scalar2(b1(1,i+2),auxvec(1))
5298         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5299         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5300         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5301      &  *fac_shield(i)*fac_shield(j)
5302 C Derivatives in gamma(i+1)
5303         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5304         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5305         s2=scalar2(b1(1,i+1),auxvec(1))
5306         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5307         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5308         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5309         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5310      &  *fac_shield(i)*fac_shield(j)
5311 C Derivatives in gamma(i+2)
5312         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5313         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5314         s1=scalar2(b1(1,i+2),auxvec(1))
5315         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5316         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5317         s2=scalar2(b1(1,i+1),auxvec(1))
5318         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5319         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5320         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5321         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5322      &  *fac_shield(i)*fac_shield(j)
5323 C Cartesian derivatives
5324 C Derivatives of this turn contributions in DC(i+2)
5325         if (j.lt.nres-1) then
5326           do l=1,3
5327             a_temp(1,1)=agg(l,1)
5328             a_temp(1,2)=agg(l,2)
5329             a_temp(2,1)=agg(l,3)
5330             a_temp(2,2)=agg(l,4)
5331             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5332             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5333             s1=scalar2(b1(1,i+2),auxvec(1))
5334             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5335             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5336             s2=scalar2(b1(1,i+1),auxvec(1))
5337             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5338             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5339             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5340             ggg(l)=-(s1+s2+s3)
5341             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5342      &  *fac_shield(i)*fac_shield(j)
5343           enddo
5344         endif
5345 C Remaining derivatives of this turn contribution
5346         do l=1,3
5347           a_temp(1,1)=aggi(l,1)
5348           a_temp(1,2)=aggi(l,2)
5349           a_temp(2,1)=aggi(l,3)
5350           a_temp(2,2)=aggi(l,4)
5351           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5352           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5353           s1=scalar2(b1(1,i+2),auxvec(1))
5354           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5355           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5356           s2=scalar2(b1(1,i+1),auxvec(1))
5357           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5358           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5359           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5360           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5361      &  *fac_shield(i)*fac_shield(j)
5362           a_temp(1,1)=aggi1(l,1)
5363           a_temp(1,2)=aggi1(l,2)
5364           a_temp(2,1)=aggi1(l,3)
5365           a_temp(2,2)=aggi1(l,4)
5366           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5367           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5368      &  *fac_shield(i)*fac_shield(j)
5369           a_temp(1,1)=aggi1(l,1)
5370           a_temp(1,2)=aggi1(l,2)
5371           a_temp(2,1)=aggi1(l,3)
5372           a_temp(2,2)=aggi1(l,4)
5373           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5374           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5375           s1=scalar2(b1(1,i+2),auxvec(1))
5376           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5377           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5378           s2=scalar2(b1(1,i+1),auxvec(1))
5379           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5380           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5381           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5382           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5383      &  *fac_shield(i)*fac_shield(j)
5384           a_temp(1,1)=aggj(l,1)
5385           a_temp(1,2)=aggj(l,2)
5386           a_temp(2,1)=aggj(l,3)
5387           a_temp(2,2)=aggj(l,4)
5388           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5389           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5390           s1=scalar2(b1(1,i+2),auxvec(1))
5391           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5392           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5393           s2=scalar2(b1(1,i+1),auxvec(1))
5394           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5395           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5396           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5397           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5398      &  *fac_shield(i)*fac_shield(j)
5399           a_temp(1,1)=aggj1(l,1)
5400           a_temp(1,2)=aggj1(l,2)
5401           a_temp(2,1)=aggj1(l,3)
5402           a_temp(2,2)=aggj1(l,4)
5403           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5404           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5405           s1=scalar2(b1(1,i+2),auxvec(1))
5406           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5407           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5408           s2=scalar2(b1(1,i+1),auxvec(1))
5409           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5410           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5411           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5412 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5413           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5414      &  *fac_shield(i)*fac_shield(j)
5415         enddo
5416       return
5417       end
5418 C-----------------------------------------------------------------------------
5419       subroutine vecpr(u,v,w)
5420       implicit none
5421       double precision u(3),v(3),w(3)
5422       w(1)=u(2)*v(3)-u(3)*v(2)
5423       w(2)=-u(1)*v(3)+u(3)*v(1)
5424       w(3)=u(1)*v(2)-u(2)*v(1)
5425       return
5426       end
5427 C-----------------------------------------------------------------------------
5428       subroutine unormderiv(u,ugrad,unorm,ungrad)
5429 C This subroutine computes the derivatives of a normalized vector u, given
5430 C the derivatives computed without normalization conditions, ugrad. Returns
5431 C ungrad.
5432       implicit none
5433       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5434       double precision vec(3)
5435       double precision scalar
5436       integer i,j
5437 c      write (2,*) 'ugrad',ugrad
5438 c      write (2,*) 'u',u
5439       do i=1,3
5440         vec(i)=scalar(ugrad(1,i),u(1))
5441       enddo
5442 c      write (2,*) 'vec',vec
5443       do i=1,3
5444         do j=1,3
5445           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5446         enddo
5447       enddo
5448 c      write (2,*) 'ungrad',ungrad
5449       return
5450       end
5451 C-----------------------------------------------------------------------------
5452       subroutine escp_soft_sphere(evdw2,evdw2_14)
5453 C
5454 C This subroutine calculates the excluded-volume interaction energy between
5455 C peptide-group centers and side chains and its gradient in virtual-bond and
5456 C side-chain vectors.
5457 C
5458       implicit none
5459       include 'DIMENSIONS'
5460       include 'COMMON.GEO'
5461       include 'COMMON.VAR'
5462       include 'COMMON.LOCAL'
5463       include 'COMMON.CHAIN'
5464       include 'COMMON.DERIV'
5465       include 'COMMON.INTERACT'
5466       include 'COMMON.FFIELD'
5467       include 'COMMON.IOUNITS'
5468       include 'COMMON.CONTROL'
5469       dimension ggg(3)
5470       integer xshift,yshift,zshift
5471       evdw2=0.0D0
5472       evdw2_14=0.0d0
5473       r0_scp=4.5d0
5474 cd    print '(a)','Enter ESCP'
5475 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5476 C      do xshift=-1,1
5477 C      do yshift=-1,1
5478 C      do zshift=-1,1
5479       do i=iatscp_s,iatscp_e
5480         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5481         iteli=itel(i)
5482         xi=0.5D0*(c(1,i)+c(1,i+1))
5483         yi=0.5D0*(c(2,i)+c(2,i+1))
5484         zi=0.5D0*(c(3,i)+c(3,i+1))
5485 C Return atom into box, boxxsize is size of box in x dimension
5486 c  134   continue
5487 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5488 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5489 C Condition for being inside the proper box
5490 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5491 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5492 c        go to 134
5493 c        endif
5494 c  135   continue
5495 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5496 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5497 C Condition for being inside the proper box
5498 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5499 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5500 c        go to 135
5501 c c       endif
5502 c  136   continue
5503 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5504 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5505 cC Condition for being inside the proper box
5506 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5507 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5508 c        go to 136
5509 c        endif
5510           xi=mod(xi,boxxsize)
5511           if (xi.lt.0) xi=xi+boxxsize
5512           yi=mod(yi,boxysize)
5513           if (yi.lt.0) yi=yi+boxysize
5514           zi=mod(zi,boxzsize)
5515           if (zi.lt.0) zi=zi+boxzsize
5516 C          xi=xi+xshift*boxxsize
5517 C          yi=yi+yshift*boxysize
5518 C          zi=zi+zshift*boxzsize
5519         do iint=1,nscp_gr(i)
5520
5521         do j=iscpstart(i,iint),iscpend(i,iint)
5522           if (itype(j).eq.ntyp1) cycle
5523           itypj=iabs(itype(j))
5524 C Uncomment following three lines for SC-p interactions
5525 c         xj=c(1,nres+j)-xi
5526 c         yj=c(2,nres+j)-yi
5527 c         zj=c(3,nres+j)-zi
5528 C Uncomment following three lines for Ca-p interactions
5529           xj=c(1,j)
5530           yj=c(2,j)
5531           zj=c(3,j)
5532 c  174   continue
5533 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5534 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5535 C Condition for being inside the proper box
5536 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5537 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5538 c        go to 174
5539 c        endif
5540 c  175   continue
5541 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5542 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5543 cC Condition for being inside the proper box
5544 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5545 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5546 c        go to 175
5547 c        endif
5548 c  176   continue
5549 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5550 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5551 C Condition for being inside the proper box
5552 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5553 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5554 c        go to 176
5555           xj=mod(xj,boxxsize)
5556           if (xj.lt.0) xj=xj+boxxsize
5557           yj=mod(yj,boxysize)
5558           if (yj.lt.0) yj=yj+boxysize
5559           zj=mod(zj,boxzsize)
5560           if (zj.lt.0) zj=zj+boxzsize
5561       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5562       xj_safe=xj
5563       yj_safe=yj
5564       zj_safe=zj
5565       subchap=0
5566       do xshift=-1,1
5567       do yshift=-1,1
5568       do zshift=-1,1
5569           xj=xj_safe+xshift*boxxsize
5570           yj=yj_safe+yshift*boxysize
5571           zj=zj_safe+zshift*boxzsize
5572           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5573           if(dist_temp.lt.dist_init) then
5574             dist_init=dist_temp
5575             xj_temp=xj
5576             yj_temp=yj
5577             zj_temp=zj
5578             subchap=1
5579           endif
5580        enddo
5581        enddo
5582        enddo
5583        if (subchap.eq.1) then
5584           xj=xj_temp-xi
5585           yj=yj_temp-yi
5586           zj=zj_temp-zi
5587        else
5588           xj=xj_safe-xi
5589           yj=yj_safe-yi
5590           zj=zj_safe-zi
5591        endif
5592 c c       endif
5593 C          xj=xj-xi
5594 C          yj=yj-yi
5595 C          zj=zj-zi
5596           rij=xj*xj+yj*yj+zj*zj
5597
5598           r0ij=r0_scp
5599           r0ijsq=r0ij*r0ij
5600           if (rij.lt.r0ijsq) then
5601             evdwij=0.25d0*(rij-r0ijsq)**2
5602             fac=rij-r0ijsq
5603           else
5604             evdwij=0.0d0
5605             fac=0.0d0
5606           endif
5607           evdw2=evdw2+evdwij
5608 C
5609 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5610 C
5611           ggg(1)=xj*fac
5612           ggg(2)=yj*fac
5613           ggg(3)=zj*fac
5614 cgrad          if (j.lt.i) then
5615 cd          write (iout,*) 'j<i'
5616 C Uncomment following three lines for SC-p interactions
5617 c           do k=1,3
5618 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5619 c           enddo
5620 cgrad          else
5621 cd          write (iout,*) 'j>i'
5622 cgrad            do k=1,3
5623 cgrad              ggg(k)=-ggg(k)
5624 C Uncomment following line for SC-p interactions
5625 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5626 cgrad            enddo
5627 cgrad          endif
5628 cgrad          do k=1,3
5629 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5630 cgrad          enddo
5631 cgrad          kstart=min0(i+1,j)
5632 cgrad          kend=max0(i-1,j-1)
5633 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5634 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5635 cgrad          do k=kstart,kend
5636 cgrad            do l=1,3
5637 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5638 cgrad            enddo
5639 cgrad          enddo
5640           do k=1,3
5641             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5642             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5643           enddo
5644         enddo
5645
5646         enddo ! iint
5647       enddo ! i
5648 C      enddo !zshift
5649 C      enddo !yshift
5650 C      enddo !xshift
5651       return
5652       end
5653 C-----------------------------------------------------------------------------
5654       subroutine escp(evdw2,evdw2_14)
5655 C
5656 C This subroutine calculates the excluded-volume interaction energy between
5657 C peptide-group centers and side chains and its gradient in virtual-bond and
5658 C side-chain vectors.
5659 C
5660       implicit none
5661       include 'DIMENSIONS'
5662       include 'COMMON.GEO'
5663       include 'COMMON.VAR'
5664       include 'COMMON.LOCAL'
5665       include 'COMMON.CHAIN'
5666       include 'COMMON.DERIV'
5667       include 'COMMON.INTERACT'
5668       include 'COMMON.FFIELD'
5669       include 'COMMON.IOUNITS'
5670       include 'COMMON.CONTROL'
5671       include 'COMMON.SPLITELE'
5672       integer xshift,yshift,zshift
5673       dimension ggg(3)
5674       evdw2=0.0D0
5675       evdw2_14=0.0d0
5676 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5677 cd    print '(a)','Enter ESCP'
5678 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5679 C      do xshift=-1,1
5680 C      do yshift=-1,1
5681 C      do zshift=-1,1
5682       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5683       do i=iatscp_s,iatscp_e
5684         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5685         iteli=itel(i)
5686         xi=0.5D0*(c(1,i)+c(1,i+1))
5687         yi=0.5D0*(c(2,i)+c(2,i+1))
5688         zi=0.5D0*(c(3,i)+c(3,i+1))
5689           xi=mod(xi,boxxsize)
5690           if (xi.lt.0) xi=xi+boxxsize
5691           yi=mod(yi,boxysize)
5692           if (yi.lt.0) yi=yi+boxysize
5693           zi=mod(zi,boxzsize)
5694           if (zi.lt.0) zi=zi+boxzsize
5695 c          xi=xi+xshift*boxxsize
5696 c          yi=yi+yshift*boxysize
5697 c          zi=zi+zshift*boxzsize
5698 c        print *,xi,yi,zi,'polozenie i'
5699 C Return atom into box, boxxsize is size of box in x dimension
5700 c  134   continue
5701 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5702 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5703 C Condition for being inside the proper box
5704 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5705 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5706 c        go to 134
5707 c        endif
5708 c  135   continue
5709 c          print *,xi,boxxsize,"pierwszy"
5710
5711 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5712 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5713 C Condition for being inside the proper box
5714 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5715 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5716 c        go to 135
5717 c        endif
5718 c  136   continue
5719 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5720 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5721 C Condition for being inside the proper box
5722 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5723 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5724 c        go to 136
5725 c        endif
5726         do iint=1,nscp_gr(i)
5727
5728         do j=iscpstart(i,iint),iscpend(i,iint)
5729           itypj=iabs(itype(j))
5730           if (itypj.eq.ntyp1) cycle
5731 C Uncomment following three lines for SC-p interactions
5732 c         xj=c(1,nres+j)-xi
5733 c         yj=c(2,nres+j)-yi
5734 c         zj=c(3,nres+j)-zi
5735 C Uncomment following three lines for Ca-p interactions
5736           xj=c(1,j)
5737           yj=c(2,j)
5738           zj=c(3,j)
5739           xj=mod(xj,boxxsize)
5740           if (xj.lt.0) xj=xj+boxxsize
5741           yj=mod(yj,boxysize)
5742           if (yj.lt.0) yj=yj+boxysize
5743           zj=mod(zj,boxzsize)
5744           if (zj.lt.0) zj=zj+boxzsize
5745 c  174   continue
5746 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5747 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5748 C Condition for being inside the proper box
5749 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5750 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5751 c        go to 174
5752 c        endif
5753 c  175   continue
5754 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5755 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5756 cC Condition for being inside the proper box
5757 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5758 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5759 c        go to 175
5760 c        endif
5761 c  176   continue
5762 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5763 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5764 C Condition for being inside the proper box
5765 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5766 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5767 c        go to 176
5768 c        endif
5769 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5770       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5771       xj_safe=xj
5772       yj_safe=yj
5773       zj_safe=zj
5774       subchap=0
5775       do xshift=-1,1
5776       do yshift=-1,1
5777       do zshift=-1,1
5778           xj=xj_safe+xshift*boxxsize
5779           yj=yj_safe+yshift*boxysize
5780           zj=zj_safe+zshift*boxzsize
5781           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5782           if(dist_temp.lt.dist_init) then
5783             dist_init=dist_temp
5784             xj_temp=xj
5785             yj_temp=yj
5786             zj_temp=zj
5787             subchap=1
5788           endif
5789        enddo
5790        enddo
5791        enddo
5792        if (subchap.eq.1) then
5793           xj=xj_temp-xi
5794           yj=yj_temp-yi
5795           zj=zj_temp-zi
5796        else
5797           xj=xj_safe-xi
5798           yj=yj_safe-yi
5799           zj=zj_safe-zi
5800        endif
5801 c          print *,xj,yj,zj,'polozenie j'
5802           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5803 c          print *,rrij
5804           sss=sscale(1.0d0/(dsqrt(rrij)))
5805 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5806 c          if (sss.eq.0) print *,'czasem jest OK'
5807           if (sss.le.0.0d0) cycle
5808           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5809           fac=rrij**expon2
5810           e1=fac*fac*aad(itypj,iteli)
5811           e2=fac*bad(itypj,iteli)
5812           if (iabs(j-i) .le. 2) then
5813             e1=scal14*e1
5814             e2=scal14*e2
5815             evdw2_14=evdw2_14+(e1+e2)*sss
5816           endif
5817           evdwij=e1+e2
5818           evdw2=evdw2+evdwij*sss
5819           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5820      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5821      &       bad(itypj,iteli)
5822 C
5823 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5824 C
5825           fac=-(evdwij+e1)*rrij*sss
5826           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5827           ggg(1)=xj*fac
5828           ggg(2)=yj*fac
5829           ggg(3)=zj*fac
5830 cgrad          if (j.lt.i) then
5831 cd          write (iout,*) 'j<i'
5832 C Uncomment following three lines for SC-p interactions
5833 c           do k=1,3
5834 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5835 c           enddo
5836 cgrad          else
5837 cd          write (iout,*) 'j>i'
5838 cgrad            do k=1,3
5839 cgrad              ggg(k)=-ggg(k)
5840 C Uncomment following line for SC-p interactions
5841 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5842 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5843 cgrad            enddo
5844 cgrad          endif
5845 cgrad          do k=1,3
5846 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5847 cgrad          enddo
5848 cgrad          kstart=min0(i+1,j)
5849 cgrad          kend=max0(i-1,j-1)
5850 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5851 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5852 cgrad          do k=kstart,kend
5853 cgrad            do l=1,3
5854 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5855 cgrad            enddo
5856 cgrad          enddo
5857           do k=1,3
5858             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5859             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5860           enddo
5861 c        endif !endif for sscale cutoff
5862         enddo ! j
5863
5864         enddo ! iint
5865       enddo ! i
5866 c      enddo !zshift
5867 c      enddo !yshift
5868 c      enddo !xshift
5869       do i=1,nct
5870         do j=1,3
5871           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5872           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5873           gradx_scp(j,i)=expon*gradx_scp(j,i)
5874         enddo
5875       enddo
5876 C******************************************************************************
5877 C
5878 C                              N O T E !!!
5879 C
5880 C To save time the factor EXPON has been extracted from ALL components
5881 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5882 C use!
5883 C
5884 C******************************************************************************
5885       return
5886       end
5887 C--------------------------------------------------------------------------
5888       subroutine edis(ehpb)
5889 C
5890 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5891 C
5892       implicit none
5893       include 'DIMENSIONS'
5894       include 'COMMON.SBRIDGE'
5895       include 'COMMON.CHAIN'
5896       include 'COMMON.DERIV'
5897       include 'COMMON.VAR'
5898       include 'COMMON.INTERACT'
5899       include 'COMMON.IOUNITS'
5900       include 'COMMON.CONTROL'
5901       dimension ggg(3),ggg_peak(3,1000)
5902       ehpb=0.0D0
5903       do i=1,3
5904        ggg(i)=0.0d0
5905       enddo
5906 c 8/21/18 AL: added explicit restraints on reference coords
5907 c      write (iout,*) "restr_on_coord",restr_on_coord
5908       if (restr_on_coord) then
5909
5910       do i=nnt,nct
5911         ecoor=0.0d0
5912         if (itype(i).eq.ntyp1) cycle
5913         do j=1,3
5914           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5915           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5916         enddo
5917         if (itype(i).ne.10) then
5918           do j=1,3
5919             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5920             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5921           enddo
5922         endif
5923         if (energy_dec) write (iout,*)
5924      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5925         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5926       enddo
5927
5928       endif
5929 C      write (iout,*) ,"link_end",link_end,constr_dist
5930 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5931 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5932 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5933 c     &  " link_end_peak",link_end_peak
5934       if (link_end.eq.0.and.link_end_peak.eq.0) return
5935       do i=link_start_peak,link_end_peak
5936         ehpb_peak=0.0d0
5937 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5938 c     &   ipeak(1,i),ipeak(2,i)
5939         do ip=ipeak(1,i),ipeak(2,i)
5940           ii=ihpb_peak(ip)
5941           jj=jhpb_peak(ip)
5942           dd=dist(ii,jj)
5943           iip=ip-ipeak(1,i)+1
5944 C iii and jjj point to the residues for which the distance is assigned.
5945 c          if (ii.gt.nres) then
5946 c            iii=ii-nres
5947 c            jjj=jj-nres
5948 c          else
5949 c            iii=ii
5950 c            jjj=jj
5951 c          endif
5952           if (ii.gt.nres) then
5953             iii=ii-nres
5954           else
5955             iii=ii
5956           endif
5957           if (jj.gt.nres) then
5958             jjj=jj-nres
5959           else
5960             jjj=jj
5961           endif
5962           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5963           aux=dexp(-scal_peak*aux)
5964           ehpb_peak=ehpb_peak+aux
5965           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5966      &      forcon_peak(ip))*aux/dd
5967           do j=1,3
5968             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5969           enddo
5970           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5971      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5972      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5973         enddo
5974 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5975         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5976         do ip=ipeak(1,i),ipeak(2,i)
5977           iip=ip-ipeak(1,i)+1
5978           do j=1,3
5979             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5980           enddo
5981           ii=ihpb_peak(ip)
5982           jj=jhpb_peak(ip)
5983 C iii and jjj point to the residues for which the distance is assigned.
5984 c          if (ii.gt.nres) then
5985 c            iii=ii-nres
5986 c            jjj=jj-nres
5987 c          else
5988 c            iii=ii
5989 c            jjj=jj
5990 c          endif
5991           if (ii.gt.nres) then
5992             iii=ii-nres
5993           else
5994             iii=ii
5995           endif
5996           if (jj.gt.nres) then
5997             jjj=jj-nres
5998           else
5999             jjj=jj
6000           endif
6001           if (iii.lt.ii) then
6002             do j=1,3
6003               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6004             enddo
6005           endif
6006           if (jjj.lt.jj) then
6007             do j=1,3
6008               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6009             enddo
6010           endif
6011           do k=1,3
6012             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6013             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6014           enddo
6015         enddo
6016       enddo
6017       do i=link_start,link_end
6018 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6019 C CA-CA distance used in regularization of structure.
6020         ii=ihpb(i)
6021         jj=jhpb(i)
6022 C iii and jjj point to the residues for which the distance is assigned.
6023         if (ii.gt.nres) then
6024           iii=ii-nres
6025         else
6026           iii=ii
6027         endif
6028         if (jj.gt.nres) then
6029           jjj=jj-nres
6030         else
6031           jjj=jj
6032         endif
6033 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6034 c     &    dhpb(i),dhpb1(i),forcon(i)
6035 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6036 C    distance and angle dependent SS bond potential.
6037 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6038 C     & iabs(itype(jjj)).eq.1) then
6039 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6040 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6041         if (.not.dyn_ss .and. i.le.nss) then
6042 C 15/02/13 CC dynamic SSbond - additional check
6043           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6044      &        iabs(itype(jjj)).eq.1) then
6045            call ssbond_ene(iii,jjj,eij)
6046            ehpb=ehpb+2*eij
6047          endif
6048 cd          write (iout,*) "eij",eij
6049 cd   &   ' waga=',waga,' fac=',fac
6050 !        else if (ii.gt.nres .and. jj.gt.nres) then
6051         else
6052 C Calculate the distance between the two points and its difference from the
6053 C target distance.
6054           dd=dist(ii,jj)
6055           if (irestr_type(i).eq.11) then
6056             ehpb=ehpb+fordepth(i)!**4.0d0
6057      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6058             fac=fordepth(i)!**4.0d0
6059      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6060             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6061      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6062      &        ehpb,irestr_type(i)
6063           else if (irestr_type(i).eq.10) then
6064 c AL 6//19/2018 cross-link restraints
6065             xdis = 0.5d0*(dd/forcon(i))**2
6066             expdis = dexp(-xdis)
6067 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6068             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6069 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6070 c     &          " wboltzd",wboltzd
6071             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6072 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6073             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6074      &           *expdis/(aux*forcon(i)**2)
6075             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6076      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6077      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6078           else if (irestr_type(i).eq.2) then
6079 c Quartic restraints
6080             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6081             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6082      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6083      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6084             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6085           else
6086 c Quadratic restraints
6087             rdis=dd-dhpb(i)
6088 C Get the force constant corresponding to this distance.
6089             waga=forcon(i)
6090 C Calculate the contribution to energy.
6091             ehpb=ehpb+0.5d0*waga*rdis*rdis
6092             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6093      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6094      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6095 C
6096 C Evaluate gradient.
6097 C
6098             fac=waga*rdis/dd
6099           endif
6100 c Calculate Cartesian gradient
6101           do j=1,3
6102             ggg(j)=fac*(c(j,jj)-c(j,ii))
6103           enddo
6104 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6105 C If this is a SC-SC distance, we need to calculate the contributions to the
6106 C Cartesian gradient in the SC vectors (ghpbx).
6107           if (iii.lt.ii) then
6108             do j=1,3
6109               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6110             enddo
6111           endif
6112           if (jjj.lt.jj) then
6113             do j=1,3
6114               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6115             enddo
6116           endif
6117           do k=1,3
6118             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6119             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6120           enddo
6121         endif
6122       enddo
6123       return
6124       end
6125 C--------------------------------------------------------------------------
6126       subroutine ssbond_ene(i,j,eij)
6127 C
6128 C Calculate the distance and angle dependent SS-bond potential energy
6129 C using a free-energy function derived based on RHF/6-31G** ab initio
6130 C calculations of diethyl disulfide.
6131 C
6132 C A. Liwo and U. Kozlowska, 11/24/03
6133 C
6134       implicit none
6135       include 'DIMENSIONS'
6136       include 'COMMON.SBRIDGE'
6137       include 'COMMON.CHAIN'
6138       include 'COMMON.DERIV'
6139       include 'COMMON.LOCAL'
6140       include 'COMMON.INTERACT'
6141       include 'COMMON.VAR'
6142       include 'COMMON.IOUNITS'
6143       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6144       itypi=iabs(itype(i))
6145       xi=c(1,nres+i)
6146       yi=c(2,nres+i)
6147       zi=c(3,nres+i)
6148       dxi=dc_norm(1,nres+i)
6149       dyi=dc_norm(2,nres+i)
6150       dzi=dc_norm(3,nres+i)
6151 c      dsci_inv=dsc_inv(itypi)
6152       dsci_inv=vbld_inv(nres+i)
6153       itypj=iabs(itype(j))
6154 c      dscj_inv=dsc_inv(itypj)
6155       dscj_inv=vbld_inv(nres+j)
6156       xj=c(1,nres+j)-xi
6157       yj=c(2,nres+j)-yi
6158       zj=c(3,nres+j)-zi
6159       dxj=dc_norm(1,nres+j)
6160       dyj=dc_norm(2,nres+j)
6161       dzj=dc_norm(3,nres+j)
6162       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6163       rij=dsqrt(rrij)
6164       erij(1)=xj*rij
6165       erij(2)=yj*rij
6166       erij(3)=zj*rij
6167       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6168       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6169       om12=dxi*dxj+dyi*dyj+dzi*dzj
6170       do k=1,3
6171         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6172         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6173       enddo
6174       rij=1.0d0/rij
6175       deltad=rij-d0cm
6176       deltat1=1.0d0-om1
6177       deltat2=1.0d0+om2
6178       deltat12=om2-om1+2.0d0
6179       cosphi=om12-om1*om2
6180       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6181      &  +akct*deltad*deltat12
6182      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6183 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6184 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6185 c     &  " deltat12",deltat12," eij",eij
6186       ed=2*akcm*deltad+akct*deltat12
6187       pom1=akct*deltad
6188       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6189       eom1=-2*akth*deltat1-pom1-om2*pom2
6190       eom2= 2*akth*deltat2+pom1-om1*pom2
6191       eom12=pom2
6192       do k=1,3
6193         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6194         ghpbx(k,i)=ghpbx(k,i)-ggk
6195      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6196      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6197         ghpbx(k,j)=ghpbx(k,j)+ggk
6198      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6199      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6200         ghpbc(k,i)=ghpbc(k,i)-ggk
6201         ghpbc(k,j)=ghpbc(k,j)+ggk
6202       enddo
6203 C
6204 C Calculate the components of the gradient in DC and X
6205 C
6206 cgrad      do k=i,j-1
6207 cgrad        do l=1,3
6208 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6209 cgrad        enddo
6210 cgrad      enddo
6211       return
6212       end
6213 C--------------------------------------------------------------------------
6214       subroutine ebond(estr)
6215 c
6216 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6217 c
6218       implicit none
6219       include 'DIMENSIONS'
6220       include 'COMMON.LOCAL'
6221       include 'COMMON.GEO'
6222       include 'COMMON.INTERACT'
6223       include 'COMMON.DERIV'
6224       include 'COMMON.VAR'
6225       include 'COMMON.CHAIN'
6226       include 'COMMON.IOUNITS'
6227       include 'COMMON.NAMES'
6228       include 'COMMON.FFIELD'
6229       include 'COMMON.CONTROL'
6230       include 'COMMON.SETUP'
6231       double precision u(3),ud(3)
6232       estr=0.0d0
6233       estr1=0.0d0
6234       do i=ibondp_start,ibondp_end
6235         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6236 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6237 c          do j=1,3
6238 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6239 c     &      *dc(j,i-1)/vbld(i)
6240 c          enddo
6241 c          if (energy_dec) write(iout,*)
6242 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6243 c        else
6244 C       Checking if it involves dummy (NH3+ or COO-) group
6245          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6246 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6247         diff = vbld(i)-vbldpDUM
6248         if (energy_dec) write(iout,*) "dum_bond",i,diff
6249          else
6250 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6251         diff = vbld(i)-vbldp0
6252          endif
6253         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6254      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6255         estr=estr+diff*diff
6256         do j=1,3
6257           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6258         enddo
6259 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6260 c        endif
6261       enddo
6262
6263       estr=0.5d0*AKP*estr+estr1
6264 c
6265 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6266 c
6267       do i=ibond_start,ibond_end
6268         iti=iabs(itype(i))
6269         if (iti.ne.10 .and. iti.ne.ntyp1) then
6270           nbi=nbondterm(iti)
6271           if (nbi.eq.1) then
6272             diff=vbld(i+nres)-vbldsc0(1,iti)
6273             if (energy_dec)  write (iout,*)
6274      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6275      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6276             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6277             do j=1,3
6278               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6279             enddo
6280           else
6281             do j=1,nbi
6282               diff=vbld(i+nres)-vbldsc0(j,iti)
6283               ud(j)=aksc(j,iti)*diff
6284               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6285             enddo
6286             uprod=u(1)
6287             do j=2,nbi
6288               uprod=uprod*u(j)
6289             enddo
6290             usum=0.0d0
6291             usumsqder=0.0d0
6292             do j=1,nbi
6293               uprod1=1.0d0
6294               uprod2=1.0d0
6295               do k=1,nbi
6296                 if (k.ne.j) then
6297                   uprod1=uprod1*u(k)
6298                   uprod2=uprod2*u(k)*u(k)
6299                 endif
6300               enddo
6301               usum=usum+uprod1
6302               usumsqder=usumsqder+ud(j)*uprod2
6303             enddo
6304             estr=estr+uprod/usum
6305             do j=1,3
6306              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6307             enddo
6308           endif
6309         endif
6310       enddo
6311       return
6312       end
6313 #ifdef CRYST_THETA
6314 C--------------------------------------------------------------------------
6315       subroutine ebend(etheta)
6316 C
6317 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6318 C angles gamma and its derivatives in consecutive thetas and gammas.
6319 C
6320       implicit real*8 (a-h,o-z)
6321       include 'DIMENSIONS'
6322       include 'COMMON.LOCAL'
6323       include 'COMMON.GEO'
6324       include 'COMMON.INTERACT'
6325       include 'COMMON.DERIV'
6326       include 'COMMON.VAR'
6327       include 'COMMON.CHAIN'
6328       include 'COMMON.IOUNITS'
6329       include 'COMMON.NAMES'
6330       include 'COMMON.FFIELD'
6331       include 'COMMON.CONTROL'
6332       include 'COMMON.TORCNSTR'
6333       common /calcthet/ term1,term2,termm,diffak,ratak,
6334      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6335      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6336       double precision y(2),z(2)
6337       delta=0.02d0*pi
6338 c      time11=dexp(-2*time)
6339 c      time12=1.0d0
6340       etheta=0.0D0
6341 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6342       do i=ithet_start,ithet_end
6343         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6344      &  .or.itype(i).eq.ntyp1) cycle
6345 C Zero the energy function and its derivative at 0 or pi.
6346         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6347         it=itype(i-1)
6348         ichir1=isign(1,itype(i-2))
6349         ichir2=isign(1,itype(i))
6350          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6351          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6352          if (itype(i-1).eq.10) then
6353           itype1=isign(10,itype(i-2))
6354           ichir11=isign(1,itype(i-2))
6355           ichir12=isign(1,itype(i-2))
6356           itype2=isign(10,itype(i))
6357           ichir21=isign(1,itype(i))
6358           ichir22=isign(1,itype(i))
6359          endif
6360
6361         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6362 #ifdef OSF
6363           phii=phi(i)
6364           if (phii.ne.phii) phii=150.0
6365 #else
6366           phii=phi(i)
6367 #endif
6368           y(1)=dcos(phii)
6369           y(2)=dsin(phii)
6370         else
6371           y(1)=0.0D0
6372           y(2)=0.0D0
6373         endif
6374         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6375 #ifdef OSF
6376           phii1=phi(i+1)
6377           if (phii1.ne.phii1) phii1=150.0
6378           phii1=pinorm(phii1)
6379           z(1)=cos(phii1)
6380 #else
6381           phii1=phi(i+1)
6382 #endif
6383           z(1)=dcos(phii1)
6384           z(2)=dsin(phii1)
6385         else
6386           z(1)=0.0D0
6387           z(2)=0.0D0
6388         endif
6389 C Calculate the "mean" value of theta from the part of the distribution
6390 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6391 C In following comments this theta will be referred to as t_c.
6392         thet_pred_mean=0.0d0
6393         do k=1,2
6394             athetk=athet(k,it,ichir1,ichir2)
6395             bthetk=bthet(k,it,ichir1,ichir2)
6396           if (it.eq.10) then
6397              athetk=athet(k,itype1,ichir11,ichir12)
6398              bthetk=bthet(k,itype2,ichir21,ichir22)
6399           endif
6400          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6401 c         write(iout,*) 'chuj tu', y(k),z(k)
6402         enddo
6403         dthett=thet_pred_mean*ssd
6404         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6405 C Derivatives of the "mean" values in gamma1 and gamma2.
6406         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6407      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6408          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6409      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6410          if (it.eq.10) then
6411       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6412      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6413         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6414      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6415          endif
6416         if (theta(i).gt.pi-delta) then
6417           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6418      &         E_tc0)
6419           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6420           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6421           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6422      &        E_theta)
6423           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6424      &        E_tc)
6425         else if (theta(i).lt.delta) then
6426           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6427           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6428           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6429      &        E_theta)
6430           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6431           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6432      &        E_tc)
6433         else
6434           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6435      &        E_theta,E_tc)
6436         endif
6437         etheta=etheta+ethetai
6438         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6439      &      'ebend',i,ethetai,theta(i),itype(i)
6440         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6441         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6442         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6443       enddo
6444
6445 C Ufff.... We've done all this!!!
6446       return
6447       end
6448 C---------------------------------------------------------------------------
6449       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6450      &     E_tc)
6451       implicit real*8 (a-h,o-z)
6452       include 'DIMENSIONS'
6453       include 'COMMON.LOCAL'
6454       include 'COMMON.IOUNITS'
6455       common /calcthet/ term1,term2,termm,diffak,ratak,
6456      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6457      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6458 C Calculate the contributions to both Gaussian lobes.
6459 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6460 C The "polynomial part" of the "standard deviation" of this part of
6461 C the distributioni.
6462 ccc        write (iout,*) thetai,thet_pred_mean
6463         sig=polthet(3,it)
6464         do j=2,0,-1
6465           sig=sig*thet_pred_mean+polthet(j,it)
6466         enddo
6467 C Derivative of the "interior part" of the "standard deviation of the"
6468 C gamma-dependent Gaussian lobe in t_c.
6469         sigtc=3*polthet(3,it)
6470         do j=2,1,-1
6471           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6472         enddo
6473         sigtc=sig*sigtc
6474 C Set the parameters of both Gaussian lobes of the distribution.
6475 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6476         fac=sig*sig+sigc0(it)
6477         sigcsq=fac+fac
6478         sigc=1.0D0/sigcsq
6479 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6480         sigsqtc=-4.0D0*sigcsq*sigtc
6481 c       print *,i,sig,sigtc,sigsqtc
6482 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6483         sigtc=-sigtc/(fac*fac)
6484 C Following variable is sigma(t_c)**(-2)
6485         sigcsq=sigcsq*sigcsq
6486         sig0i=sig0(it)
6487         sig0inv=1.0D0/sig0i**2
6488         delthec=thetai-thet_pred_mean
6489         delthe0=thetai-theta0i
6490         term1=-0.5D0*sigcsq*delthec*delthec
6491         term2=-0.5D0*sig0inv*delthe0*delthe0
6492 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6493 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6494 C NaNs in taking the logarithm. We extract the largest exponent which is added
6495 C to the energy (this being the log of the distribution) at the end of energy
6496 C term evaluation for this virtual-bond angle.
6497         if (term1.gt.term2) then
6498           termm=term1
6499           term2=dexp(term2-termm)
6500           term1=1.0d0
6501         else
6502           termm=term2
6503           term1=dexp(term1-termm)
6504           term2=1.0d0
6505         endif
6506 C The ratio between the gamma-independent and gamma-dependent lobes of
6507 C the distribution is a Gaussian function of thet_pred_mean too.
6508         diffak=gthet(2,it)-thet_pred_mean
6509         ratak=diffak/gthet(3,it)**2
6510         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6511 C Let's differentiate it in thet_pred_mean NOW.
6512         aktc=ak*ratak
6513 C Now put together the distribution terms to make complete distribution.
6514         termexp=term1+ak*term2
6515         termpre=sigc+ak*sig0i
6516 C Contribution of the bending energy from this theta is just the -log of
6517 C the sum of the contributions from the two lobes and the pre-exponential
6518 C factor. Simple enough, isn't it?
6519         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6520 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6521 C NOW the derivatives!!!
6522 C 6/6/97 Take into account the deformation.
6523         E_theta=(delthec*sigcsq*term1
6524      &       +ak*delthe0*sig0inv*term2)/termexp
6525         E_tc=((sigtc+aktc*sig0i)/termpre
6526      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6527      &       aktc*term2)/termexp)
6528       return
6529       end
6530 c-----------------------------------------------------------------------------
6531       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6532       implicit real*8 (a-h,o-z)
6533       include 'DIMENSIONS'
6534       include 'COMMON.LOCAL'
6535       include 'COMMON.IOUNITS'
6536       common /calcthet/ term1,term2,termm,diffak,ratak,
6537      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6538      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6539       delthec=thetai-thet_pred_mean
6540       delthe0=thetai-theta0i
6541 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6542       t3 = thetai-thet_pred_mean
6543       t6 = t3**2
6544       t9 = term1
6545       t12 = t3*sigcsq
6546       t14 = t12+t6*sigsqtc
6547       t16 = 1.0d0
6548       t21 = thetai-theta0i
6549       t23 = t21**2
6550       t26 = term2
6551       t27 = t21*t26
6552       t32 = termexp
6553       t40 = t32**2
6554       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6555      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6556      & *(-t12*t9-ak*sig0inv*t27)
6557       return
6558       end
6559 #else
6560 C--------------------------------------------------------------------------
6561       subroutine ebend(etheta)
6562 C
6563 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6564 C angles gamma and its derivatives in consecutive thetas and gammas.
6565 C ab initio-derived potentials from
6566 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6567 C
6568       implicit none
6569       include 'DIMENSIONS'
6570       include 'COMMON.LOCAL'
6571       include 'COMMON.GEO'
6572       include 'COMMON.INTERACT'
6573       include 'COMMON.DERIV'
6574       include 'COMMON.VAR'
6575       include 'COMMON.CHAIN'
6576       include 'COMMON.IOUNITS'
6577       include 'COMMON.NAMES'
6578       include 'COMMON.FFIELD'
6579       include 'COMMON.CONTROL'
6580       include 'COMMON.TORCNSTR'
6581       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6582      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6583      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6584      & sinph1ph2(maxdouble,maxdouble)
6585       logical lprn /.false./, lprn1 /.false./
6586       etheta=0.0D0
6587       do i=ithet_start,ithet_end
6588 c        print *,i,itype(i-1),itype(i),itype(i-2)
6589         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6590      &  .or.itype(i).eq.ntyp1) cycle
6591 C        print *,i,theta(i)
6592         if (iabs(itype(i+1)).eq.20) iblock=2
6593         if (iabs(itype(i+1)).ne.20) iblock=1
6594         dethetai=0.0d0
6595         dephii=0.0d0
6596         dephii1=0.0d0
6597         theti2=0.5d0*theta(i)
6598         ityp2=ithetyp((itype(i-1)))
6599         do k=1,nntheterm
6600           coskt(k)=dcos(k*theti2)
6601           sinkt(k)=dsin(k*theti2)
6602         enddo
6603 C        print *,ethetai
6604         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6605 #ifdef OSF
6606           phii=phi(i)
6607           if (phii.ne.phii) phii=150.0
6608 #else
6609           phii=phi(i)
6610 #endif
6611           ityp1=ithetyp((itype(i-2)))
6612 C propagation of chirality for glycine type
6613           do k=1,nsingle
6614             cosph1(k)=dcos(k*phii)
6615             sinph1(k)=dsin(k*phii)
6616           enddo
6617         else
6618           phii=0.0d0
6619           do k=1,nsingle
6620           ityp1=ithetyp((itype(i-2)))
6621             cosph1(k)=0.0d0
6622             sinph1(k)=0.0d0
6623           enddo
6624         endif
6625         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6626 #ifdef OSF
6627           phii1=phi(i+1)
6628           if (phii1.ne.phii1) phii1=150.0
6629           phii1=pinorm(phii1)
6630 #else
6631           phii1=phi(i+1)
6632 #endif
6633           ityp3=ithetyp((itype(i)))
6634           do k=1,nsingle
6635             cosph2(k)=dcos(k*phii1)
6636             sinph2(k)=dsin(k*phii1)
6637           enddo
6638         else
6639           phii1=0.0d0
6640           ityp3=ithetyp((itype(i)))
6641           do k=1,nsingle
6642             cosph2(k)=0.0d0
6643             sinph2(k)=0.0d0
6644           enddo
6645         endif
6646         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6647         do k=1,ndouble
6648           do l=1,k-1
6649             ccl=cosph1(l)*cosph2(k-l)
6650             ssl=sinph1(l)*sinph2(k-l)
6651             scl=sinph1(l)*cosph2(k-l)
6652             csl=cosph1(l)*sinph2(k-l)
6653             cosph1ph2(l,k)=ccl-ssl
6654             cosph1ph2(k,l)=ccl+ssl
6655             sinph1ph2(l,k)=scl+csl
6656             sinph1ph2(k,l)=scl-csl
6657           enddo
6658         enddo
6659         if (lprn) then
6660         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6661      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6662         write (iout,*) "coskt and sinkt"
6663         do k=1,nntheterm
6664           write (iout,*) k,coskt(k),sinkt(k)
6665         enddo
6666         endif
6667         do k=1,ntheterm
6668           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6669           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6670      &      *coskt(k)
6671           if (lprn)
6672      &    write (iout,*) "k",k,"
6673      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6674      &     " ethetai",ethetai
6675         enddo
6676         if (lprn) then
6677         write (iout,*) "cosph and sinph"
6678         do k=1,nsingle
6679           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6680         enddo
6681         write (iout,*) "cosph1ph2 and sinph2ph2"
6682         do k=2,ndouble
6683           do l=1,k-1
6684             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6685      &         sinph1ph2(l,k),sinph1ph2(k,l)
6686           enddo
6687         enddo
6688         write(iout,*) "ethetai",ethetai
6689         endif
6690 C       print *,ethetai
6691         do m=1,ntheterm2
6692           do k=1,nsingle
6693             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6694      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6695      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6696      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6697             ethetai=ethetai+sinkt(m)*aux
6698             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6699             dephii=dephii+k*sinkt(m)*(
6700      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6701      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6702             dephii1=dephii1+k*sinkt(m)*(
6703      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6704      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6705             if (lprn)
6706      &      write (iout,*) "m",m," k",k," bbthet",
6707      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6708      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6709      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6710      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6711 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6712           enddo
6713         enddo
6714 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6715 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6716 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6717 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6718         if (lprn)
6719      &  write(iout,*) "ethetai",ethetai
6720 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6721         do m=1,ntheterm3
6722           do k=2,ndouble
6723             do l=1,k-1
6724               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6725      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6726      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6727      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6728               ethetai=ethetai+sinkt(m)*aux
6729               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6730               dephii=dephii+l*sinkt(m)*(
6731      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6732      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6733      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6734      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6735               dephii1=dephii1+(k-l)*sinkt(m)*(
6736      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6737      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6738      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6739      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6740               if (lprn) then
6741               write (iout,*) "m",m," k",k," l",l," ffthet",
6742      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6743      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6744      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6745      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6746      &            " ethetai",ethetai
6747               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6748      &            cosph1ph2(k,l)*sinkt(m),
6749      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6750               endif
6751             enddo
6752           enddo
6753         enddo
6754 10      continue
6755 c        lprn1=.true.
6756 C        print *,ethetai
6757         if (lprn1)
6758      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6759      &   i,theta(i)*rad2deg,phii*rad2deg,
6760      &   phii1*rad2deg,ethetai
6761 c        lprn1=.false.
6762         etheta=etheta+ethetai
6763         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6764         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6765         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6766       enddo
6767
6768       return
6769       end
6770 #endif
6771 #ifdef CRYST_SC
6772 c-----------------------------------------------------------------------------
6773       subroutine esc(escloc)
6774 C Calculate the local energy of a side chain and its derivatives in the
6775 C corresponding virtual-bond valence angles THETA and the spherical angles
6776 C ALPHA and OMEGA.
6777       implicit real*8 (a-h,o-z)
6778       include 'DIMENSIONS'
6779       include 'COMMON.GEO'
6780       include 'COMMON.LOCAL'
6781       include 'COMMON.VAR'
6782       include 'COMMON.INTERACT'
6783       include 'COMMON.DERIV'
6784       include 'COMMON.CHAIN'
6785       include 'COMMON.IOUNITS'
6786       include 'COMMON.NAMES'
6787       include 'COMMON.FFIELD'
6788       include 'COMMON.CONTROL'
6789       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6790      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6791       common /sccalc/ time11,time12,time112,theti,it,nlobit
6792       delta=0.02d0*pi
6793       escloc=0.0D0
6794 c     write (iout,'(a)') 'ESC'
6795       do i=loc_start,loc_end
6796         it=itype(i)
6797         if (it.eq.ntyp1) cycle
6798         if (it.eq.10) goto 1
6799         nlobit=nlob(iabs(it))
6800 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6801 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6802         theti=theta(i+1)-pipol
6803         x(1)=dtan(theti)
6804         x(2)=alph(i)
6805         x(3)=omeg(i)
6806
6807         if (x(2).gt.pi-delta) then
6808           xtemp(1)=x(1)
6809           xtemp(2)=pi-delta
6810           xtemp(3)=x(3)
6811           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6812           xtemp(2)=pi
6813           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6814           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6815      &        escloci,dersc(2))
6816           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6817      &        ddersc0(1),dersc(1))
6818           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6819      &        ddersc0(3),dersc(3))
6820           xtemp(2)=pi-delta
6821           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6822           xtemp(2)=pi
6823           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6824           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6825      &            dersc0(2),esclocbi,dersc02)
6826           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6827      &            dersc12,dersc01)
6828           call splinthet(x(2),0.5d0*delta,ss,ssd)
6829           dersc0(1)=dersc01
6830           dersc0(2)=dersc02
6831           dersc0(3)=0.0d0
6832           do k=1,3
6833             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6834           enddo
6835           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6836 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6837 c    &             esclocbi,ss,ssd
6838           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6839 c         escloci=esclocbi
6840 c         write (iout,*) escloci
6841         else if (x(2).lt.delta) then
6842           xtemp(1)=x(1)
6843           xtemp(2)=delta
6844           xtemp(3)=x(3)
6845           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6846           xtemp(2)=0.0d0
6847           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6848           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6849      &        escloci,dersc(2))
6850           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6851      &        ddersc0(1),dersc(1))
6852           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6853      &        ddersc0(3),dersc(3))
6854           xtemp(2)=delta
6855           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6856           xtemp(2)=0.0d0
6857           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6858           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6859      &            dersc0(2),esclocbi,dersc02)
6860           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6861      &            dersc12,dersc01)
6862           dersc0(1)=dersc01
6863           dersc0(2)=dersc02
6864           dersc0(3)=0.0d0
6865           call splinthet(x(2),0.5d0*delta,ss,ssd)
6866           do k=1,3
6867             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6868           enddo
6869           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6870 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6871 c    &             esclocbi,ss,ssd
6872           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6873 c         write (iout,*) escloci
6874         else
6875           call enesc(x,escloci,dersc,ddummy,.false.)
6876         endif
6877
6878         escloc=escloc+escloci
6879         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6880      &     'escloc',i,escloci
6881 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6882
6883         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6884      &   wscloc*dersc(1)
6885         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6886         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6887     1   continue
6888       enddo
6889       return
6890       end
6891 C---------------------------------------------------------------------------
6892       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6893       implicit real*8 (a-h,o-z)
6894       include 'DIMENSIONS'
6895       include 'COMMON.GEO'
6896       include 'COMMON.LOCAL'
6897       include 'COMMON.IOUNITS'
6898       common /sccalc/ time11,time12,time112,theti,it,nlobit
6899       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6900       double precision contr(maxlob,-1:1)
6901       logical mixed
6902 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6903         escloc_i=0.0D0
6904         do j=1,3
6905           dersc(j)=0.0D0
6906           if (mixed) ddersc(j)=0.0d0
6907         enddo
6908         x3=x(3)
6909
6910 C Because of periodicity of the dependence of the SC energy in omega we have
6911 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6912 C To avoid underflows, first compute & store the exponents.
6913
6914         do iii=-1,1
6915
6916           x(3)=x3+iii*dwapi
6917
6918           do j=1,nlobit
6919             do k=1,3
6920               z(k)=x(k)-censc(k,j,it)
6921             enddo
6922             do k=1,3
6923               Axk=0.0D0
6924               do l=1,3
6925                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6926               enddo
6927               Ax(k,j,iii)=Axk
6928             enddo
6929             expfac=0.0D0
6930             do k=1,3
6931               expfac=expfac+Ax(k,j,iii)*z(k)
6932             enddo
6933             contr(j,iii)=expfac
6934           enddo ! j
6935
6936         enddo ! iii
6937
6938         x(3)=x3
6939 C As in the case of ebend, we want to avoid underflows in exponentiation and
6940 C subsequent NaNs and INFs in energy calculation.
6941 C Find the largest exponent
6942         emin=contr(1,-1)
6943         do iii=-1,1
6944           do j=1,nlobit
6945             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6946           enddo
6947         enddo
6948         emin=0.5D0*emin
6949 cd      print *,'it=',it,' emin=',emin
6950
6951 C Compute the contribution to SC energy and derivatives
6952         do iii=-1,1
6953
6954           do j=1,nlobit
6955 #ifdef OSF
6956             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6957             if(adexp.ne.adexp) adexp=1.0
6958             expfac=dexp(adexp)
6959 #else
6960             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6961 #endif
6962 cd          print *,'j=',j,' expfac=',expfac
6963             escloc_i=escloc_i+expfac
6964             do k=1,3
6965               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6966             enddo
6967             if (mixed) then
6968               do k=1,3,2
6969                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6970      &            +gaussc(k,2,j,it))*expfac
6971               enddo
6972             endif
6973           enddo
6974
6975         enddo ! iii
6976
6977         dersc(1)=dersc(1)/cos(theti)**2
6978         ddersc(1)=ddersc(1)/cos(theti)**2
6979         ddersc(3)=ddersc(3)
6980
6981         escloci=-(dlog(escloc_i)-emin)
6982         do j=1,3
6983           dersc(j)=dersc(j)/escloc_i
6984         enddo
6985         if (mixed) then
6986           do j=1,3,2
6987             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6988           enddo
6989         endif
6990       return
6991       end
6992 C------------------------------------------------------------------------------
6993       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6994       implicit real*8 (a-h,o-z)
6995       include 'DIMENSIONS'
6996       include 'COMMON.GEO'
6997       include 'COMMON.LOCAL'
6998       include 'COMMON.IOUNITS'
6999       common /sccalc/ time11,time12,time112,theti,it,nlobit
7000       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7001       double precision contr(maxlob)
7002       logical mixed
7003
7004       escloc_i=0.0D0
7005
7006       do j=1,3
7007         dersc(j)=0.0D0
7008       enddo
7009
7010       do j=1,nlobit
7011         do k=1,2
7012           z(k)=x(k)-censc(k,j,it)
7013         enddo
7014         z(3)=dwapi
7015         do k=1,3
7016           Axk=0.0D0
7017           do l=1,3
7018             Axk=Axk+gaussc(l,k,j,it)*z(l)
7019           enddo
7020           Ax(k,j)=Axk
7021         enddo
7022         expfac=0.0D0
7023         do k=1,3
7024           expfac=expfac+Ax(k,j)*z(k)
7025         enddo
7026         contr(j)=expfac
7027       enddo ! j
7028
7029 C As in the case of ebend, we want to avoid underflows in exponentiation and
7030 C subsequent NaNs and INFs in energy calculation.
7031 C Find the largest exponent
7032       emin=contr(1)
7033       do j=1,nlobit
7034         if (emin.gt.contr(j)) emin=contr(j)
7035       enddo
7036       emin=0.5D0*emin
7037
7038 C Compute the contribution to SC energy and derivatives
7039
7040       dersc12=0.0d0
7041       do j=1,nlobit
7042         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7043         escloc_i=escloc_i+expfac
7044         do k=1,2
7045           dersc(k)=dersc(k)+Ax(k,j)*expfac
7046         enddo
7047         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7048      &            +gaussc(1,2,j,it))*expfac
7049         dersc(3)=0.0d0
7050       enddo
7051
7052       dersc(1)=dersc(1)/cos(theti)**2
7053       dersc12=dersc12/cos(theti)**2
7054       escloci=-(dlog(escloc_i)-emin)
7055       do j=1,2
7056         dersc(j)=dersc(j)/escloc_i
7057       enddo
7058       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7059       return
7060       end
7061 #else
7062 c----------------------------------------------------------------------------------
7063       subroutine esc(escloc)
7064 C Calculate the local energy of a side chain and its derivatives in the
7065 C corresponding virtual-bond valence angles THETA and the spherical angles
7066 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7067 C added by Urszula Kozlowska. 07/11/2007
7068 C
7069       implicit none
7070       include 'DIMENSIONS'
7071       include 'COMMON.GEO'
7072       include 'COMMON.LOCAL'
7073       include 'COMMON.VAR'
7074       include 'COMMON.SCROT'
7075       include 'COMMON.INTERACT'
7076       include 'COMMON.DERIV'
7077       include 'COMMON.CHAIN'
7078       include 'COMMON.IOUNITS'
7079       include 'COMMON.NAMES'
7080       include 'COMMON.FFIELD'
7081       include 'COMMON.CONTROL'
7082       include 'COMMON.VECTORS'
7083       double precision x_prime(3),y_prime(3),z_prime(3)
7084      &    , sumene,dsc_i,dp2_i,x(65),
7085      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7086      &    de_dxx,de_dyy,de_dzz,de_dt
7087       double precision s1_t,s1_6_t,s2_t,s2_6_t
7088       double precision
7089      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7090      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7091      & dt_dCi(3),dt_dCi1(3)
7092       common /sccalc/ time11,time12,time112,theti,it,nlobit
7093       delta=0.02d0*pi
7094       escloc=0.0D0
7095       do i=loc_start,loc_end
7096         if (itype(i).eq.ntyp1) cycle
7097         costtab(i+1) =dcos(theta(i+1))
7098         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7099         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7100         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7101         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7102         cosfac=dsqrt(cosfac2)
7103         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7104         sinfac=dsqrt(sinfac2)
7105         it=iabs(itype(i))
7106         if (it.eq.10) goto 1
7107 c
7108 C  Compute the axes of tghe local cartesian coordinates system; store in
7109 c   x_prime, y_prime and z_prime
7110 c
7111         do j=1,3
7112           x_prime(j) = 0.00
7113           y_prime(j) = 0.00
7114           z_prime(j) = 0.00
7115         enddo
7116 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7117 C     &   dc_norm(3,i+nres)
7118         do j = 1,3
7119           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7120           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7121         enddo
7122         do j = 1,3
7123           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7124         enddo
7125 c       write (2,*) "i",i
7126 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7127 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7128 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7129 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7130 c      & " xy",scalar(x_prime(1),y_prime(1)),
7131 c      & " xz",scalar(x_prime(1),z_prime(1)),
7132 c      & " yy",scalar(y_prime(1),y_prime(1)),
7133 c      & " yz",scalar(y_prime(1),z_prime(1)),
7134 c      & " zz",scalar(z_prime(1),z_prime(1))
7135 c
7136 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7137 C to local coordinate system. Store in xx, yy, zz.
7138 c
7139         xx=0.0d0
7140         yy=0.0d0
7141         zz=0.0d0
7142         do j = 1,3
7143           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7144           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7145           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7146         enddo
7147
7148         xxtab(i)=xx
7149         yytab(i)=yy
7150         zztab(i)=zz
7151 C
7152 C Compute the energy of the ith side cbain
7153 C
7154 c        write (2,*) "xx",xx," yy",yy," zz",zz
7155         it=iabs(itype(i))
7156         do j = 1,65
7157           x(j) = sc_parmin(j,it)
7158         enddo
7159 #ifdef CHECK_COORD
7160 Cc diagnostics - remove later
7161         xx1 = dcos(alph(2))
7162         yy1 = dsin(alph(2))*dcos(omeg(2))
7163         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7164         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7165      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7166      &    xx1,yy1,zz1
7167 C,"  --- ", xx_w,yy_w,zz_w
7168 c end diagnostics
7169 #endif
7170         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7171      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7172      &   + x(10)*yy*zz
7173         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7174      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7175      & + x(20)*yy*zz
7176         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7177      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7178      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7179      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7180      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7181      &  +x(40)*xx*yy*zz
7182         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7183      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7184      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7185      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7186      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7187      &  +x(60)*xx*yy*zz
7188         dsc_i   = 0.743d0+x(61)
7189         dp2_i   = 1.9d0+x(62)
7190         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7191      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7192         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7193      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7194         s1=(1+x(63))/(0.1d0 + dscp1)
7195         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7196         s2=(1+x(65))/(0.1d0 + dscp2)
7197         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7198         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7199      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7200 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7201 c     &   sumene4,
7202 c     &   dscp1,dscp2,sumene
7203 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7204         escloc = escloc + sumene
7205 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7206 c     & ,zz,xx,yy
7207 c#define DEBUG
7208 #ifdef DEBUG
7209 C
7210 C This section to check the numerical derivatives of the energy of ith side
7211 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7212 C #define DEBUG in the code to turn it on.
7213 C
7214         write (2,*) "sumene               =",sumene
7215         aincr=1.0d-7
7216         xxsave=xx
7217         xx=xx+aincr
7218         write (2,*) xx,yy,zz
7219         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7220         de_dxx_num=(sumenep-sumene)/aincr
7221         xx=xxsave
7222         write (2,*) "xx+ sumene from enesc=",sumenep
7223         yysave=yy
7224         yy=yy+aincr
7225         write (2,*) xx,yy,zz
7226         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7227         de_dyy_num=(sumenep-sumene)/aincr
7228         yy=yysave
7229         write (2,*) "yy+ sumene from enesc=",sumenep
7230         zzsave=zz
7231         zz=zz+aincr
7232         write (2,*) xx,yy,zz
7233         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7234         de_dzz_num=(sumenep-sumene)/aincr
7235         zz=zzsave
7236         write (2,*) "zz+ sumene from enesc=",sumenep
7237         costsave=cost2tab(i+1)
7238         sintsave=sint2tab(i+1)
7239         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7240         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7241         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7242         de_dt_num=(sumenep-sumene)/aincr
7243         write (2,*) " t+ sumene from enesc=",sumenep
7244         cost2tab(i+1)=costsave
7245         sint2tab(i+1)=sintsave
7246 C End of diagnostics section.
7247 #endif
7248 C
7249 C Compute the gradient of esc
7250 C
7251 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7252         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7253         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7254         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7255         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7256         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7257         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7258         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7259         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7260         pom1=(sumene3*sint2tab(i+1)+sumene1)
7261      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7262         pom2=(sumene4*cost2tab(i+1)+sumene2)
7263      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7264         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7265         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7266      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7267      &  +x(40)*yy*zz
7268         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7269         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7270      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7271      &  +x(60)*yy*zz
7272         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7273      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7274      &        +(pom1+pom2)*pom_dx
7275 #ifdef DEBUG
7276         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7277 #endif
7278 C
7279         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7280         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7281      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7282      &  +x(40)*xx*zz
7283         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7284         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7285      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7286      &  +x(59)*zz**2 +x(60)*xx*zz
7287         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7288      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7289      &        +(pom1-pom2)*pom_dy
7290 #ifdef DEBUG
7291         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7292 #endif
7293 C
7294         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7295      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7296      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7297      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7298      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7299      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7300      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7301      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7302 #ifdef DEBUG
7303         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7304 #endif
7305 C
7306         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7307      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7308      &  +pom1*pom_dt1+pom2*pom_dt2
7309 #ifdef DEBUG
7310         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7311 #endif
7312 c#undef DEBUG
7313 c
7314 C
7315        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7316        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7317        cosfac2xx=cosfac2*xx
7318        sinfac2yy=sinfac2*yy
7319        do k = 1,3
7320          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7321      &      vbld_inv(i+1)
7322          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7323      &      vbld_inv(i)
7324          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7325          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7326 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7327 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7328 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7329 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7330          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7331          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7332          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7333          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7334          dZZ_Ci1(k)=0.0d0
7335          dZZ_Ci(k)=0.0d0
7336          do j=1,3
7337            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7338      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7339            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7340      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7341          enddo
7342
7343          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7344          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7345          dZZ_XYZ(k)=vbld_inv(i+nres)*
7346      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7347 c
7348          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7349          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7350        enddo
7351
7352        do k=1,3
7353          dXX_Ctab(k,i)=dXX_Ci(k)
7354          dXX_C1tab(k,i)=dXX_Ci1(k)
7355          dYY_Ctab(k,i)=dYY_Ci(k)
7356          dYY_C1tab(k,i)=dYY_Ci1(k)
7357          dZZ_Ctab(k,i)=dZZ_Ci(k)
7358          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7359          dXX_XYZtab(k,i)=dXX_XYZ(k)
7360          dYY_XYZtab(k,i)=dYY_XYZ(k)
7361          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7362        enddo
7363
7364        do k = 1,3
7365 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7366 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7367 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7368 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7369 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7370 c     &    dt_dci(k)
7371 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7372 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7373          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7374      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7375          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7376      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7377          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7378      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7379        enddo
7380 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7381 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7382
7383 C to check gradient call subroutine check_grad
7384
7385     1 continue
7386       enddo
7387       return
7388       end
7389 c------------------------------------------------------------------------------
7390       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7391       implicit none
7392       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7393      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7394       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7395      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7396      &   + x(10)*yy*zz
7397       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7398      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7399      & + x(20)*yy*zz
7400       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7401      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7402      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7403      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7404      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7405      &  +x(40)*xx*yy*zz
7406       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7407      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7408      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7409      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7410      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7411      &  +x(60)*xx*yy*zz
7412       dsc_i   = 0.743d0+x(61)
7413       dp2_i   = 1.9d0+x(62)
7414       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7415      &          *(xx*cost2+yy*sint2))
7416       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7417      &          *(xx*cost2-yy*sint2))
7418       s1=(1+x(63))/(0.1d0 + dscp1)
7419       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7420       s2=(1+x(65))/(0.1d0 + dscp2)
7421       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7422       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7423      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7424       enesc=sumene
7425       return
7426       end
7427 #endif
7428 c------------------------------------------------------------------------------
7429       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7430 C
7431 C This procedure calculates two-body contact function g(rij) and its derivative:
7432 C
7433 C           eps0ij                                     !       x < -1
7434 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7435 C            0                                         !       x > 1
7436 C
7437 C where x=(rij-r0ij)/delta
7438 C
7439 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7440 C
7441       implicit none
7442       double precision rij,r0ij,eps0ij,fcont,fprimcont
7443       double precision x,x2,x4,delta
7444 c     delta=0.02D0*r0ij
7445 c      delta=0.2D0*r0ij
7446       x=(rij-r0ij)/delta
7447       if (x.lt.-1.0D0) then
7448         fcont=eps0ij
7449         fprimcont=0.0D0
7450       else if (x.le.1.0D0) then
7451         x2=x*x
7452         x4=x2*x2
7453         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7454         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7455       else
7456         fcont=0.0D0
7457         fprimcont=0.0D0
7458       endif
7459       return
7460       end
7461 c------------------------------------------------------------------------------
7462       subroutine splinthet(theti,delta,ss,ssder)
7463       implicit real*8 (a-h,o-z)
7464       include 'DIMENSIONS'
7465       include 'COMMON.VAR'
7466       include 'COMMON.GEO'
7467       thetup=pi-delta
7468       thetlow=delta
7469       if (theti.gt.pipol) then
7470         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7471       else
7472         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7473         ssder=-ssder
7474       endif
7475       return
7476       end
7477 c------------------------------------------------------------------------------
7478       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7479       implicit none
7480       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7481       double precision ksi,ksi2,ksi3,a1,a2,a3
7482       a1=fprim0*delta/(f1-f0)
7483       a2=3.0d0-2.0d0*a1
7484       a3=a1-2.0d0
7485       ksi=(x-x0)/delta
7486       ksi2=ksi*ksi
7487       ksi3=ksi2*ksi
7488       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7489       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7490       return
7491       end
7492 c------------------------------------------------------------------------------
7493       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7494       implicit none
7495       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7496       double precision ksi,ksi2,ksi3,a1,a2,a3
7497       ksi=(x-x0)/delta
7498       ksi2=ksi*ksi
7499       ksi3=ksi2*ksi
7500       a1=fprim0x*delta
7501       a2=3*(f1x-f0x)-2*fprim0x*delta
7502       a3=fprim0x*delta-2*(f1x-f0x)
7503       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7504       return
7505       end
7506 C-----------------------------------------------------------------------------
7507 #ifdef CRYST_TOR
7508 C-----------------------------------------------------------------------------
7509       subroutine etor(etors)
7510       implicit real*8 (a-h,o-z)
7511       include 'DIMENSIONS'
7512       include 'COMMON.VAR'
7513       include 'COMMON.GEO'
7514       include 'COMMON.LOCAL'
7515       include 'COMMON.TORSION'
7516       include 'COMMON.INTERACT'
7517       include 'COMMON.DERIV'
7518       include 'COMMON.CHAIN'
7519       include 'COMMON.NAMES'
7520       include 'COMMON.IOUNITS'
7521       include 'COMMON.FFIELD'
7522       include 'COMMON.TORCNSTR'
7523       include 'COMMON.CONTROL'
7524       logical lprn
7525 C Set lprn=.true. for debugging
7526       lprn=.false.
7527 c      lprn=.true.
7528       etors=0.0D0
7529       do i=iphi_start,iphi_end
7530       etors_ii=0.0D0
7531         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7532      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7533         itori=itortyp(itype(i-2))
7534         itori1=itortyp(itype(i-1))
7535         phii=phi(i)
7536         gloci=0.0D0
7537 C Proline-Proline pair is a special case...
7538         if (itori.eq.3 .and. itori1.eq.3) then
7539           if (phii.gt.-dwapi3) then
7540             cosphi=dcos(3*phii)
7541             fac=1.0D0/(1.0D0-cosphi)
7542             etorsi=v1(1,3,3)*fac
7543             etorsi=etorsi+etorsi
7544             etors=etors+etorsi-v1(1,3,3)
7545             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7546             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7547           endif
7548           do j=1,3
7549             v1ij=v1(j+1,itori,itori1)
7550             v2ij=v2(j+1,itori,itori1)
7551             cosphi=dcos(j*phii)
7552             sinphi=dsin(j*phii)
7553             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7554             if (energy_dec) etors_ii=etors_ii+
7555      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7556             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7557           enddo
7558         else
7559           do j=1,nterm_old
7560             v1ij=v1(j,itori,itori1)
7561             v2ij=v2(j,itori,itori1)
7562             cosphi=dcos(j*phii)
7563             sinphi=dsin(j*phii)
7564             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7565             if (energy_dec) etors_ii=etors_ii+
7566      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7567             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7568           enddo
7569         endif
7570         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7571              'etor',i,etors_ii
7572         if (lprn)
7573      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7574      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7575      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7576         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7577 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7578       enddo
7579       return
7580       end
7581 c------------------------------------------------------------------------------
7582       subroutine etor_d(etors_d)
7583       etors_d=0.0d0
7584       return
7585       end
7586 c----------------------------------------------------------------------------
7587 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7588       subroutine e_modeller(ehomology_constr)
7589       ehomology_constr=0.0d0
7590       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7591       return
7592       end
7593 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7594
7595 c------------------------------------------------------------------------------
7596       subroutine etor_d(etors_d)
7597       etors_d=0.0d0
7598       return
7599       end
7600 c----------------------------------------------------------------------------
7601 #else
7602       subroutine etor(etors)
7603       implicit none
7604       include 'DIMENSIONS'
7605       include 'COMMON.VAR'
7606       include 'COMMON.GEO'
7607       include 'COMMON.LOCAL'
7608       include 'COMMON.TORSION'
7609       include 'COMMON.INTERACT'
7610       include 'COMMON.DERIV'
7611       include 'COMMON.CHAIN'
7612       include 'COMMON.NAMES'
7613       include 'COMMON.IOUNITS'
7614       include 'COMMON.FFIELD'
7615       include 'COMMON.TORCNSTR'
7616       include 'COMMON.CONTROL'
7617       logical lprn
7618 C Set lprn=.true. for debugging
7619       lprn=.false.
7620 c     lprn=.true.
7621       etors=0.0D0
7622       do i=iphi_start,iphi_end
7623 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7624 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7625 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7626 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7627         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7628      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7629 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7630 C For introducing the NH3+ and COO- group please check the etor_d for reference
7631 C and guidance
7632         etors_ii=0.0D0
7633          if (iabs(itype(i)).eq.20) then
7634          iblock=2
7635          else
7636          iblock=1
7637          endif
7638         itori=itortyp(itype(i-2))
7639         itori1=itortyp(itype(i-1))
7640         phii=phi(i)
7641         gloci=0.0D0
7642 C Regular cosine and sine terms
7643         do j=1,nterm(itori,itori1,iblock)
7644           v1ij=v1(j,itori,itori1,iblock)
7645           v2ij=v2(j,itori,itori1,iblock)
7646           cosphi=dcos(j*phii)
7647           sinphi=dsin(j*phii)
7648           etors=etors+v1ij*cosphi+v2ij*sinphi
7649           if (energy_dec) etors_ii=etors_ii+
7650      &                v1ij*cosphi+v2ij*sinphi
7651           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7652         enddo
7653 C Lorentz terms
7654 C                         v1
7655 C  E = SUM ----------------------------------- - v1
7656 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7657 C
7658         cosphi=dcos(0.5d0*phii)
7659         sinphi=dsin(0.5d0*phii)
7660         do j=1,nlor(itori,itori1,iblock)
7661           vl1ij=vlor1(j,itori,itori1)
7662           vl2ij=vlor2(j,itori,itori1)
7663           vl3ij=vlor3(j,itori,itori1)
7664           pom=vl2ij*cosphi+vl3ij*sinphi
7665           pom1=1.0d0/(pom*pom+1.0d0)
7666           etors=etors+vl1ij*pom1
7667           if (energy_dec) etors_ii=etors_ii+
7668      &                vl1ij*pom1
7669           pom=-pom*pom1*pom1
7670           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7671         enddo
7672 C Subtract the constant term
7673         etors=etors-v0(itori,itori1,iblock)
7674           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7675      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7676         if (lprn)
7677      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7678      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7679      &  (v1(j,itori,itori1,iblock),j=1,6),
7680      &  (v2(j,itori,itori1,iblock),j=1,6)
7681         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7682 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7683       enddo
7684       return
7685       end
7686 c----------------------------------------------------------------------------
7687       subroutine etor_d(etors_d)
7688 C 6/23/01 Compute double torsional energy
7689       implicit none
7690       include 'DIMENSIONS'
7691       include 'COMMON.VAR'
7692       include 'COMMON.GEO'
7693       include 'COMMON.LOCAL'
7694       include 'COMMON.TORSION'
7695       include 'COMMON.INTERACT'
7696       include 'COMMON.DERIV'
7697       include 'COMMON.CHAIN'
7698       include 'COMMON.NAMES'
7699       include 'COMMON.IOUNITS'
7700       include 'COMMON.FFIELD'
7701       include 'COMMON.TORCNSTR'
7702       logical lprn
7703 C Set lprn=.true. for debugging
7704       lprn=.false.
7705 c     lprn=.true.
7706       etors_d=0.0D0
7707 c      write(iout,*) "a tu??"
7708       do i=iphid_start,iphid_end
7709 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7710 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7711 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7712 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7713 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7714          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7715      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7716      &  (itype(i+1).eq.ntyp1)) cycle
7717 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7718         itori=itortyp(itype(i-2))
7719         itori1=itortyp(itype(i-1))
7720         itori2=itortyp(itype(i))
7721         phii=phi(i)
7722         phii1=phi(i+1)
7723         gloci1=0.0D0
7724         gloci2=0.0D0
7725         iblock=1
7726         if (iabs(itype(i+1)).eq.20) iblock=2
7727 C Iblock=2 Proline type
7728 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7729 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7730 C        if (itype(i+1).eq.ntyp1) iblock=3
7731 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7732 C IS or IS NOT need for this
7733 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7734 C        is (itype(i-3).eq.ntyp1) ntblock=2
7735 C        ntblock is N-terminal blocking group
7736
7737 C Regular cosine and sine terms
7738         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7739 C Example of changes for NH3+ blocking group
7740 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7741 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7742           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7743           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7744           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7745           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7746           cosphi1=dcos(j*phii)
7747           sinphi1=dsin(j*phii)
7748           cosphi2=dcos(j*phii1)
7749           sinphi2=dsin(j*phii1)
7750           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7751      &     v2cij*cosphi2+v2sij*sinphi2
7752           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7753           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7754         enddo
7755         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7756           do l=1,k-1
7757             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7758             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7759             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7760             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7761             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7762             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7763             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7764             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7765             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7766      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7767             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7768      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7769             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7770      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7771           enddo
7772         enddo
7773         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7774         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7775       enddo
7776       return
7777       end
7778 #endif
7779 C----------------------------------------------------------------------------------
7780 C The rigorous attempt to derive energy function
7781       subroutine etor_kcc(etors)
7782       implicit none
7783       include 'DIMENSIONS'
7784       include 'COMMON.VAR'
7785       include 'COMMON.GEO'
7786       include 'COMMON.LOCAL'
7787       include 'COMMON.TORSION'
7788       include 'COMMON.INTERACT'
7789       include 'COMMON.DERIV'
7790       include 'COMMON.CHAIN'
7791       include 'COMMON.NAMES'
7792       include 'COMMON.IOUNITS'
7793       include 'COMMON.FFIELD'
7794       include 'COMMON.TORCNSTR'
7795       include 'COMMON.CONTROL'
7796       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7797       logical lprn
7798 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7799 C Set lprn=.true. for debugging
7800       lprn=energy_dec
7801 c     lprn=.true.
7802 C      print *,"wchodze kcc"
7803       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7804       etors=0.0D0
7805       do i=iphi_start,iphi_end
7806 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7807 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7808 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7809 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7810         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7811      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7812         itori=itortyp(itype(i-2))
7813         itori1=itortyp(itype(i-1))
7814         phii=phi(i)
7815         glocig=0.0D0
7816         glocit1=0.0d0
7817         glocit2=0.0d0
7818 C to avoid multiple devision by 2
7819 c        theti22=0.5d0*theta(i)
7820 C theta 12 is the theta_1 /2
7821 C theta 22 is theta_2 /2
7822 c        theti12=0.5d0*theta(i-1)
7823 C and appropriate sinus function
7824         sinthet1=dsin(theta(i-1))
7825         sinthet2=dsin(theta(i))
7826         costhet1=dcos(theta(i-1))
7827         costhet2=dcos(theta(i))
7828 C to speed up lets store its mutliplication
7829         sint1t2=sinthet2*sinthet1
7830         sint1t2n=1.0d0
7831 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7832 C +d_n*sin(n*gamma)) *
7833 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7834 C we have two sum 1) Non-Chebyshev which is with n and gamma
7835         nval=nterm_kcc_Tb(itori,itori1)
7836         c1(0)=0.0d0
7837         c2(0)=0.0d0
7838         c1(1)=1.0d0
7839         c2(1)=1.0d0
7840         do j=2,nval
7841           c1(j)=c1(j-1)*costhet1
7842           c2(j)=c2(j-1)*costhet2
7843         enddo
7844         etori=0.0d0
7845         do j=1,nterm_kcc(itori,itori1)
7846           cosphi=dcos(j*phii)
7847           sinphi=dsin(j*phii)
7848           sint1t2n1=sint1t2n
7849           sint1t2n=sint1t2n*sint1t2
7850           sumvalc=0.0d0
7851           gradvalct1=0.0d0
7852           gradvalct2=0.0d0
7853           do k=1,nval
7854             do l=1,nval
7855               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7856               gradvalct1=gradvalct1+
7857      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7858               gradvalct2=gradvalct2+
7859      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7860             enddo
7861           enddo
7862           gradvalct1=-gradvalct1*sinthet1
7863           gradvalct2=-gradvalct2*sinthet2
7864           sumvals=0.0d0
7865           gradvalst1=0.0d0
7866           gradvalst2=0.0d0
7867           do k=1,nval
7868             do l=1,nval
7869               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7870               gradvalst1=gradvalst1+
7871      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7872               gradvalst2=gradvalst2+
7873      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7874             enddo
7875           enddo
7876           gradvalst1=-gradvalst1*sinthet1
7877           gradvalst2=-gradvalst2*sinthet2
7878           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7879           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7880 C glocig is the gradient local i site in gamma
7881           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7882 C now gradient over theta_1
7883           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7884      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7885           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7886      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7887         enddo ! j
7888         etors=etors+etori
7889 C derivative over gamma
7890         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7891 C derivative over theta1
7892         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7893 C now derivative over theta2
7894         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7895         if (lprn) then
7896           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7897      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7898           write (iout,*) "c1",(c1(k),k=0,nval),
7899      &    " c2",(c2(k),k=0,nval)
7900         endif
7901       enddo
7902       return
7903       end
7904 c---------------------------------------------------------------------------------------------
7905       subroutine etor_constr(edihcnstr)
7906       implicit none
7907       include 'DIMENSIONS'
7908       include 'COMMON.VAR'
7909       include 'COMMON.GEO'
7910       include 'COMMON.LOCAL'
7911       include 'COMMON.TORSION'
7912       include 'COMMON.INTERACT'
7913       include 'COMMON.DERIV'
7914       include 'COMMON.CHAIN'
7915       include 'COMMON.NAMES'
7916       include 'COMMON.IOUNITS'
7917       include 'COMMON.FFIELD'
7918       include 'COMMON.TORCNSTR'
7919       include 'COMMON.BOUNDS'
7920       include 'COMMON.CONTROL'
7921 ! 6/20/98 - dihedral angle constraints
7922       edihcnstr=0.0d0
7923 c      do i=1,ndih_constr
7924       if (raw_psipred) then
7925         do i=idihconstr_start,idihconstr_end
7926           itori=idih_constr(i)
7927           phii=phi(itori)
7928           gaudih_i=vpsipred(1,i)
7929           gauder_i=0.0d0
7930           do j=1,2
7931             s = sdihed(j,i)
7932             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7933             dexpcos_i=dexp(-cos_i*cos_i)
7934             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7935             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7936      &            *cos_i*dexpcos_i/s**2
7937           enddo
7938           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7939           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7940           if (energy_dec)
7941      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7942      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7943      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7944      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7945      &     -wdihc*dlog(gaudih_i)
7946         enddo
7947       else
7948
7949       do i=idihconstr_start,idihconstr_end
7950         itori=idih_constr(i)
7951         phii=phi(itori)
7952         difi=pinorm(phii-phi0(i))
7953         if (difi.gt.drange(i)) then
7954           difi=difi-drange(i)
7955           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7956           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7957         else if (difi.lt.-drange(i)) then
7958           difi=difi+drange(i)
7959           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7960           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7961         else
7962           difi=0.0
7963         endif
7964       enddo
7965
7966       endif
7967
7968       return
7969       end
7970 c----------------------------------------------------------------------------
7971 c MODELLER restraint function
7972       subroutine e_modeller(ehomology_constr)
7973       implicit none
7974       include 'DIMENSIONS'
7975
7976       integer nnn, i, j, k, ki, irec, l
7977       integer katy, odleglosci, test7
7978       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7979       real*8 Eval,Erot
7980       real*8 distance(max_template),distancek(max_template),
7981      &    min_odl,godl(max_template),dih_diff(max_template)
7982
7983 c
7984 c     FP - 30/10/2014 Temporary specifications for homology restraints
7985 c
7986       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7987      &                 sgtheta
7988       double precision, dimension (maxres) :: guscdiff,usc_diff
7989       double precision, dimension (max_template) ::
7990      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7991      &           theta_diff
7992 c
7993
7994       include 'COMMON.SBRIDGE'
7995       include 'COMMON.CHAIN'
7996       include 'COMMON.GEO'
7997       include 'COMMON.DERIV'
7998       include 'COMMON.LOCAL'
7999       include 'COMMON.INTERACT'
8000       include 'COMMON.VAR'
8001       include 'COMMON.IOUNITS'
8002       include 'COMMON.MD'
8003       include 'COMMON.CONTROL'
8004       include 'COMMON.HOMOLOGY'
8005       include 'COMMON.QRESTR'
8006 c
8007 c     From subroutine Econstr_back
8008 c
8009       include 'COMMON.NAMES'
8010       include 'COMMON.TIME1'
8011 c
8012
8013
8014       do i=1,max_template
8015         distancek(i)=9999999.9
8016       enddo
8017
8018
8019       odleg=0.0d0
8020
8021 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8022 c function)
8023 C AL 5/2/14 - Introduce list of restraints
8024 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8025 #ifdef DEBUG
8026       write(iout,*) "------- dist restrs start -------"
8027 #endif
8028       do ii = link_start_homo,link_end_homo
8029          i = ires_homo(ii)
8030          j = jres_homo(ii)
8031          dij=dist(i,j)
8032 c        write (iout,*) "dij(",i,j,") =",dij
8033          nexl=0
8034          do k=1,constr_homology
8035 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8036            if(.not.l_homo(k,ii)) then
8037              nexl=nexl+1
8038              cycle
8039            endif
8040            distance(k)=odl(k,ii)-dij
8041 c          write (iout,*) "distance(",k,") =",distance(k)
8042 c
8043 c          For Gaussian-type Urestr
8044 c
8045            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8046 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8047 c          write (iout,*) "distancek(",k,") =",distancek(k)
8048 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8049 c
8050 c          For Lorentzian-type Urestr
8051 c
8052            if (waga_dist.lt.0.0d0) then
8053               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8054               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8055      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8056            endif
8057          enddo
8058
8059 c         min_odl=minval(distancek)
8060          do kk=1,constr_homology
8061           if(l_homo(kk,ii)) then
8062             min_odl=distancek(kk)
8063             exit
8064           endif
8065          enddo
8066          do kk=1,constr_homology
8067           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8068      &              min_odl=distancek(kk)
8069          enddo
8070
8071 c        write (iout,* )"min_odl",min_odl
8072 #ifdef DEBUG
8073          write (iout,*) "ij dij",i,j,dij
8074          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8075          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8076          write (iout,* )"min_odl",min_odl
8077 #endif
8078 #ifdef OLDRESTR
8079          odleg2=0.0d0
8080 #else
8081          if (waga_dist.ge.0.0d0) then
8082            odleg2=nexl
8083          else
8084            odleg2=0.0d0
8085          endif
8086 #endif
8087          do k=1,constr_homology
8088 c Nie wiem po co to liczycie jeszcze raz!
8089 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8090 c     &              (2*(sigma_odl(i,j,k))**2))
8091            if(.not.l_homo(k,ii)) cycle
8092            if (waga_dist.ge.0.0d0) then
8093 c
8094 c          For Gaussian-type Urestr
8095 c
8096             godl(k)=dexp(-distancek(k)+min_odl)
8097             odleg2=odleg2+godl(k)
8098 c
8099 c          For Lorentzian-type Urestr
8100 c
8101            else
8102             odleg2=odleg2+distancek(k)
8103            endif
8104
8105 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8106 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8107 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8108 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8109
8110          enddo
8111 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8112 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8113 #ifdef DEBUG
8114          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8115          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8116 #endif
8117            if (waga_dist.ge.0.0d0) then
8118 c
8119 c          For Gaussian-type Urestr
8120 c
8121               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8122 c
8123 c          For Lorentzian-type Urestr
8124 c
8125            else
8126               odleg=odleg+odleg2/constr_homology
8127            endif
8128 c
8129 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8130 c Gradient
8131 c
8132 c          For Gaussian-type Urestr
8133 c
8134          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8135          sum_sgodl=0.0d0
8136          do k=1,constr_homology
8137 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8138 c     &           *waga_dist)+min_odl
8139 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8140 c
8141          if(.not.l_homo(k,ii)) cycle
8142          if (waga_dist.ge.0.0d0) then
8143 c          For Gaussian-type Urestr
8144 c
8145            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8146 c
8147 c          For Lorentzian-type Urestr
8148 c
8149          else
8150            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8151      &           sigma_odlir(k,ii)**2)**2)
8152          endif
8153            sum_sgodl=sum_sgodl+sgodl
8154
8155 c            sgodl2=sgodl2+sgodl
8156 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8157 c      write(iout,*) "constr_homology=",constr_homology
8158 c      write(iout,*) i, j, k, "TEST K"
8159          enddo
8160          if (waga_dist.ge.0.0d0) then
8161 c
8162 c          For Gaussian-type Urestr
8163 c
8164             grad_odl3=waga_homology(iset)*waga_dist
8165      &                *sum_sgodl/(sum_godl*dij)
8166 c
8167 c          For Lorentzian-type Urestr
8168 c
8169          else
8170 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8171 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8172             grad_odl3=-waga_homology(iset)*waga_dist*
8173      &                sum_sgodl/(constr_homology*dij)
8174          endif
8175 c
8176 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8177
8178
8179 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8180 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8181 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8182
8183 ccc      write(iout,*) godl, sgodl, grad_odl3
8184
8185 c          grad_odl=grad_odl+grad_odl3
8186
8187          do jik=1,3
8188             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8189 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8190 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8191 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8192             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8193             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8194 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8195 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8196 c         if (i.eq.25.and.j.eq.27) then
8197 c         write(iout,*) "jik",jik,"i",i,"j",j
8198 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8199 c         write(iout,*) "grad_odl3",grad_odl3
8200 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8201 c         write(iout,*) "ggodl",ggodl
8202 c         write(iout,*) "ghpbc(",jik,i,")",
8203 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8204 c     &                 ghpbc(jik,j)
8205 c         endif
8206          enddo
8207 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8208 ccc     & dLOG(odleg2),"-odleg=", -odleg
8209
8210       enddo ! ii-loop for dist
8211 #ifdef DEBUG
8212       write(iout,*) "------- dist restrs end -------"
8213 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8214 c    &     waga_d.eq.1.0d0) call sum_gradient
8215 #endif
8216 c Pseudo-energy and gradient from dihedral-angle restraints from
8217 c homology templates
8218 c      write (iout,*) "End of distance loop"
8219 c      call flush(iout)
8220       kat=0.0d0
8221 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8222 #ifdef DEBUG
8223       write(iout,*) "------- dih restrs start -------"
8224       do i=idihconstr_start_homo,idihconstr_end_homo
8225         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8226       enddo
8227 #endif
8228       do i=idihconstr_start_homo,idihconstr_end_homo
8229         kat2=0.0d0
8230 c        betai=beta(i,i+1,i+2,i+3)
8231         betai = phi(i)
8232 c       write (iout,*) "betai =",betai
8233         do k=1,constr_homology
8234           dih_diff(k)=pinorm(dih(k,i)-betai)
8235 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8236 cd     &                  ,sigma_dih(k,i)
8237 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8238 c     &                                   -(6.28318-dih_diff(i,k))
8239 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8240 c     &                                   6.28318+dih_diff(i,k)
8241 #ifdef OLD_DIHED
8242           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8243 #else
8244           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8245 #endif
8246 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8247           gdih(k)=dexp(kat3)
8248           kat2=kat2+gdih(k)
8249 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8250 c          write(*,*)""
8251         enddo
8252 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8253 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8254 #ifdef DEBUG
8255         write (iout,*) "i",i," betai",betai," kat2",kat2
8256         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8257 #endif
8258         if (kat2.le.1.0d-14) cycle
8259         kat=kat-dLOG(kat2/constr_homology)
8260 c       write (iout,*) "kat",kat ! sum of -ln-s
8261
8262 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8263 ccc     & dLOG(kat2), "-kat=", -kat
8264
8265 c ----------------------------------------------------------------------
8266 c Gradient
8267 c ----------------------------------------------------------------------
8268
8269         sum_gdih=kat2
8270         sum_sgdih=0.0d0
8271         do k=1,constr_homology
8272 #ifdef OLD_DIHED
8273           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8274 #else
8275           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8276 #endif
8277 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8278           sum_sgdih=sum_sgdih+sgdih
8279         enddo
8280 c       grad_dih3=sum_sgdih/sum_gdih
8281         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8282
8283 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8284 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8285 ccc     & gloc(nphi+i-3,icg)
8286         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8287 c        if (i.eq.25) then
8288 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8289 c        endif
8290 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8291 ccc     & gloc(nphi+i-3,icg)
8292
8293       enddo ! i-loop for dih
8294 #ifdef DEBUG
8295       write(iout,*) "------- dih restrs end -------"
8296 #endif
8297
8298 c Pseudo-energy and gradient for theta angle restraints from
8299 c homology templates
8300 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8301 c adapted
8302
8303 c
8304 c     For constr_homology reference structures (FP)
8305 c
8306 c     Uconst_back_tot=0.0d0
8307       Eval=0.0d0
8308       Erot=0.0d0
8309 c     Econstr_back legacy
8310       do i=1,nres
8311 c     do i=ithet_start,ithet_end
8312        dutheta(i)=0.0d0
8313 c     enddo
8314 c     do i=loc_start,loc_end
8315         do j=1,3
8316           duscdiff(j,i)=0.0d0
8317           duscdiffx(j,i)=0.0d0
8318         enddo
8319       enddo
8320 c
8321 c     do iref=1,nref
8322 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8323 c     write (iout,*) "waga_theta",waga_theta
8324       if (waga_theta.gt.0.0d0) then
8325 #ifdef DEBUG
8326       write (iout,*) "usampl",usampl
8327       write(iout,*) "------- theta restrs start -------"
8328 c     do i=ithet_start,ithet_end
8329 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8330 c     enddo
8331 #endif
8332 c     write (iout,*) "maxres",maxres,"nres",nres
8333
8334       do i=ithet_start,ithet_end
8335 c
8336 c     do i=1,nfrag_back
8337 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8338 c
8339 c Deviation of theta angles wrt constr_homology ref structures
8340 c
8341         utheta_i=0.0d0 ! argument of Gaussian for single k
8342         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8343 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8344 c       over residues in a fragment
8345 c       write (iout,*) "theta(",i,")=",theta(i)
8346         do k=1,constr_homology
8347 c
8348 c         dtheta_i=theta(j)-thetaref(j,iref)
8349 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8350           theta_diff(k)=thetatpl(k,i)-theta(i)
8351 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8352 cd     &                  ,sigma_theta(k,i)
8353
8354 c
8355           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8356 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8357           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8358           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8359 c         Gradient for single Gaussian restraint in subr Econstr_back
8360 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8361 c
8362         enddo
8363 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8364 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8365
8366 c
8367 c         Gradient for multiple Gaussian restraint
8368         sum_gtheta=gutheta_i
8369         sum_sgtheta=0.0d0
8370         do k=1,constr_homology
8371 c        New generalized expr for multiple Gaussian from Econstr_back
8372          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8373 c
8374 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8375           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8376         enddo
8377 c       Final value of gradient using same var as in Econstr_back
8378         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8379      &      +sum_sgtheta/sum_gtheta*waga_theta
8380      &               *waga_homology(iset)
8381 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8382 c     &               *waga_homology(iset)
8383 c       dutheta(i)=sum_sgtheta/sum_gtheta
8384 c
8385 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8386         Eval=Eval-dLOG(gutheta_i/constr_homology)
8387 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8388 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8389 c       Uconst_back=Uconst_back+utheta(i)
8390       enddo ! (i-loop for theta)
8391 #ifdef DEBUG
8392       write(iout,*) "------- theta restrs end -------"
8393 #endif
8394       endif
8395 c
8396 c Deviation of local SC geometry
8397 c
8398 c Separation of two i-loops (instructed by AL - 11/3/2014)
8399 c
8400 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8401 c     write (iout,*) "waga_d",waga_d
8402
8403 #ifdef DEBUG
8404       write(iout,*) "------- SC restrs start -------"
8405       write (iout,*) "Initial duscdiff,duscdiffx"
8406       do i=loc_start,loc_end
8407         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8408      &                 (duscdiffx(jik,i),jik=1,3)
8409       enddo
8410 #endif
8411       do i=loc_start,loc_end
8412         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8413         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8414 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8415 c       write(iout,*) "xxtab, yytab, zztab"
8416 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8417         do k=1,constr_homology
8418 c
8419           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8420 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8421           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8422           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8423 c         write(iout,*) "dxx, dyy, dzz"
8424 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8425 c
8426           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8427 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8428 c         uscdiffk(k)=usc_diff(i)
8429           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8430 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8431 c     &       " guscdiff2",guscdiff2(k)
8432           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8433 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8434 c     &      xxref(j),yyref(j),zzref(j)
8435         enddo
8436 c
8437 c       Gradient
8438 c
8439 c       Generalized expression for multiple Gaussian acc to that for a single
8440 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8441 c
8442 c       Original implementation
8443 c       sum_guscdiff=guscdiff(i)
8444 c
8445 c       sum_sguscdiff=0.0d0
8446 c       do k=1,constr_homology
8447 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8448 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8449 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8450 c       enddo
8451 c
8452 c       Implementation of new expressions for gradient (Jan. 2015)
8453 c
8454 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8455         do k=1,constr_homology
8456 c
8457 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8458 c       before. Now the drivatives should be correct
8459 c
8460           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8461 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8462           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8463           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8464 c
8465 c         New implementation
8466 c
8467           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8468      &                 sigma_d(k,i) ! for the grad wrt r'
8469 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8470 c
8471 c
8472 c        New implementation
8473          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8474          do jik=1,3
8475             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8476      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8477      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8478             duscdiff(jik,i)=duscdiff(jik,i)+
8479      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8480      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8481             duscdiffx(jik,i)=duscdiffx(jik,i)+
8482      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8483      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8484 c
8485 #ifdef DEBUG
8486              write(iout,*) "jik",jik,"i",i
8487              write(iout,*) "dxx, dyy, dzz"
8488              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8489              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8490 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8491 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8492 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8493 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8494 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8495 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8496 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8497 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8498 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8499 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8500 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8501 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8502 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8503 c            endif
8504 #endif
8505          enddo
8506         enddo
8507 c
8508 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8509 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8510 c
8511 c        write (iout,*) i," uscdiff",uscdiff(i)
8512 c
8513 c Put together deviations from local geometry
8514
8515 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8516 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8517         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8518 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8519 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8520 c       Uconst_back=Uconst_back+usc_diff(i)
8521 c
8522 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8523 c
8524 c     New implment: multiplied by sum_sguscdiff
8525 c
8526
8527       enddo ! (i-loop for dscdiff)
8528
8529 c      endif
8530
8531 #ifdef DEBUG
8532       write(iout,*) "------- SC restrs end -------"
8533         write (iout,*) "------ After SC loop in e_modeller ------"
8534         do i=loc_start,loc_end
8535          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8536          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8537         enddo
8538       if (waga_theta.eq.1.0d0) then
8539       write (iout,*) "in e_modeller after SC restr end: dutheta"
8540       do i=ithet_start,ithet_end
8541         write (iout,*) i,dutheta(i)
8542       enddo
8543       endif
8544       if (waga_d.eq.1.0d0) then
8545       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8546       do i=1,nres
8547         write (iout,*) i,(duscdiff(j,i),j=1,3)
8548         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8549       enddo
8550       endif
8551 #endif
8552
8553 c Total energy from homology restraints
8554 #ifdef DEBUG
8555       write (iout,*) "odleg",odleg," kat",kat
8556 #endif
8557 c
8558 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8559 c
8560 c     ehomology_constr=odleg+kat
8561 c
8562 c     For Lorentzian-type Urestr
8563 c
8564
8565       if (waga_dist.ge.0.0d0) then
8566 c
8567 c          For Gaussian-type Urestr
8568 c
8569         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8570      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8571 c     write (iout,*) "ehomology_constr=",ehomology_constr
8572       else
8573 c
8574 c          For Lorentzian-type Urestr
8575 c
8576         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8577      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8578 c     write (iout,*) "ehomology_constr=",ehomology_constr
8579       endif
8580 #ifdef DEBUG
8581       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8582      & "Eval",waga_theta,eval,
8583      &   "Erot",waga_d,Erot
8584       write (iout,*) "ehomology_constr",ehomology_constr
8585 #endif
8586       return
8587 c
8588 c FP 01/15 end
8589 c
8590   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8591   747 format(a12,i4,i4,i4,f8.3,f8.3)
8592   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8593   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8594   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8595      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8596       end
8597 c----------------------------------------------------------------------------
8598 C The rigorous attempt to derive energy function
8599       subroutine ebend_kcc(etheta)
8600
8601       implicit none
8602       include 'DIMENSIONS'
8603       include 'COMMON.VAR'
8604       include 'COMMON.GEO'
8605       include 'COMMON.LOCAL'
8606       include 'COMMON.TORSION'
8607       include 'COMMON.INTERACT'
8608       include 'COMMON.DERIV'
8609       include 'COMMON.CHAIN'
8610       include 'COMMON.NAMES'
8611       include 'COMMON.IOUNITS'
8612       include 'COMMON.FFIELD'
8613       include 'COMMON.TORCNSTR'
8614       include 'COMMON.CONTROL'
8615       logical lprn
8616       double precision thybt1(maxang_kcc)
8617 C Set lprn=.true. for debugging
8618       lprn=energy_dec
8619 c     lprn=.true.
8620 C      print *,"wchodze kcc"
8621       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8622       etheta=0.0D0
8623       do i=ithet_start,ithet_end
8624 c        print *,i,itype(i-1),itype(i),itype(i-2)
8625         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8626      &  .or.itype(i).eq.ntyp1) cycle
8627         iti=iabs(itortyp(itype(i-1)))
8628         sinthet=dsin(theta(i))
8629         costhet=dcos(theta(i))
8630         do j=1,nbend_kcc_Tb(iti)
8631           thybt1(j)=v1bend_chyb(j,iti)
8632         enddo
8633         sumth1thyb=v1bend_chyb(0,iti)+
8634      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8635         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8636      &    sumth1thyb
8637         ihelp=nbend_kcc_Tb(iti)-1
8638         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8639         etheta=etheta+sumth1thyb
8640 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8641         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8642       enddo
8643       return
8644       end
8645 c-------------------------------------------------------------------------------------
8646       subroutine etheta_constr(ethetacnstr)
8647
8648       implicit none
8649       include 'DIMENSIONS'
8650       include 'COMMON.VAR'
8651       include 'COMMON.GEO'
8652       include 'COMMON.LOCAL'
8653       include 'COMMON.TORSION'
8654       include 'COMMON.INTERACT'
8655       include 'COMMON.DERIV'
8656       include 'COMMON.CHAIN'
8657       include 'COMMON.NAMES'
8658       include 'COMMON.IOUNITS'
8659       include 'COMMON.FFIELD'
8660       include 'COMMON.TORCNSTR'
8661       include 'COMMON.CONTROL'
8662       ethetacnstr=0.0d0
8663 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8664       do i=ithetaconstr_start,ithetaconstr_end
8665         itheta=itheta_constr(i)
8666         thetiii=theta(itheta)
8667         difi=pinorm(thetiii-theta_constr0(i))
8668         if (difi.gt.theta_drange(i)) then
8669           difi=difi-theta_drange(i)
8670           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8671           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8672      &    +for_thet_constr(i)*difi**3
8673         else if (difi.lt.-drange(i)) then
8674           difi=difi+drange(i)
8675           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8676           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8677      &    +for_thet_constr(i)*difi**3
8678         else
8679           difi=0.0
8680         endif
8681        if (energy_dec) then
8682         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8683      &    i,itheta,rad2deg*thetiii,
8684      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8685      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8686      &    gloc(itheta+nphi-2,icg)
8687         endif
8688       enddo
8689       return
8690       end
8691 c------------------------------------------------------------------------------
8692       subroutine eback_sc_corr(esccor)
8693 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8694 c        conformational states; temporarily implemented as differences
8695 c        between UNRES torsional potentials (dependent on three types of
8696 c        residues) and the torsional potentials dependent on all 20 types
8697 c        of residues computed from AM1  energy surfaces of terminally-blocked
8698 c        amino-acid residues.
8699       implicit none
8700       include 'DIMENSIONS'
8701       include 'COMMON.VAR'
8702       include 'COMMON.GEO'
8703       include 'COMMON.LOCAL'
8704       include 'COMMON.TORSION'
8705       include 'COMMON.SCCOR'
8706       include 'COMMON.INTERACT'
8707       include 'COMMON.DERIV'
8708       include 'COMMON.CHAIN'
8709       include 'COMMON.NAMES'
8710       include 'COMMON.IOUNITS'
8711       include 'COMMON.FFIELD'
8712       include 'COMMON.CONTROL'
8713       logical lprn
8714 C Set lprn=.true. for debugging
8715       lprn=.false.
8716 c      lprn=.true.
8717 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8718       esccor=0.0D0
8719       do i=itau_start,itau_end
8720         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8721         esccor_ii=0.0D0
8722         isccori=isccortyp(itype(i-2))
8723         isccori1=isccortyp(itype(i-1))
8724 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8725         phii=phi(i)
8726         do intertyp=1,3 !intertyp
8727 cc Added 09 May 2012 (Adasko)
8728 cc  Intertyp means interaction type of backbone mainchain correlation:
8729 c   1 = SC...Ca...Ca...Ca
8730 c   2 = Ca...Ca...Ca...SC
8731 c   3 = SC...Ca...Ca...SCi
8732         gloci=0.0D0
8733         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8734      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8735      &      (itype(i-1).eq.ntyp1)))
8736      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8737      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8738      &     .or.(itype(i).eq.ntyp1)))
8739      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8740      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8741      &      (itype(i-3).eq.ntyp1)))) cycle
8742         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8743         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8744      & cycle
8745        do j=1,nterm_sccor(isccori,isccori1)
8746           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8747           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8748           cosphi=dcos(j*tauangle(intertyp,i))
8749           sinphi=dsin(j*tauangle(intertyp,i))
8750           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8751           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8752         enddo
8753 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8754         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8755         if (lprn)
8756      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8757      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8758      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8759      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8760         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8761        enddo !intertyp
8762       enddo
8763
8764       return
8765       end
8766 c----------------------------------------------------------------------------
8767       subroutine multibody(ecorr)
8768 C This subroutine calculates multi-body contributions to energy following
8769 C the idea of Skolnick et al. If side chains I and J make a contact and
8770 C at the same time side chains I+1 and J+1 make a contact, an extra
8771 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8772       implicit none
8773       include 'DIMENSIONS'
8774       include 'COMMON.IOUNITS'
8775       include 'COMMON.DERIV'
8776       include 'COMMON.INTERACT'
8777       include 'COMMON.CONTACTS'
8778       double precision gx(3),gx1(3)
8779       logical lprn
8780
8781 C Set lprn=.true. for debugging
8782       lprn=.false.
8783
8784       if (lprn) then
8785         write (iout,'(a)') 'Contact function values:'
8786         do i=nnt,nct-2
8787           write (iout,'(i2,20(1x,i2,f10.5))')
8788      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8789         enddo
8790       endif
8791       ecorr=0.0D0
8792       do i=nnt,nct
8793         do j=1,3
8794           gradcorr(j,i)=0.0D0
8795           gradxorr(j,i)=0.0D0
8796         enddo
8797       enddo
8798       do i=nnt,nct-2
8799
8800         DO ISHIFT = 3,4
8801
8802         i1=i+ishift
8803         num_conti=num_cont(i)
8804         num_conti1=num_cont(i1)
8805         do jj=1,num_conti
8806           j=jcont(jj,i)
8807           do kk=1,num_conti1
8808             j1=jcont(kk,i1)
8809             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8810 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8811 cd   &                   ' ishift=',ishift
8812 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8813 C The system gains extra energy.
8814               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8815             endif   ! j1==j+-ishift
8816           enddo     ! kk
8817         enddo       ! jj
8818
8819         ENDDO ! ISHIFT
8820
8821       enddo         ! i
8822       return
8823       end
8824 c------------------------------------------------------------------------------
8825       double precision function esccorr(i,j,k,l,jj,kk)
8826       implicit none
8827       include 'DIMENSIONS'
8828       include 'COMMON.IOUNITS'
8829       include 'COMMON.DERIV'
8830       include 'COMMON.INTERACT'
8831       include 'COMMON.CONTACTS'
8832       include 'COMMON.SHIELD'
8833       double precision gx(3),gx1(3)
8834       logical lprn
8835       lprn=.false.
8836       eij=facont(jj,i)
8837       ekl=facont(kk,k)
8838 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8839 C Calculate the multi-body contribution to energy.
8840 C Calculate multi-body contributions to the gradient.
8841 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8842 cd   & k,l,(gacont(m,kk,k),m=1,3)
8843       do m=1,3
8844         gx(m) =ekl*gacont(m,jj,i)
8845         gx1(m)=eij*gacont(m,kk,k)
8846         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8847         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8848         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8849         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8850       enddo
8851       do m=i,j-1
8852         do ll=1,3
8853           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8854         enddo
8855       enddo
8856       do m=k,l-1
8857         do ll=1,3
8858           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8859         enddo
8860       enddo
8861       esccorr=-eij*ekl
8862       return
8863       end
8864 c------------------------------------------------------------------------------
8865       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8866 C This subroutine calculates multi-body contributions to hydrogen-bonding
8867       implicit none
8868       include 'DIMENSIONS'
8869       include 'COMMON.IOUNITS'
8870 #ifdef MPI
8871       include "mpif.h"
8872       parameter (max_cont=maxconts)
8873       parameter (max_dim=26)
8874       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8875       double precision zapas(max_dim,maxconts,max_fg_procs),
8876      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8877       common /przechowalnia/ zapas
8878       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8879      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8880 #endif
8881       include 'COMMON.SETUP'
8882       include 'COMMON.FFIELD'
8883       include 'COMMON.DERIV'
8884       include 'COMMON.INTERACT'
8885       include 'COMMON.CONTACTS'
8886       include 'COMMON.CONTROL'
8887       include 'COMMON.LOCAL'
8888       double precision gx(3),gx1(3),time00
8889       logical lprn,ldone
8890
8891 C Set lprn=.true. for debugging
8892       lprn=.false.
8893 #ifdef MPI
8894       n_corr=0
8895       n_corr1=0
8896       if (nfgtasks.le.1) goto 30
8897       if (lprn) then
8898         write (iout,'(a)') 'Contact function values before RECEIVE:'
8899         do i=nnt,nct-2
8900           write (iout,'(2i3,50(1x,i2,f5.2))')
8901      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8902      &    j=1,num_cont_hb(i))
8903         enddo
8904         call flush(iout)
8905       endif
8906       do i=1,ntask_cont_from
8907         ncont_recv(i)=0
8908       enddo
8909       do i=1,ntask_cont_to
8910         ncont_sent(i)=0
8911       enddo
8912 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8913 c     & ntask_cont_to
8914 C Make the list of contacts to send to send to other procesors
8915 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8916 c      call flush(iout)
8917       do i=iturn3_start,iturn3_end
8918 c        write (iout,*) "make contact list turn3",i," num_cont",
8919 c     &    num_cont_hb(i)
8920         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8921       enddo
8922       do i=iturn4_start,iturn4_end
8923 c        write (iout,*) "make contact list turn4",i," num_cont",
8924 c     &   num_cont_hb(i)
8925         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8926       enddo
8927       do ii=1,nat_sent
8928         i=iat_sent(ii)
8929 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8930 c     &    num_cont_hb(i)
8931         do j=1,num_cont_hb(i)
8932         do k=1,4
8933           jjc=jcont_hb(j,i)
8934           iproc=iint_sent_local(k,jjc,ii)
8935 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8936           if (iproc.gt.0) then
8937             ncont_sent(iproc)=ncont_sent(iproc)+1
8938             nn=ncont_sent(iproc)
8939             zapas(1,nn,iproc)=i
8940             zapas(2,nn,iproc)=jjc
8941             zapas(3,nn,iproc)=facont_hb(j,i)
8942             zapas(4,nn,iproc)=ees0p(j,i)
8943             zapas(5,nn,iproc)=ees0m(j,i)
8944             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8945             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8946             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8947             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8948             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8949             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8950             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8951             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8952             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8953             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8954             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8955             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8956             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8957             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8958             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8959             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8960             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8961             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8962             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8963             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8964             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8965           endif
8966         enddo
8967         enddo
8968       enddo
8969       if (lprn) then
8970       write (iout,*)
8971      &  "Numbers of contacts to be sent to other processors",
8972      &  (ncont_sent(i),i=1,ntask_cont_to)
8973       write (iout,*) "Contacts sent"
8974       do ii=1,ntask_cont_to
8975         nn=ncont_sent(ii)
8976         iproc=itask_cont_to(ii)
8977         write (iout,*) nn," contacts to processor",iproc,
8978      &   " of CONT_TO_COMM group"
8979         do i=1,nn
8980           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8981         enddo
8982       enddo
8983       call flush(iout)
8984       endif
8985       CorrelType=477
8986       CorrelID=fg_rank+1
8987       CorrelType1=478
8988       CorrelID1=nfgtasks+fg_rank+1
8989       ireq=0
8990 C Receive the numbers of needed contacts from other processors
8991       do ii=1,ntask_cont_from
8992         iproc=itask_cont_from(ii)
8993         ireq=ireq+1
8994         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8995      &    FG_COMM,req(ireq),IERR)
8996       enddo
8997 c      write (iout,*) "IRECV ended"
8998 c      call flush(iout)
8999 C Send the number of contacts needed by other processors
9000       do ii=1,ntask_cont_to
9001         iproc=itask_cont_to(ii)
9002         ireq=ireq+1
9003         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9004      &    FG_COMM,req(ireq),IERR)
9005       enddo
9006 c      write (iout,*) "ISEND ended"
9007 c      write (iout,*) "number of requests (nn)",ireq
9008 c      call flush(iout)
9009       if (ireq.gt.0)
9010      &  call MPI_Waitall(ireq,req,status_array,ierr)
9011 c      write (iout,*)
9012 c     &  "Numbers of contacts to be received from other processors",
9013 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9014 c      call flush(iout)
9015 C Receive contacts
9016       ireq=0
9017       do ii=1,ntask_cont_from
9018         iproc=itask_cont_from(ii)
9019         nn=ncont_recv(ii)
9020 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9021 c     &   " of CONT_TO_COMM group"
9022 c        call flush(iout)
9023         if (nn.gt.0) then
9024           ireq=ireq+1
9025           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9026      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9027 c          write (iout,*) "ireq,req",ireq,req(ireq)
9028         endif
9029       enddo
9030 C Send the contacts to processors that need them
9031       do ii=1,ntask_cont_to
9032         iproc=itask_cont_to(ii)
9033         nn=ncont_sent(ii)
9034 c        write (iout,*) nn," contacts to processor",iproc,
9035 c     &   " of CONT_TO_COMM group"
9036         if (nn.gt.0) then
9037           ireq=ireq+1
9038           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9039      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9040 c          write (iout,*) "ireq,req",ireq,req(ireq)
9041 c          do i=1,nn
9042 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9043 c          enddo
9044         endif
9045       enddo
9046 c      write (iout,*) "number of requests (contacts)",ireq
9047 c      write (iout,*) "req",(req(i),i=1,4)
9048 c      call flush(iout)
9049       if (ireq.gt.0)
9050      & call MPI_Waitall(ireq,req,status_array,ierr)
9051       do iii=1,ntask_cont_from
9052         iproc=itask_cont_from(iii)
9053         nn=ncont_recv(iii)
9054         if (lprn) then
9055         write (iout,*) "Received",nn," contacts from processor",iproc,
9056      &   " of CONT_FROM_COMM group"
9057         call flush(iout)
9058         do i=1,nn
9059           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9060         enddo
9061         call flush(iout)
9062         endif
9063         do i=1,nn
9064           ii=zapas_recv(1,i,iii)
9065 c Flag the received contacts to prevent double-counting
9066           jj=-zapas_recv(2,i,iii)
9067 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9068 c          call flush(iout)
9069           nnn=num_cont_hb(ii)+1
9070           num_cont_hb(ii)=nnn
9071           jcont_hb(nnn,ii)=jj
9072           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9073           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9074           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9075           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9076           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9077           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9078           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9079           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9080           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9081           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9082           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9083           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9084           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9085           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9086           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9087           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9088           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9089           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9090           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9091           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9092           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9093           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9094           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9095           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9096         enddo
9097       enddo
9098       if (lprn) then
9099         write (iout,'(a)') 'Contact function values after receive:'
9100         do i=nnt,nct-2
9101           write (iout,'(2i3,50(1x,i3,f5.2))')
9102      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9103      &    j=1,num_cont_hb(i))
9104         enddo
9105         call flush(iout)
9106       endif
9107    30 continue
9108 #endif
9109       if (lprn) then
9110         write (iout,'(a)') 'Contact function values:'
9111         do i=nnt,nct-2
9112           write (iout,'(2i3,50(1x,i3,f5.2))')
9113      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9114      &    j=1,num_cont_hb(i))
9115         enddo
9116         call flush(iout)
9117       endif
9118       ecorr=0.0D0
9119 C Remove the loop below after debugging !!!
9120       do i=nnt,nct
9121         do j=1,3
9122           gradcorr(j,i)=0.0D0
9123           gradxorr(j,i)=0.0D0
9124         enddo
9125       enddo
9126 C Calculate the local-electrostatic correlation terms
9127       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9128         i1=i+1
9129         num_conti=num_cont_hb(i)
9130         num_conti1=num_cont_hb(i+1)
9131         do jj=1,num_conti
9132           j=jcont_hb(jj,i)
9133           jp=iabs(j)
9134           do kk=1,num_conti1
9135             j1=jcont_hb(kk,i1)
9136             jp1=iabs(j1)
9137 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9138 c     &         ' jj=',jj,' kk=',kk
9139 c            call flush(iout)
9140             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9141      &          .or. j.lt.0 .and. j1.gt.0) .and.
9142      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9143 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9144 C The system gains extra energy.
9145               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9146               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9147      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9148               n_corr=n_corr+1
9149             else if (j1.eq.j) then
9150 C Contacts I-J and I-(J+1) occur simultaneously.
9151 C The system loses extra energy.
9152 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9153             endif
9154           enddo ! kk
9155           do kk=1,num_conti
9156             j1=jcont_hb(kk,i)
9157 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9158 c    &         ' jj=',jj,' kk=',kk
9159             if (j1.eq.j+1) then
9160 C Contacts I-J and (I+1)-J occur simultaneously.
9161 C The system loses extra energy.
9162 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9163             endif ! j1==j+1
9164           enddo ! kk
9165         enddo ! jj
9166       enddo ! i
9167       return
9168       end
9169 c------------------------------------------------------------------------------
9170       subroutine add_hb_contact(ii,jj,itask)
9171       implicit none
9172       include "DIMENSIONS"
9173       include "COMMON.IOUNITS"
9174       integer max_cont
9175       integer max_dim
9176       parameter (max_cont=maxconts)
9177       parameter (max_dim=26)
9178       include "COMMON.CONTACTS"
9179       double precision zapas(max_dim,maxconts,max_fg_procs),
9180      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9181       common /przechowalnia/ zapas
9182       integer i,j,ii,jj,iproc,itask(4),nn
9183 c      write (iout,*) "itask",itask
9184       do i=1,2
9185         iproc=itask(i)
9186         if (iproc.gt.0) then
9187           do j=1,num_cont_hb(ii)
9188             jjc=jcont_hb(j,ii)
9189 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9190             if (jjc.eq.jj) then
9191               ncont_sent(iproc)=ncont_sent(iproc)+1
9192               nn=ncont_sent(iproc)
9193               zapas(1,nn,iproc)=ii
9194               zapas(2,nn,iproc)=jjc
9195               zapas(3,nn,iproc)=facont_hb(j,ii)
9196               zapas(4,nn,iproc)=ees0p(j,ii)
9197               zapas(5,nn,iproc)=ees0m(j,ii)
9198               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9199               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9200               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9201               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9202               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9203               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9204               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9205               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9206               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9207               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9208               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9209               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9210               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9211               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9212               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9213               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9214               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9215               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9216               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9217               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9218               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9219               exit
9220             endif
9221           enddo
9222         endif
9223       enddo
9224       return
9225       end
9226 c------------------------------------------------------------------------------
9227       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9228      &  n_corr1)
9229 C This subroutine calculates multi-body contributions to hydrogen-bonding
9230       implicit none
9231       include 'DIMENSIONS'
9232       include 'COMMON.IOUNITS'
9233 #ifdef MPI
9234       include "mpif.h"
9235       parameter (max_cont=maxconts)
9236       parameter (max_dim=70)
9237       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9238       double precision zapas(max_dim,maxconts,max_fg_procs),
9239      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9240       common /przechowalnia/ zapas
9241       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9242      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9243 #endif
9244       include 'COMMON.SETUP'
9245       include 'COMMON.FFIELD'
9246       include 'COMMON.DERIV'
9247       include 'COMMON.LOCAL'
9248       include 'COMMON.INTERACT'
9249       include 'COMMON.CONTACTS'
9250       include 'COMMON.CHAIN'
9251       include 'COMMON.CONTROL'
9252       include 'COMMON.SHIELD'
9253       double precision gx(3),gx1(3)
9254       integer num_cont_hb_old(maxres)
9255       logical lprn,ldone
9256       double precision eello4,eello5,eelo6,eello_turn6
9257       external eello4,eello5,eello6,eello_turn6
9258 C Set lprn=.true. for debugging
9259       lprn=.false.
9260       eturn6=0.0d0
9261 #ifdef MPI
9262       do i=1,nres
9263         num_cont_hb_old(i)=num_cont_hb(i)
9264       enddo
9265       n_corr=0
9266       n_corr1=0
9267       if (nfgtasks.le.1) goto 30
9268       if (lprn) then
9269         write (iout,'(a)') 'Contact function values before RECEIVE:'
9270         do i=nnt,nct-2
9271           write (iout,'(2i3,50(1x,i2,f5.2))')
9272      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9273      &    j=1,num_cont_hb(i))
9274         enddo
9275       endif
9276       do i=1,ntask_cont_from
9277         ncont_recv(i)=0
9278       enddo
9279       do i=1,ntask_cont_to
9280         ncont_sent(i)=0
9281       enddo
9282 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9283 c     & ntask_cont_to
9284 C Make the list of contacts to send to send to other procesors
9285       do i=iturn3_start,iturn3_end
9286 c        write (iout,*) "make contact list turn3",i," num_cont",
9287 c     &    num_cont_hb(i)
9288         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9289       enddo
9290       do i=iturn4_start,iturn4_end
9291 c        write (iout,*) "make contact list turn4",i," num_cont",
9292 c     &   num_cont_hb(i)
9293         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9294       enddo
9295       do ii=1,nat_sent
9296         i=iat_sent(ii)
9297 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9298 c     &    num_cont_hb(i)
9299         do j=1,num_cont_hb(i)
9300         do k=1,4
9301           jjc=jcont_hb(j,i)
9302           iproc=iint_sent_local(k,jjc,ii)
9303 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9304           if (iproc.ne.0) then
9305             ncont_sent(iproc)=ncont_sent(iproc)+1
9306             nn=ncont_sent(iproc)
9307             zapas(1,nn,iproc)=i
9308             zapas(2,nn,iproc)=jjc
9309             zapas(3,nn,iproc)=d_cont(j,i)
9310             ind=3
9311             do kk=1,3
9312               ind=ind+1
9313               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9314             enddo
9315             do kk=1,2
9316               do ll=1,2
9317                 ind=ind+1
9318                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9319               enddo
9320             enddo
9321             do jj=1,5
9322               do kk=1,3
9323                 do ll=1,2
9324                   do mm=1,2
9325                     ind=ind+1
9326                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9327                   enddo
9328                 enddo
9329               enddo
9330             enddo
9331           endif
9332         enddo
9333         enddo
9334       enddo
9335       if (lprn) then
9336       write (iout,*)
9337      &  "Numbers of contacts to be sent to other processors",
9338      &  (ncont_sent(i),i=1,ntask_cont_to)
9339       write (iout,*) "Contacts sent"
9340       do ii=1,ntask_cont_to
9341         nn=ncont_sent(ii)
9342         iproc=itask_cont_to(ii)
9343         write (iout,*) nn," contacts to processor",iproc,
9344      &   " of CONT_TO_COMM group"
9345         do i=1,nn
9346           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9347         enddo
9348       enddo
9349       call flush(iout)
9350       endif
9351       CorrelType=477
9352       CorrelID=fg_rank+1
9353       CorrelType1=478
9354       CorrelID1=nfgtasks+fg_rank+1
9355       ireq=0
9356 C Receive the numbers of needed contacts from other processors
9357       do ii=1,ntask_cont_from
9358         iproc=itask_cont_from(ii)
9359         ireq=ireq+1
9360         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9361      &    FG_COMM,req(ireq),IERR)
9362       enddo
9363 c      write (iout,*) "IRECV ended"
9364 c      call flush(iout)
9365 C Send the number of contacts needed by other processors
9366       do ii=1,ntask_cont_to
9367         iproc=itask_cont_to(ii)
9368         ireq=ireq+1
9369         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9370      &    FG_COMM,req(ireq),IERR)
9371       enddo
9372 c      write (iout,*) "ISEND ended"
9373 c      write (iout,*) "number of requests (nn)",ireq
9374 c      call flush(iout)
9375       if (ireq.gt.0)
9376      &  call MPI_Waitall(ireq,req,status_array,ierr)
9377 c      write (iout,*)
9378 c     &  "Numbers of contacts to be received from other processors",
9379 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9380 c      call flush(iout)
9381 C Receive contacts
9382       ireq=0
9383       do ii=1,ntask_cont_from
9384         iproc=itask_cont_from(ii)
9385         nn=ncont_recv(ii)
9386 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9387 c     &   " of CONT_TO_COMM group"
9388 c        call flush(iout)
9389         if (nn.gt.0) then
9390           ireq=ireq+1
9391           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9392      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9393 c          write (iout,*) "ireq,req",ireq,req(ireq)
9394         endif
9395       enddo
9396 C Send the contacts to processors that need them
9397       do ii=1,ntask_cont_to
9398         iproc=itask_cont_to(ii)
9399         nn=ncont_sent(ii)
9400 c        write (iout,*) nn," contacts to processor",iproc,
9401 c     &   " of CONT_TO_COMM group"
9402         if (nn.gt.0) then
9403           ireq=ireq+1
9404           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9405      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9406 c          write (iout,*) "ireq,req",ireq,req(ireq)
9407 c          do i=1,nn
9408 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9409 c          enddo
9410         endif
9411       enddo
9412 c      write (iout,*) "number of requests (contacts)",ireq
9413 c      write (iout,*) "req",(req(i),i=1,4)
9414 c      call flush(iout)
9415       if (ireq.gt.0)
9416      & call MPI_Waitall(ireq,req,status_array,ierr)
9417       do iii=1,ntask_cont_from
9418         iproc=itask_cont_from(iii)
9419         nn=ncont_recv(iii)
9420         if (lprn) then
9421         write (iout,*) "Received",nn," contacts from processor",iproc,
9422      &   " of CONT_FROM_COMM group"
9423         call flush(iout)
9424         do i=1,nn
9425           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9426         enddo
9427         call flush(iout)
9428         endif
9429         do i=1,nn
9430           ii=zapas_recv(1,i,iii)
9431 c Flag the received contacts to prevent double-counting
9432           jj=-zapas_recv(2,i,iii)
9433 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9434 c          call flush(iout)
9435           nnn=num_cont_hb(ii)+1
9436           num_cont_hb(ii)=nnn
9437           jcont_hb(nnn,ii)=jj
9438           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9439           ind=3
9440           do kk=1,3
9441             ind=ind+1
9442             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9443           enddo
9444           do kk=1,2
9445             do ll=1,2
9446               ind=ind+1
9447               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9448             enddo
9449           enddo
9450           do jj=1,5
9451             do kk=1,3
9452               do ll=1,2
9453                 do mm=1,2
9454                   ind=ind+1
9455                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9456                 enddo
9457               enddo
9458             enddo
9459           enddo
9460         enddo
9461       enddo
9462       if (lprn) then
9463         write (iout,'(a)') 'Contact function values after receive:'
9464         do i=nnt,nct-2
9465           write (iout,'(2i3,50(1x,i3,5f6.3))')
9466      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9467      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9468         enddo
9469         call flush(iout)
9470       endif
9471    30 continue
9472 #endif
9473       if (lprn) then
9474         write (iout,'(a)') 'Contact function values:'
9475         do i=nnt,nct-2
9476           write (iout,'(2i3,50(1x,i2,5f6.3))')
9477      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9478      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9479         enddo
9480       endif
9481       ecorr=0.0D0
9482       ecorr5=0.0d0
9483       ecorr6=0.0d0
9484 C Remove the loop below after debugging !!!
9485       do i=nnt,nct
9486         do j=1,3
9487           gradcorr(j,i)=0.0D0
9488           gradxorr(j,i)=0.0D0
9489         enddo
9490       enddo
9491 C Calculate the dipole-dipole interaction energies
9492       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9493       do i=iatel_s,iatel_e+1
9494         num_conti=num_cont_hb(i)
9495         do jj=1,num_conti
9496           j=jcont_hb(jj,i)
9497 #ifdef MOMENT
9498           call dipole(i,j,jj)
9499 #endif
9500         enddo
9501       enddo
9502       endif
9503 C Calculate the local-electrostatic correlation terms
9504 c                write (iout,*) "gradcorr5 in eello5 before loop"
9505 c                do iii=1,nres
9506 c                  write (iout,'(i5,3f10.5)')
9507 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9508 c                enddo
9509       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9510 c        write (iout,*) "corr loop i",i
9511         i1=i+1
9512         num_conti=num_cont_hb(i)
9513         num_conti1=num_cont_hb(i+1)
9514         do jj=1,num_conti
9515           j=jcont_hb(jj,i)
9516           jp=iabs(j)
9517           do kk=1,num_conti1
9518             j1=jcont_hb(kk,i1)
9519             jp1=iabs(j1)
9520 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9521 c     &         ' jj=',jj,' kk=',kk
9522 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9523             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9524      &          .or. j.lt.0 .and. j1.gt.0) .and.
9525      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9526 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9527 C The system gains extra energy.
9528               n_corr=n_corr+1
9529               sqd1=dsqrt(d_cont(jj,i))
9530               sqd2=dsqrt(d_cont(kk,i1))
9531               sred_geom = sqd1*sqd2
9532               IF (sred_geom.lt.cutoff_corr) THEN
9533                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9534      &            ekont,fprimcont)
9535 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9536 cd     &         ' jj=',jj,' kk=',kk
9537                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9538                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9539                 do l=1,3
9540                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9541                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9542                 enddo
9543                 n_corr1=n_corr1+1
9544 cd               write (iout,*) 'sred_geom=',sred_geom,
9545 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9546 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9547 cd               write (iout,*) "g_contij",g_contij
9548 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9549 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9550                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9551                 if (wcorr4.gt.0.0d0)
9552      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9553 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9554                   if (energy_dec.and.wcorr4.gt.0.0d0)
9555      1                 write (iout,'(a6,4i5,0pf7.3)')
9556      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9557 c                write (iout,*) "gradcorr5 before eello5"
9558 c                do iii=1,nres
9559 c                  write (iout,'(i5,3f10.5)')
9560 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9561 c                enddo
9562                 if (wcorr5.gt.0.0d0)
9563      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9564 c                write (iout,*) "gradcorr5 after eello5"
9565 c                do iii=1,nres
9566 c                  write (iout,'(i5,3f10.5)')
9567 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9568 c                enddo
9569                   if (energy_dec.and.wcorr5.gt.0.0d0)
9570      1                 write (iout,'(a6,4i5,0pf7.3)')
9571      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9572 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9573 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9574                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9575      &               .or. wturn6.eq.0.0d0))then
9576 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9577                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9578                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9579      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9580 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9581 cd     &            'ecorr6=',ecorr6
9582 cd                write (iout,'(4e15.5)') sred_geom,
9583 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9584 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9585 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9586                 else if (wturn6.gt.0.0d0
9587      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9588 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9589                   eturn6=eturn6+eello_turn6(i,jj,kk)
9590                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9591      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9592 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9593                 endif
9594               ENDIF
9595 1111          continue
9596             endif
9597           enddo ! kk
9598         enddo ! jj
9599       enddo ! i
9600       do i=1,nres
9601         num_cont_hb(i)=num_cont_hb_old(i)
9602       enddo
9603 c                write (iout,*) "gradcorr5 in eello5"
9604 c                do iii=1,nres
9605 c                  write (iout,'(i5,3f10.5)')
9606 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9607 c                enddo
9608       return
9609       end
9610 c------------------------------------------------------------------------------
9611       subroutine add_hb_contact_eello(ii,jj,itask)
9612       implicit none
9613       include "DIMENSIONS"
9614       include "COMMON.IOUNITS"
9615       integer max_cont
9616       integer max_dim
9617       parameter (max_cont=maxconts)
9618       parameter (max_dim=70)
9619       include "COMMON.CONTACTS"
9620       double precision zapas(max_dim,maxconts,max_fg_procs),
9621      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9622       common /przechowalnia/ zapas
9623       integer i,j,ii,jj,iproc,itask(4),nn
9624 c      write (iout,*) "itask",itask
9625       do i=1,2
9626         iproc=itask(i)
9627         if (iproc.gt.0) then
9628           do j=1,num_cont_hb(ii)
9629             jjc=jcont_hb(j,ii)
9630 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9631             if (jjc.eq.jj) then
9632               ncont_sent(iproc)=ncont_sent(iproc)+1
9633               nn=ncont_sent(iproc)
9634               zapas(1,nn,iproc)=ii
9635               zapas(2,nn,iproc)=jjc
9636               zapas(3,nn,iproc)=d_cont(j,ii)
9637               ind=3
9638               do kk=1,3
9639                 ind=ind+1
9640                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9641               enddo
9642               do kk=1,2
9643                 do ll=1,2
9644                   ind=ind+1
9645                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9646                 enddo
9647               enddo
9648               do jj=1,5
9649                 do kk=1,3
9650                   do ll=1,2
9651                     do mm=1,2
9652                       ind=ind+1
9653                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9654                     enddo
9655                   enddo
9656                 enddo
9657               enddo
9658               exit
9659             endif
9660           enddo
9661         endif
9662       enddo
9663       return
9664       end
9665 c------------------------------------------------------------------------------
9666       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9667       implicit none
9668       include 'DIMENSIONS'
9669       include 'COMMON.IOUNITS'
9670       include 'COMMON.DERIV'
9671       include 'COMMON.INTERACT'
9672       include 'COMMON.CONTACTS'
9673       include 'COMMON.SHIELD'
9674       include 'COMMON.CONTROL'
9675       double precision gx(3),gx1(3)
9676       logical lprn
9677       lprn=.false.
9678 C      print *,"wchodze",fac_shield(i),shield_mode
9679       eij=facont_hb(jj,i)
9680       ekl=facont_hb(kk,k)
9681       ees0pij=ees0p(jj,i)
9682       ees0pkl=ees0p(kk,k)
9683       ees0mij=ees0m(jj,i)
9684       ees0mkl=ees0m(kk,k)
9685       ekont=eij*ekl
9686       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9687 C*
9688 C     & fac_shield(i)**2*fac_shield(j)**2
9689 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9690 C Following 4 lines for diagnostics.
9691 cd    ees0pkl=0.0D0
9692 cd    ees0pij=1.0D0
9693 cd    ees0mkl=0.0D0
9694 cd    ees0mij=1.0D0
9695 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9696 c     & 'Contacts ',i,j,
9697 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9698 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9699 c     & 'gradcorr_long'
9700 C Calculate the multi-body contribution to energy.
9701 C      ecorr=ecorr+ekont*ees
9702 C Calculate multi-body contributions to the gradient.
9703       coeffpees0pij=coeffp*ees0pij
9704       coeffmees0mij=coeffm*ees0mij
9705       coeffpees0pkl=coeffp*ees0pkl
9706       coeffmees0mkl=coeffm*ees0mkl
9707       do ll=1,3
9708 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9709         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9710      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9711      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9712         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9713      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9714      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9715 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9716         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9717      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9718      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9719         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9720      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9721      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9722         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9723      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9724      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9725         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9726         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9727         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9728      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9729      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9730         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9731         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9732 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9733       enddo
9734 c      write (iout,*)
9735 cgrad      do m=i+1,j-1
9736 cgrad        do ll=1,3
9737 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9738 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9739 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9740 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9741 cgrad        enddo
9742 cgrad      enddo
9743 cgrad      do m=k+1,l-1
9744 cgrad        do ll=1,3
9745 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9746 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9747 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9748 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9749 cgrad        enddo
9750 cgrad      enddo
9751 c      write (iout,*) "ehbcorr",ekont*ees
9752 C      print *,ekont,ees,i,k
9753       ehbcorr=ekont*ees
9754 C now gradient over shielding
9755 C      return
9756       if (shield_mode.gt.0) then
9757        j=ees0plist(jj,i)
9758        l=ees0plist(kk,k)
9759 C        print *,i,j,fac_shield(i),fac_shield(j),
9760 C     &fac_shield(k),fac_shield(l)
9761         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9762      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9763           do ilist=1,ishield_list(i)
9764            iresshield=shield_list(ilist,i)
9765            do m=1,3
9766            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9767 C     &      *2.0
9768            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9769      &              rlocshield
9770      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9771             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9772      &+rlocshield
9773            enddo
9774           enddo
9775           do ilist=1,ishield_list(j)
9776            iresshield=shield_list(ilist,j)
9777            do m=1,3
9778            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9779 C     &     *2.0
9780            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9781      &              rlocshield
9782      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9783            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9784      &     +rlocshield
9785            enddo
9786           enddo
9787
9788           do ilist=1,ishield_list(k)
9789            iresshield=shield_list(ilist,k)
9790            do m=1,3
9791            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9792 C     &     *2.0
9793            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9794      &              rlocshield
9795      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9796            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9797      &     +rlocshield
9798            enddo
9799           enddo
9800           do ilist=1,ishield_list(l)
9801            iresshield=shield_list(ilist,l)
9802            do m=1,3
9803            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9804 C     &     *2.0
9805            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9806      &              rlocshield
9807      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9808            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9809      &     +rlocshield
9810            enddo
9811           enddo
9812 C          print *,gshieldx(m,iresshield)
9813           do m=1,3
9814             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9815      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9816             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9817      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9818             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9819      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9820             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9821      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9822
9823             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9824      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9825             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9826      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9827             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9828      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9829             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9830      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9831
9832            enddo
9833       endif
9834       endif
9835       return
9836       end
9837 #ifdef MOMENT
9838 C---------------------------------------------------------------------------
9839       subroutine dipole(i,j,jj)
9840       implicit real*8 (a-h,o-z)
9841       include 'DIMENSIONS'
9842       include 'COMMON.IOUNITS'
9843       include 'COMMON.CHAIN'
9844       include 'COMMON.FFIELD'
9845       include 'COMMON.DERIV'
9846       include 'COMMON.INTERACT'
9847       include 'COMMON.CONTACTS'
9848       include 'COMMON.TORSION'
9849       include 'COMMON.VAR'
9850       include 'COMMON.GEO'
9851       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9852      &  auxmat(2,2)
9853       iti1 = itortyp(itype(i+1))
9854       if (j.lt.nres-1) then
9855         itj1 = itype2loc(itype(j+1))
9856       else
9857         itj1=nloctyp
9858       endif
9859       do iii=1,2
9860         dipi(iii,1)=Ub2(iii,i)
9861         dipderi(iii)=Ub2der(iii,i)
9862         dipi(iii,2)=b1(iii,i+1)
9863         dipj(iii,1)=Ub2(iii,j)
9864         dipderj(iii)=Ub2der(iii,j)
9865         dipj(iii,2)=b1(iii,j+1)
9866       enddo
9867       kkk=0
9868       do iii=1,2
9869         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9870         do jjj=1,2
9871           kkk=kkk+1
9872           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9873         enddo
9874       enddo
9875       do kkk=1,5
9876         do lll=1,3
9877           mmm=0
9878           do iii=1,2
9879             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9880      &        auxvec(1))
9881             do jjj=1,2
9882               mmm=mmm+1
9883               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9884             enddo
9885           enddo
9886         enddo
9887       enddo
9888       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9889       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9890       do iii=1,2
9891         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9892       enddo
9893       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9894       do iii=1,2
9895         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9896       enddo
9897       return
9898       end
9899 #endif
9900 C---------------------------------------------------------------------------
9901       subroutine calc_eello(i,j,k,l,jj,kk)
9902 C
9903 C This subroutine computes matrices and vectors needed to calculate
9904 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9905 C
9906       implicit none
9907       include 'DIMENSIONS'
9908       include 'COMMON.IOUNITS'
9909       include 'COMMON.CHAIN'
9910       include 'COMMON.DERIV'
9911       include 'COMMON.INTERACT'
9912       include 'COMMON.CONTACTS'
9913       include 'COMMON.TORSION'
9914       include 'COMMON.VAR'
9915       include 'COMMON.GEO'
9916       include 'COMMON.FFIELD'
9917       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9918      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9919       logical lprn
9920       common /kutas/ lprn
9921 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9922 cd     & ' jj=',jj,' kk=',kk
9923 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9924 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9925 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9926       do iii=1,2
9927         do jjj=1,2
9928           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9929           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9930         enddo
9931       enddo
9932       call transpose2(aa1(1,1),aa1t(1,1))
9933       call transpose2(aa2(1,1),aa2t(1,1))
9934       do kkk=1,5
9935         do lll=1,3
9936           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9937      &      aa1tder(1,1,lll,kkk))
9938           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9939      &      aa2tder(1,1,lll,kkk))
9940         enddo
9941       enddo
9942       if (l.eq.j+1) then
9943 C parallel orientation of the two CA-CA-CA frames.
9944         if (i.gt.1) then
9945           iti=itype2loc(itype(i))
9946         else
9947           iti=nloctyp
9948         endif
9949         itk1=itype2loc(itype(k+1))
9950         itj=itype2loc(itype(j))
9951         if (l.lt.nres-1) then
9952           itl1=itype2loc(itype(l+1))
9953         else
9954           itl1=nloctyp
9955         endif
9956 C A1 kernel(j+1) A2T
9957 cd        do iii=1,2
9958 cd          write (iout,'(3f10.5,5x,3f10.5)')
9959 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9960 cd        enddo
9961         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9962      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9963      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9964 C Following matrices are needed only for 6-th order cumulants
9965         IF (wcorr6.gt.0.0d0) THEN
9966         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9967      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9968      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9969         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9970      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9971      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9972      &   ADtEAderx(1,1,1,1,1,1))
9973         lprn=.false.
9974         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9975      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9976      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9977      &   ADtEA1derx(1,1,1,1,1,1))
9978         ENDIF
9979 C End 6-th order cumulants
9980 cd        lprn=.false.
9981 cd        if (lprn) then
9982 cd        write (2,*) 'In calc_eello6'
9983 cd        do iii=1,2
9984 cd          write (2,*) 'iii=',iii
9985 cd          do kkk=1,5
9986 cd            write (2,*) 'kkk=',kkk
9987 cd            do jjj=1,2
9988 cd              write (2,'(3(2f10.5),5x)')
9989 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9990 cd            enddo
9991 cd          enddo
9992 cd        enddo
9993 cd        endif
9994         call transpose2(EUgder(1,1,k),auxmat(1,1))
9995         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9996         call transpose2(EUg(1,1,k),auxmat(1,1))
9997         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9998         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9999 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10000 c    in theta; to be sriten later.
10001 c#ifdef NEWCORR
10002 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
10003 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10004 c        call transpose2(EUg(1,1,k),auxmat(1,1))
10005 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10006 c#endif
10007         do iii=1,2
10008           do kkk=1,5
10009             do lll=1,3
10010               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10011      &          EAEAderx(1,1,lll,kkk,iii,1))
10012             enddo
10013           enddo
10014         enddo
10015 C A1T kernel(i+1) A2
10016         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10017      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10018      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10019 C Following matrices are needed only for 6-th order cumulants
10020         IF (wcorr6.gt.0.0d0) THEN
10021         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10022      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10023      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10024         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10025      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10026      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10027      &   ADtEAderx(1,1,1,1,1,2))
10028         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10029      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10030      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10031      &   ADtEA1derx(1,1,1,1,1,2))
10032         ENDIF
10033 C End 6-th order cumulants
10034         call transpose2(EUgder(1,1,l),auxmat(1,1))
10035         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10036         call transpose2(EUg(1,1,l),auxmat(1,1))
10037         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10038         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10039         do iii=1,2
10040           do kkk=1,5
10041             do lll=1,3
10042               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10043      &          EAEAderx(1,1,lll,kkk,iii,2))
10044             enddo
10045           enddo
10046         enddo
10047 C AEAb1 and AEAb2
10048 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10049 C They are needed only when the fifth- or the sixth-order cumulants are
10050 C indluded.
10051         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10052         call transpose2(AEA(1,1,1),auxmat(1,1))
10053         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10054         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10055         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10056         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10057         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10058         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10059         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10060         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10061         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10062         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10063         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10064         call transpose2(AEA(1,1,2),auxmat(1,1))
10065         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10066         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10067         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10068         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10069         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10070         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10071         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10072         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10073         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10074         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10075         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10076 C Calculate the Cartesian derivatives of the vectors.
10077         do iii=1,2
10078           do kkk=1,5
10079             do lll=1,3
10080               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10081               call matvec2(auxmat(1,1),b1(1,i),
10082      &          AEAb1derx(1,lll,kkk,iii,1,1))
10083               call matvec2(auxmat(1,1),Ub2(1,i),
10084      &          AEAb2derx(1,lll,kkk,iii,1,1))
10085               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10086      &          AEAb1derx(1,lll,kkk,iii,2,1))
10087               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10088      &          AEAb2derx(1,lll,kkk,iii,2,1))
10089               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10090               call matvec2(auxmat(1,1),b1(1,j),
10091      &          AEAb1derx(1,lll,kkk,iii,1,2))
10092               call matvec2(auxmat(1,1),Ub2(1,j),
10093      &          AEAb2derx(1,lll,kkk,iii,1,2))
10094               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10095      &          AEAb1derx(1,lll,kkk,iii,2,2))
10096               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10097      &          AEAb2derx(1,lll,kkk,iii,2,2))
10098             enddo
10099           enddo
10100         enddo
10101         ENDIF
10102 C End vectors
10103       else
10104 C Antiparallel orientation of the two CA-CA-CA frames.
10105         if (i.gt.1) then
10106           iti=itype2loc(itype(i))
10107         else
10108           iti=nloctyp
10109         endif
10110         itk1=itype2loc(itype(k+1))
10111         itl=itype2loc(itype(l))
10112         itj=itype2loc(itype(j))
10113         if (j.lt.nres-1) then
10114           itj1=itype2loc(itype(j+1))
10115         else
10116           itj1=nloctyp
10117         endif
10118 C A2 kernel(j-1)T A1T
10119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10120      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10121      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10122 C Following matrices are needed only for 6-th order cumulants
10123         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10124      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10125         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10126      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10127      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10128         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10129      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10130      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10131      &   ADtEAderx(1,1,1,1,1,1))
10132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10133      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10134      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10135      &   ADtEA1derx(1,1,1,1,1,1))
10136         ENDIF
10137 C End 6-th order cumulants
10138         call transpose2(EUgder(1,1,k),auxmat(1,1))
10139         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10140         call transpose2(EUg(1,1,k),auxmat(1,1))
10141         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10142         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10143         do iii=1,2
10144           do kkk=1,5
10145             do lll=1,3
10146               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10147      &          EAEAderx(1,1,lll,kkk,iii,1))
10148             enddo
10149           enddo
10150         enddo
10151 C A2T kernel(i+1)T A1
10152         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10153      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10154      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10155 C Following matrices are needed only for 6-th order cumulants
10156         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10157      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10158         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10159      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10160      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10161         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10162      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10163      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10164      &   ADtEAderx(1,1,1,1,1,2))
10165         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10166      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10167      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10168      &   ADtEA1derx(1,1,1,1,1,2))
10169         ENDIF
10170 C End 6-th order cumulants
10171         call transpose2(EUgder(1,1,j),auxmat(1,1))
10172         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10173         call transpose2(EUg(1,1,j),auxmat(1,1))
10174         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10175         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10176         do iii=1,2
10177           do kkk=1,5
10178             do lll=1,3
10179               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10180      &          EAEAderx(1,1,lll,kkk,iii,2))
10181             enddo
10182           enddo
10183         enddo
10184 C AEAb1 and AEAb2
10185 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10186 C They are needed only when the fifth- or the sixth-order cumulants are
10187 C indluded.
10188         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10189      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10190         call transpose2(AEA(1,1,1),auxmat(1,1))
10191         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10192         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10193         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10194         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10195         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10196         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10197         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10198         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10199         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10200         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10201         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10202         call transpose2(AEA(1,1,2),auxmat(1,1))
10203         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10204         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10205         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10206         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10207         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10208         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10209         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10210         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10211         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10212         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10213         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10214 C Calculate the Cartesian derivatives of the vectors.
10215         do iii=1,2
10216           do kkk=1,5
10217             do lll=1,3
10218               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10219               call matvec2(auxmat(1,1),b1(1,i),
10220      &          AEAb1derx(1,lll,kkk,iii,1,1))
10221               call matvec2(auxmat(1,1),Ub2(1,i),
10222      &          AEAb2derx(1,lll,kkk,iii,1,1))
10223               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10224      &          AEAb1derx(1,lll,kkk,iii,2,1))
10225               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10226      &          AEAb2derx(1,lll,kkk,iii,2,1))
10227               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10228               call matvec2(auxmat(1,1),b1(1,l),
10229      &          AEAb1derx(1,lll,kkk,iii,1,2))
10230               call matvec2(auxmat(1,1),Ub2(1,l),
10231      &          AEAb2derx(1,lll,kkk,iii,1,2))
10232               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10233      &          AEAb1derx(1,lll,kkk,iii,2,2))
10234               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10235      &          AEAb2derx(1,lll,kkk,iii,2,2))
10236             enddo
10237           enddo
10238         enddo
10239         ENDIF
10240 C End vectors
10241       endif
10242       return
10243       end
10244 C---------------------------------------------------------------------------
10245       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10246      &  KK,KKderg,AKA,AKAderg,AKAderx)
10247       implicit none
10248       integer nderg
10249       logical transp
10250       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10251      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10252      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10253       integer iii,kkk,lll
10254       integer jjj,mmm
10255       logical lprn
10256       common /kutas/ lprn
10257       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10258       do iii=1,nderg
10259         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10260      &    AKAderg(1,1,iii))
10261       enddo
10262 cd      if (lprn) write (2,*) 'In kernel'
10263       do kkk=1,5
10264 cd        if (lprn) write (2,*) 'kkk=',kkk
10265         do lll=1,3
10266           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10267      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10268 cd          if (lprn) then
10269 cd            write (2,*) 'lll=',lll
10270 cd            write (2,*) 'iii=1'
10271 cd            do jjj=1,2
10272 cd              write (2,'(3(2f10.5),5x)')
10273 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10274 cd            enddo
10275 cd          endif
10276           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10277      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10278 cd          if (lprn) then
10279 cd            write (2,*) 'lll=',lll
10280 cd            write (2,*) 'iii=2'
10281 cd            do jjj=1,2
10282 cd              write (2,'(3(2f10.5),5x)')
10283 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10284 cd            enddo
10285 cd          endif
10286         enddo
10287       enddo
10288       return
10289       end
10290 C---------------------------------------------------------------------------
10291       double precision function eello4(i,j,k,l,jj,kk)
10292       implicit none
10293       include 'DIMENSIONS'
10294       include 'COMMON.IOUNITS'
10295       include 'COMMON.CHAIN'
10296       include 'COMMON.DERIV'
10297       include 'COMMON.INTERACT'
10298       include 'COMMON.CONTACTS'
10299       include 'COMMON.TORSION'
10300       include 'COMMON.VAR'
10301       include 'COMMON.GEO'
10302       double precision pizda(2,2),ggg1(3),ggg2(3)
10303 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10304 cd        eello4=0.0d0
10305 cd        return
10306 cd      endif
10307 cd      print *,'eello4:',i,j,k,l,jj,kk
10308 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10309 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10310 cold      eij=facont_hb(jj,i)
10311 cold      ekl=facont_hb(kk,k)
10312 cold      ekont=eij*ekl
10313       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10314 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10315       gcorr_loc(k-1)=gcorr_loc(k-1)
10316      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10317       if (l.eq.j+1) then
10318         gcorr_loc(l-1)=gcorr_loc(l-1)
10319      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10320 C Al 4/16/16: Derivatives in theta, to be added later.
10321 c#ifdef NEWCORR
10322 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10323 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10324 c#endif
10325       else
10326         gcorr_loc(j-1)=gcorr_loc(j-1)
10327      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10328 c#ifdef NEWCORR
10329 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10330 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10331 c#endif
10332       endif
10333       do iii=1,2
10334         do kkk=1,5
10335           do lll=1,3
10336             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10337      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10338 cd            derx(lll,kkk,iii)=0.0d0
10339           enddo
10340         enddo
10341       enddo
10342 cd      gcorr_loc(l-1)=0.0d0
10343 cd      gcorr_loc(j-1)=0.0d0
10344 cd      gcorr_loc(k-1)=0.0d0
10345 cd      eel4=1.0d0
10346 cd      write (iout,*)'Contacts have occurred for peptide groups',
10347 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10348 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10349       if (j.lt.nres-1) then
10350         j1=j+1
10351         j2=j-1
10352       else
10353         j1=j-1
10354         j2=j-2
10355       endif
10356       if (l.lt.nres-1) then
10357         l1=l+1
10358         l2=l-1
10359       else
10360         l1=l-1
10361         l2=l-2
10362       endif
10363       do ll=1,3
10364 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10365 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10366         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10367         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10368 cgrad        ghalf=0.5d0*ggg1(ll)
10369         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10370         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10371         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10372         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10373         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10374         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10375 cgrad        ghalf=0.5d0*ggg2(ll)
10376         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10377         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10378         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10379         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10380         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10381         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10382       enddo
10383 cgrad      do m=i+1,j-1
10384 cgrad        do ll=1,3
10385 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10386 cgrad        enddo
10387 cgrad      enddo
10388 cgrad      do m=k+1,l-1
10389 cgrad        do ll=1,3
10390 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10391 cgrad        enddo
10392 cgrad      enddo
10393 cgrad      do m=i+2,j2
10394 cgrad        do ll=1,3
10395 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10396 cgrad        enddo
10397 cgrad      enddo
10398 cgrad      do m=k+2,l2
10399 cgrad        do ll=1,3
10400 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10401 cgrad        enddo
10402 cgrad      enddo
10403 cd      do iii=1,nres-3
10404 cd        write (2,*) iii,gcorr_loc(iii)
10405 cd      enddo
10406       eello4=ekont*eel4
10407 cd      write (2,*) 'ekont',ekont
10408 cd      write (iout,*) 'eello4',ekont*eel4
10409       return
10410       end
10411 C---------------------------------------------------------------------------
10412       double precision function eello5(i,j,k,l,jj,kk)
10413       implicit real*8 (a-h,o-z)
10414       include 'DIMENSIONS'
10415       include 'COMMON.IOUNITS'
10416       include 'COMMON.CHAIN'
10417       include 'COMMON.DERIV'
10418       include 'COMMON.INTERACT'
10419       include 'COMMON.CONTACTS'
10420       include 'COMMON.TORSION'
10421       include 'COMMON.VAR'
10422       include 'COMMON.GEO'
10423       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10424       double precision ggg1(3),ggg2(3)
10425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10426 C                                                                              C
10427 C                            Parallel chains                                   C
10428 C                                                                              C
10429 C          o             o                   o             o                   C
10430 C         /l\           / \             \   / \           / \   /              C
10431 C        /   \         /   \             \ /   \         /   \ /               C
10432 C       j| o |l1       | o |              o| o |         | o |o                C
10433 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10434 C      \i/   \         /   \ /             /   \         /   \                 C
10435 C       o    k1             o                                                  C
10436 C         (I)          (II)                (III)          (IV)                 C
10437 C                                                                              C
10438 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10439 C                                                                              C
10440 C                            Antiparallel chains                               C
10441 C                                                                              C
10442 C          o             o                   o             o                   C
10443 C         /j\           / \             \   / \           / \   /              C
10444 C        /   \         /   \             \ /   \         /   \ /               C
10445 C      j1| o |l        | o |              o| o |         | o |o                C
10446 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10447 C      \i/   \         /   \ /             /   \         /   \                 C
10448 C       o     k1            o                                                  C
10449 C         (I)          (II)                (III)          (IV)                 C
10450 C                                                                              C
10451 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10452 C                                                                              C
10453 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10454 C                                                                              C
10455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10456 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10457 cd        eello5=0.0d0
10458 cd        return
10459 cd      endif
10460 cd      write (iout,*)
10461 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10462 cd     &   ' and',k,l
10463       itk=itype2loc(itype(k))
10464       itl=itype2loc(itype(l))
10465       itj=itype2loc(itype(j))
10466       eello5_1=0.0d0
10467       eello5_2=0.0d0
10468       eello5_3=0.0d0
10469       eello5_4=0.0d0
10470 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10471 cd     &   eel5_3_num,eel5_4_num)
10472       do iii=1,2
10473         do kkk=1,5
10474           do lll=1,3
10475             derx(lll,kkk,iii)=0.0d0
10476           enddo
10477         enddo
10478       enddo
10479 cd      eij=facont_hb(jj,i)
10480 cd      ekl=facont_hb(kk,k)
10481 cd      ekont=eij*ekl
10482 cd      write (iout,*)'Contacts have occurred for peptide groups',
10483 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10484 cd      goto 1111
10485 C Contribution from the graph I.
10486 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10487 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10488       call transpose2(EUg(1,1,k),auxmat(1,1))
10489       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10490       vv(1)=pizda(1,1)-pizda(2,2)
10491       vv(2)=pizda(1,2)+pizda(2,1)
10492       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10493      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10494 C Explicit gradient in virtual-dihedral angles.
10495       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10496      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10497      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10498       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10499       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10500       vv(1)=pizda(1,1)-pizda(2,2)
10501       vv(2)=pizda(1,2)+pizda(2,1)
10502       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10503      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10504      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10505       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10506       vv(1)=pizda(1,1)-pizda(2,2)
10507       vv(2)=pizda(1,2)+pizda(2,1)
10508       if (l.eq.j+1) then
10509         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10510      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10511      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10512       else
10513         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10514      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10515      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10516       endif
10517 C Cartesian gradient
10518       do iii=1,2
10519         do kkk=1,5
10520           do lll=1,3
10521             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10522      &        pizda(1,1))
10523             vv(1)=pizda(1,1)-pizda(2,2)
10524             vv(2)=pizda(1,2)+pizda(2,1)
10525             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10526      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10527      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10528           enddo
10529         enddo
10530       enddo
10531 c      goto 1112
10532 c1111  continue
10533 C Contribution from graph II
10534       call transpose2(EE(1,1,k),auxmat(1,1))
10535       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10536       vv(1)=pizda(1,1)+pizda(2,2)
10537       vv(2)=pizda(2,1)-pizda(1,2)
10538       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10539      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10540 C Explicit gradient in virtual-dihedral angles.
10541       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10542      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10543       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10544       vv(1)=pizda(1,1)+pizda(2,2)
10545       vv(2)=pizda(2,1)-pizda(1,2)
10546       if (l.eq.j+1) then
10547         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10548      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10549      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10550       else
10551         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10552      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10553      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10554       endif
10555 C Cartesian gradient
10556       do iii=1,2
10557         do kkk=1,5
10558           do lll=1,3
10559             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10560      &        pizda(1,1))
10561             vv(1)=pizda(1,1)+pizda(2,2)
10562             vv(2)=pizda(2,1)-pizda(1,2)
10563             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10564      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10565      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10566           enddo
10567         enddo
10568       enddo
10569 cd      goto 1112
10570 cd1111  continue
10571       if (l.eq.j+1) then
10572 cd        goto 1110
10573 C Parallel orientation
10574 C Contribution from graph III
10575         call transpose2(EUg(1,1,l),auxmat(1,1))
10576         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10577         vv(1)=pizda(1,1)-pizda(2,2)
10578         vv(2)=pizda(1,2)+pizda(2,1)
10579         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10580      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10581 C Explicit gradient in virtual-dihedral angles.
10582         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10583      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10584      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10585         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10586         vv(1)=pizda(1,1)-pizda(2,2)
10587         vv(2)=pizda(1,2)+pizda(2,1)
10588         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10589      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10591         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10592         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10593         vv(1)=pizda(1,1)-pizda(2,2)
10594         vv(2)=pizda(1,2)+pizda(2,1)
10595         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10596      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10597      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10598 C Cartesian gradient
10599         do iii=1,2
10600           do kkk=1,5
10601             do lll=1,3
10602               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10603      &          pizda(1,1))
10604               vv(1)=pizda(1,1)-pizda(2,2)
10605               vv(2)=pizda(1,2)+pizda(2,1)
10606               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10607      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10608      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10609             enddo
10610           enddo
10611         enddo
10612 cd        goto 1112
10613 C Contribution from graph IV
10614 cd1110    continue
10615         call transpose2(EE(1,1,l),auxmat(1,1))
10616         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10617         vv(1)=pizda(1,1)+pizda(2,2)
10618         vv(2)=pizda(2,1)-pizda(1,2)
10619         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10620      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10621 C Explicit gradient in virtual-dihedral angles.
10622         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10623      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10624         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10625         vv(1)=pizda(1,1)+pizda(2,2)
10626         vv(2)=pizda(2,1)-pizda(1,2)
10627         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10628      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10629      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10630 C Cartesian gradient
10631         do iii=1,2
10632           do kkk=1,5
10633             do lll=1,3
10634               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10635      &          pizda(1,1))
10636               vv(1)=pizda(1,1)+pizda(2,2)
10637               vv(2)=pizda(2,1)-pizda(1,2)
10638               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10639      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10640      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10641             enddo
10642           enddo
10643         enddo
10644       else
10645 C Antiparallel orientation
10646 C Contribution from graph III
10647 c        goto 1110
10648         call transpose2(EUg(1,1,j),auxmat(1,1))
10649         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10650         vv(1)=pizda(1,1)-pizda(2,2)
10651         vv(2)=pizda(1,2)+pizda(2,1)
10652         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10653      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10654 C Explicit gradient in virtual-dihedral angles.
10655         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10656      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10657      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10658         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10659         vv(1)=pizda(1,1)-pizda(2,2)
10660         vv(2)=pizda(1,2)+pizda(2,1)
10661         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10662      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10663      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10664         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10665         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10666         vv(1)=pizda(1,1)-pizda(2,2)
10667         vv(2)=pizda(1,2)+pizda(2,1)
10668         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10669      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10670      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10671 C Cartesian gradient
10672         do iii=1,2
10673           do kkk=1,5
10674             do lll=1,3
10675               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10676      &          pizda(1,1))
10677               vv(1)=pizda(1,1)-pizda(2,2)
10678               vv(2)=pizda(1,2)+pizda(2,1)
10679               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10680      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10681      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10682             enddo
10683           enddo
10684         enddo
10685 cd        goto 1112
10686 C Contribution from graph IV
10687 1110    continue
10688         call transpose2(EE(1,1,j),auxmat(1,1))
10689         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10690         vv(1)=pizda(1,1)+pizda(2,2)
10691         vv(2)=pizda(2,1)-pizda(1,2)
10692         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10693      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10694 C Explicit gradient in virtual-dihedral angles.
10695         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10696      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10697         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10698         vv(1)=pizda(1,1)+pizda(2,2)
10699         vv(2)=pizda(2,1)-pizda(1,2)
10700         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10701      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10702      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10703 C Cartesian gradient
10704         do iii=1,2
10705           do kkk=1,5
10706             do lll=1,3
10707               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10708      &          pizda(1,1))
10709               vv(1)=pizda(1,1)+pizda(2,2)
10710               vv(2)=pizda(2,1)-pizda(1,2)
10711               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10712      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10713      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10714             enddo
10715           enddo
10716         enddo
10717       endif
10718 1112  continue
10719       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10720 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10721 cd        write (2,*) 'ijkl',i,j,k,l
10722 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10723 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10724 cd      endif
10725 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10726 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10727 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10728 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10729       if (j.lt.nres-1) then
10730         j1=j+1
10731         j2=j-1
10732       else
10733         j1=j-1
10734         j2=j-2
10735       endif
10736       if (l.lt.nres-1) then
10737         l1=l+1
10738         l2=l-1
10739       else
10740         l1=l-1
10741         l2=l-2
10742       endif
10743 cd      eij=1.0d0
10744 cd      ekl=1.0d0
10745 cd      ekont=1.0d0
10746 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10747 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10748 C        summed up outside the subrouine as for the other subroutines
10749 C        handling long-range interactions. The old code is commented out
10750 C        with "cgrad" to keep track of changes.
10751       do ll=1,3
10752 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10753 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10754         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10755         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10756 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10757 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10758 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10759 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10760 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10761 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10762 c     &   gradcorr5ij,
10763 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10764 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10765 cgrad        ghalf=0.5d0*ggg1(ll)
10766 cd        ghalf=0.0d0
10767         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10768         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10769         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10770         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10771         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10772         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10773 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10774 cgrad        ghalf=0.5d0*ggg2(ll)
10775 cd        ghalf=0.0d0
10776         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10777         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10778         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10779         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10780         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10781         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10782       enddo
10783 cd      goto 1112
10784 cgrad      do m=i+1,j-1
10785 cgrad        do ll=1,3
10786 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10787 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10788 cgrad        enddo
10789 cgrad      enddo
10790 cgrad      do m=k+1,l-1
10791 cgrad        do ll=1,3
10792 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10793 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10794 cgrad        enddo
10795 cgrad      enddo
10796 c1112  continue
10797 cgrad      do m=i+2,j2
10798 cgrad        do ll=1,3
10799 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10800 cgrad        enddo
10801 cgrad      enddo
10802 cgrad      do m=k+2,l2
10803 cgrad        do ll=1,3
10804 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10805 cgrad        enddo
10806 cgrad      enddo
10807 cd      do iii=1,nres-3
10808 cd        write (2,*) iii,g_corr5_loc(iii)
10809 cd      enddo
10810       eello5=ekont*eel5
10811 cd      write (2,*) 'ekont',ekont
10812 cd      write (iout,*) 'eello5',ekont*eel5
10813       return
10814       end
10815 c--------------------------------------------------------------------------
10816       double precision function eello6(i,j,k,l,jj,kk)
10817       implicit real*8 (a-h,o-z)
10818       include 'DIMENSIONS'
10819       include 'COMMON.IOUNITS'
10820       include 'COMMON.CHAIN'
10821       include 'COMMON.DERIV'
10822       include 'COMMON.INTERACT'
10823       include 'COMMON.CONTACTS'
10824       include 'COMMON.TORSION'
10825       include 'COMMON.VAR'
10826       include 'COMMON.GEO'
10827       include 'COMMON.FFIELD'
10828       double precision ggg1(3),ggg2(3)
10829 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10830 cd        eello6=0.0d0
10831 cd        return
10832 cd      endif
10833 cd      write (iout,*)
10834 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10835 cd     &   ' and',k,l
10836       eello6_1=0.0d0
10837       eello6_2=0.0d0
10838       eello6_3=0.0d0
10839       eello6_4=0.0d0
10840       eello6_5=0.0d0
10841       eello6_6=0.0d0
10842 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10843 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10844       do iii=1,2
10845         do kkk=1,5
10846           do lll=1,3
10847             derx(lll,kkk,iii)=0.0d0
10848           enddo
10849         enddo
10850       enddo
10851 cd      eij=facont_hb(jj,i)
10852 cd      ekl=facont_hb(kk,k)
10853 cd      ekont=eij*ekl
10854 cd      eij=1.0d0
10855 cd      ekl=1.0d0
10856 cd      ekont=1.0d0
10857       if (l.eq.j+1) then
10858         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10859         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10860         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10861         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10862         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10863         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10864       else
10865         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10866         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10867         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10868         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10869         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10870           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10871         else
10872           eello6_5=0.0d0
10873         endif
10874         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10875       endif
10876 C If turn contributions are considered, they will be handled separately.
10877       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10878 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10879 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10880 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10881 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10882 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10883 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10884 cd      goto 1112
10885       if (j.lt.nres-1) then
10886         j1=j+1
10887         j2=j-1
10888       else
10889         j1=j-1
10890         j2=j-2
10891       endif
10892       if (l.lt.nres-1) then
10893         l1=l+1
10894         l2=l-1
10895       else
10896         l1=l-1
10897         l2=l-2
10898       endif
10899       do ll=1,3
10900 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10901 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10902 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10903 cgrad        ghalf=0.5d0*ggg1(ll)
10904 cd        ghalf=0.0d0
10905         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10906         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10907         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10908         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10909         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10910         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10911         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10912         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10913 cgrad        ghalf=0.5d0*ggg2(ll)
10914 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10915 cd        ghalf=0.0d0
10916         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10917         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10918         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10919         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10920         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10921         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10922       enddo
10923 cd      goto 1112
10924 cgrad      do m=i+1,j-1
10925 cgrad        do ll=1,3
10926 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10927 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10928 cgrad        enddo
10929 cgrad      enddo
10930 cgrad      do m=k+1,l-1
10931 cgrad        do ll=1,3
10932 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10933 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10934 cgrad        enddo
10935 cgrad      enddo
10936 cgrad1112  continue
10937 cgrad      do m=i+2,j2
10938 cgrad        do ll=1,3
10939 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10940 cgrad        enddo
10941 cgrad      enddo
10942 cgrad      do m=k+2,l2
10943 cgrad        do ll=1,3
10944 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10945 cgrad        enddo
10946 cgrad      enddo
10947 cd      do iii=1,nres-3
10948 cd        write (2,*) iii,g_corr6_loc(iii)
10949 cd      enddo
10950       eello6=ekont*eel6
10951 cd      write (2,*) 'ekont',ekont
10952 cd      write (iout,*) 'eello6',ekont*eel6
10953       return
10954       end
10955 c--------------------------------------------------------------------------
10956       double precision function eello6_graph1(i,j,k,l,imat,swap)
10957       implicit real*8 (a-h,o-z)
10958       include 'DIMENSIONS'
10959       include 'COMMON.IOUNITS'
10960       include 'COMMON.CHAIN'
10961       include 'COMMON.DERIV'
10962       include 'COMMON.INTERACT'
10963       include 'COMMON.CONTACTS'
10964       include 'COMMON.TORSION'
10965       include 'COMMON.VAR'
10966       include 'COMMON.GEO'
10967       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10968       logical swap
10969       logical lprn
10970       common /kutas/ lprn
10971 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10972 C                                                                              C
10973 C      Parallel       Antiparallel                                             C
10974 C                                                                              C
10975 C          o             o                                                     C
10976 C         /l\           /j\                                                    C
10977 C        /   \         /   \                                                   C
10978 C       /| o |         | o |\                                                  C
10979 C     \ j|/k\|  /   \  |/k\|l /                                                C
10980 C      \ /   \ /     \ /   \ /                                                 C
10981 C       o     o       o     o                                                  C
10982 C       i             i                                                        C
10983 C                                                                              C
10984 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10985       itk=itype2loc(itype(k))
10986       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10987       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10988       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10989       call transpose2(EUgC(1,1,k),auxmat(1,1))
10990       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10991       vv1(1)=pizda1(1,1)-pizda1(2,2)
10992       vv1(2)=pizda1(1,2)+pizda1(2,1)
10993       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10994       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10995       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10996       s5=scalar2(vv(1),Dtobr2(1,i))
10997 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10998       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10999       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11000      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11001      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11002      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11003      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11004      & +scalar2(vv(1),Dtobr2der(1,i)))
11005       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11006       vv1(1)=pizda1(1,1)-pizda1(2,2)
11007       vv1(2)=pizda1(1,2)+pizda1(2,1)
11008       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11009       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11010       if (l.eq.j+1) then
11011         g_corr6_loc(l-1)=g_corr6_loc(l-1)
11012      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11013      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11014      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11015      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11016       else
11017         g_corr6_loc(j-1)=g_corr6_loc(j-1)
11018      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11019      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11020      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11021      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11022       endif
11023       call transpose2(EUgCder(1,1,k),auxmat(1,1))
11024       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11025       vv1(1)=pizda1(1,1)-pizda1(2,2)
11026       vv1(2)=pizda1(1,2)+pizda1(2,1)
11027       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11028      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11029      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11030      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11031       do iii=1,2
11032         if (swap) then
11033           ind=3-iii
11034         else
11035           ind=iii
11036         endif
11037         do kkk=1,5
11038           do lll=1,3
11039             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11040             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11041             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11042             call transpose2(EUgC(1,1,k),auxmat(1,1))
11043             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11044      &        pizda1(1,1))
11045             vv1(1)=pizda1(1,1)-pizda1(2,2)
11046             vv1(2)=pizda1(1,2)+pizda1(2,1)
11047             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11048             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11049      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11050             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11051      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11052             s5=scalar2(vv(1),Dtobr2(1,i))
11053             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11054           enddo
11055         enddo
11056       enddo
11057       return
11058       end
11059 c----------------------------------------------------------------------------
11060       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11061       implicit real*8 (a-h,o-z)
11062       include 'DIMENSIONS'
11063       include 'COMMON.IOUNITS'
11064       include 'COMMON.CHAIN'
11065       include 'COMMON.DERIV'
11066       include 'COMMON.INTERACT'
11067       include 'COMMON.CONTACTS'
11068       include 'COMMON.TORSION'
11069       include 'COMMON.VAR'
11070       include 'COMMON.GEO'
11071       logical swap
11072       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11073      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11074       logical lprn
11075       common /kutas/ lprn
11076 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11077 C                                                                              C
11078 C      Parallel       Antiparallel                                             C
11079 C                                                                              C
11080 C          o             o                                                     C
11081 C     \   /l\           /j\   /                                                C
11082 C      \ /   \         /   \ /                                                 C
11083 C       o| o |         | o |o                                                  C
11084 C     \ j|/k\|      \  |/k\|l                                                  C
11085 C      \ /   \       \ /   \                                                   C
11086 C       o             o                                                        C
11087 C       i             i                                                        C
11088 C                                                                              C
11089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11090 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11091 C AL 7/4/01 s1 would occur in the sixth-order moment,
11092 C           but not in a cluster cumulant
11093 #ifdef MOMENT
11094       s1=dip(1,jj,i)*dip(1,kk,k)
11095 #endif
11096       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11097       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11098       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11099       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11100       call transpose2(EUg(1,1,k),auxmat(1,1))
11101       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11102       vv(1)=pizda(1,1)-pizda(2,2)
11103       vv(2)=pizda(1,2)+pizda(2,1)
11104       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11105 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11106 #ifdef MOMENT
11107       eello6_graph2=-(s1+s2+s3+s4)
11108 #else
11109       eello6_graph2=-(s2+s3+s4)
11110 #endif
11111 c      eello6_graph2=-s3
11112 C Derivatives in gamma(i-1)
11113       if (i.gt.1) then
11114 #ifdef MOMENT
11115         s1=dipderg(1,jj,i)*dip(1,kk,k)
11116 #endif
11117         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11118         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11119         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11120         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11121 #ifdef MOMENT
11122         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11123 #else
11124         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11125 #endif
11126 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11127       endif
11128 C Derivatives in gamma(k-1)
11129 #ifdef MOMENT
11130       s1=dip(1,jj,i)*dipderg(1,kk,k)
11131 #endif
11132       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11133       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11134       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11135       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11136       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11137       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11138       vv(1)=pizda(1,1)-pizda(2,2)
11139       vv(2)=pizda(1,2)+pizda(2,1)
11140       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11141 #ifdef MOMENT
11142       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11143 #else
11144       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11145 #endif
11146 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11147 C Derivatives in gamma(j-1) or gamma(l-1)
11148       if (j.gt.1) then
11149 #ifdef MOMENT
11150         s1=dipderg(3,jj,i)*dip(1,kk,k)
11151 #endif
11152         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11153         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11154         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11155         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11156         vv(1)=pizda(1,1)-pizda(2,2)
11157         vv(2)=pizda(1,2)+pizda(2,1)
11158         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11159 #ifdef MOMENT
11160         if (swap) then
11161           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11162         else
11163           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11164         endif
11165 #endif
11166         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11167 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11168       endif
11169 C Derivatives in gamma(l-1) or gamma(j-1)
11170       if (l.gt.1) then
11171 #ifdef MOMENT
11172         s1=dip(1,jj,i)*dipderg(3,kk,k)
11173 #endif
11174         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11175         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11176         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11177         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11178         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11179         vv(1)=pizda(1,1)-pizda(2,2)
11180         vv(2)=pizda(1,2)+pizda(2,1)
11181         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11182 #ifdef MOMENT
11183         if (swap) then
11184           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11185         else
11186           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11187         endif
11188 #endif
11189         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11190 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11191       endif
11192 C Cartesian derivatives.
11193       if (lprn) then
11194         write (2,*) 'In eello6_graph2'
11195         do iii=1,2
11196           write (2,*) 'iii=',iii
11197           do kkk=1,5
11198             write (2,*) 'kkk=',kkk
11199             do jjj=1,2
11200               write (2,'(3(2f10.5),5x)')
11201      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11202             enddo
11203           enddo
11204         enddo
11205       endif
11206       do iii=1,2
11207         do kkk=1,5
11208           do lll=1,3
11209 #ifdef MOMENT
11210             if (iii.eq.1) then
11211               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11212             else
11213               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11214             endif
11215 #endif
11216             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11217             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11218      &        auxvec(1))
11219             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11220             call transpose2(EUg(1,1,k),auxmat(1,1))
11221             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11222      &        pizda(1,1))
11223             vv(1)=pizda(1,1)-pizda(2,2)
11224             vv(2)=pizda(1,2)+pizda(2,1)
11225             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11226 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11227 #ifdef MOMENT
11228             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11229 #else
11230             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11231 #endif
11232             if (swap) then
11233               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11234             else
11235               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11236             endif
11237           enddo
11238         enddo
11239       enddo
11240       return
11241       end
11242 c----------------------------------------------------------------------------
11243       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11244       implicit real*8 (a-h,o-z)
11245       include 'DIMENSIONS'
11246       include 'COMMON.IOUNITS'
11247       include 'COMMON.CHAIN'
11248       include 'COMMON.DERIV'
11249       include 'COMMON.INTERACT'
11250       include 'COMMON.CONTACTS'
11251       include 'COMMON.TORSION'
11252       include 'COMMON.VAR'
11253       include 'COMMON.GEO'
11254       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11255       logical swap
11256 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11257 C                                                                              C
11258 C      Parallel       Antiparallel                                             C
11259 C                                                                              C
11260 C          o             o                                                     C
11261 C         /l\   /   \   /j\                                                    C
11262 C        /   \ /     \ /   \                                                   C
11263 C       /| o |o       o| o |\                                                  C
11264 C       j|/k\|  /      |/k\|l /                                                C
11265 C        /   \ /       /   \ /                                                 C
11266 C       /     o       /     o                                                  C
11267 C       i             i                                                        C
11268 C                                                                              C
11269 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11270 C
11271 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11272 C           energy moment and not to the cluster cumulant.
11273       iti=itortyp(itype(i))
11274       if (j.lt.nres-1) then
11275         itj1=itype2loc(itype(j+1))
11276       else
11277         itj1=nloctyp
11278       endif
11279       itk=itype2loc(itype(k))
11280       itk1=itype2loc(itype(k+1))
11281       if (l.lt.nres-1) then
11282         itl1=itype2loc(itype(l+1))
11283       else
11284         itl1=nloctyp
11285       endif
11286 #ifdef MOMENT
11287       s1=dip(4,jj,i)*dip(4,kk,k)
11288 #endif
11289       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11290       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11291       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11292       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11293       call transpose2(EE(1,1,k),auxmat(1,1))
11294       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11295       vv(1)=pizda(1,1)+pizda(2,2)
11296       vv(2)=pizda(2,1)-pizda(1,2)
11297       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11298 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11299 cd     & "sum",-(s2+s3+s4)
11300 #ifdef MOMENT
11301       eello6_graph3=-(s1+s2+s3+s4)
11302 #else
11303       eello6_graph3=-(s2+s3+s4)
11304 #endif
11305             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11306             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11307      &        auxvec(1))
11308             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11309             call transpose2(EUg(1,1,k),auxmat(1,1))
11310             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11311      &        pizda(1,1))
11312             vv(1)=pizda(1,1)-pizda(2,2)
11313             vv(2)=pizda(1,2)+pizda(2,1)
11314             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11315 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11316 #ifdef MOMENT
11317             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11318 #else
11319             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11320 #endif
11321             if (swap) then
11322               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11323             else
11324               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11325             endif
11326           enddo
11327         enddo
11328       enddo
11329       return
11330       end
11331 c----------------------------------------------------------------------------
11332       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11333       implicit real*8 (a-h,o-z)
11334       include 'DIMENSIONS'
11335       include 'COMMON.IOUNITS'
11336       include 'COMMON.CHAIN'
11337       include 'COMMON.DERIV'
11338       include 'COMMON.INTERACT'
11339       include 'COMMON.CONTACTS'
11340       include 'COMMON.TORSION'
11341       include 'COMMON.VAR'
11342       include 'COMMON.GEO'
11343       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11344       logical swap
11345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11346 C                                                                              C
11347 C      Parallel       Antiparallel                                             C
11348 C                                                                              C
11349 C          o             o                                                     C
11350 C         /l\   /   \   /j\                                                    C
11351 C        /   \ /     \ /   \                                                   C
11352 C       /| o |o       o| o |\                                                  C
11353 C       j|/k\|  /      |/k\|l /                                                C
11354 C        /   \ /       /   \ /                                                 C
11355 C       /     o       /     o                                                  C
11356 C       i             i                                                        C
11357 C                                                                              C
11358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11359 C
11360 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11361 C           energy moment and not to the cluster cumulant.
11362       iti=itortyp(itype(i))
11363       if (j.lt.nres-1) then
11364         itj1=itype2loc(itype(j+1))
11365       else
11366         itj1=nloctyp
11367       endif
11368       itk=itype2loc(itype(k))
11369       itk1=itype2loc(itype(k+1))
11370       if (l.lt.nres-1) then
11371         itl1=itype2loc(itype(l+1))
11372       else
11373         itl1=nloctyp
11374       endif
11375 #ifdef MOMENT
11376       s1=dip(4,jj,i)*dip(4,kk,k)
11377 #endif
11378       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11379       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11380       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11381       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11382       call transpose2(EE(1,1,k),auxmat(1,1))
11383       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11384       vv(1)=pizda(1,1)+pizda(2,2)
11385       vv(2)=pizda(2,1)-pizda(1,2)
11386       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11387 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11388 cd     & "sum",-(s2+s3+s4)
11389 #ifdef MOMENT
11390       eello6_graph3=-(s1+s2+s3+s4)
11391 #else
11392 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11393       iti=itype2loc(itype(i))
11394       itj=itype2loc(itype(j))
11395       if (j.lt.nres-1) then
11396         itj1=itype2loc(itype(j+1))
11397       else
11398         itj1=nloctyp
11399       endif
11400       itk=itype2loc(itype(k))
11401       if (k.lt.nres-1) then
11402         itk1=itype2loc(itype(k+1))
11403       else
11404         itk1=nloctyp
11405       endif
11406       itl=itype2loc(itype(l))
11407       if (l.lt.nres-1) then
11408         itl1=itype2loc(itype(l+1))
11409       else
11410         itl1=nloctyp
11411       endif
11412 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11413 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11414 cd     & ' itl',itl,' itl1',itl1
11415 #ifdef MOMENT
11416       if (imat.eq.1) then
11417         s1=dip(3,jj,i)*dip(3,kk,k)
11418       else
11419         s1=dip(2,jj,j)*dip(2,kk,l)
11420       endif
11421 #endif
11422       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11423       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11424       if (j.eq.l+1) then
11425         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11426         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11427       else
11428         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11429         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11430       endif
11431       call transpose2(EUg(1,1,k),auxmat(1,1))
11432       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11433       vv(1)=pizda(1,1)-pizda(2,2)
11434       vv(2)=pizda(2,1)+pizda(1,2)
11435       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11436 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11437 #ifdef MOMENT
11438       eello6_graph4=-(s1+s2+s3+s4)
11439 #else
11440       eello6_graph4=-(s2+s3+s4)
11441 #endif
11442 C Derivatives in gamma(i-1)
11443       if (i.gt.1) then
11444 #ifdef MOMENT
11445         if (imat.eq.1) then
11446           s1=dipderg(2,jj,i)*dip(3,kk,k)
11447         else
11448           s1=dipderg(4,jj,j)*dip(2,kk,l)
11449         endif
11450 #endif
11451         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11452         if (j.eq.l+1) then
11453           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11454           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11455         else
11456           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11457           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11458         endif
11459         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11460         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11461 cd          write (2,*) 'turn6 derivatives'
11462 #ifdef MOMENT
11463           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11464 #else
11465           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11466 #endif
11467         else
11468 #ifdef MOMENT
11469           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11470 #else
11471           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11472 #endif
11473         endif
11474       endif
11475 C Derivatives in gamma(k-1)
11476 #ifdef MOMENT
11477       if (imat.eq.1) then
11478         s1=dip(3,jj,i)*dipderg(2,kk,k)
11479       else
11480         s1=dip(2,jj,j)*dipderg(4,kk,l)
11481       endif
11482 #endif
11483       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11484       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11485       if (j.eq.l+1) then
11486         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11487         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11488       else
11489         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11490         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11491       endif
11492       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11493       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11494       vv(1)=pizda(1,1)-pizda(2,2)
11495       vv(2)=pizda(2,1)+pizda(1,2)
11496       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11497       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11498 #ifdef MOMENT
11499         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11500 #else
11501         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11502 #endif
11503       else
11504 #ifdef MOMENT
11505         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11506 #else
11507         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11508 #endif
11509       endif
11510 C Derivatives in gamma(j-1) or gamma(l-1)
11511       if (l.eq.j+1 .and. l.gt.1) then
11512         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11513         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11514         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11515         vv(1)=pizda(1,1)-pizda(2,2)
11516         vv(2)=pizda(2,1)+pizda(1,2)
11517         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11518         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11519       else if (j.gt.1) then
11520         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11521         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11522         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11523         vv(1)=pizda(1,1)-pizda(2,2)
11524         vv(2)=pizda(2,1)+pizda(1,2)
11525         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11526         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11527           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11528         else
11529           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11530         endif
11531       endif
11532 C Cartesian derivatives.
11533       do iii=1,2
11534         do kkk=1,5
11535           do lll=1,3
11536 #ifdef MOMENT
11537             if (iii.eq.1) then
11538               if (imat.eq.1) then
11539                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11540               else
11541                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11542               endif
11543             else
11544               if (imat.eq.1) then
11545                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11546               else
11547                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11548               endif
11549             endif
11550 #endif
11551             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11552      &        auxvec(1))
11553             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11554             if (j.eq.l+1) then
11555               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11556      &          b1(1,j+1),auxvec(1))
11557               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11558             else
11559               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11560      &          b1(1,l+1),auxvec(1))
11561               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11562             endif
11563             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11564      &        pizda(1,1))
11565             vv(1)=pizda(1,1)-pizda(2,2)
11566             vv(2)=pizda(2,1)+pizda(1,2)
11567             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11568             if (swap) then
11569               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11570 #ifdef MOMENT
11571                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11572      &             -(s1+s2+s4)
11573 #else
11574                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11575      &             -(s2+s4)
11576 #endif
11577                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11578               else
11579 #ifdef MOMENT
11580                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11581 #else
11582                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11583 #endif
11584                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11585               endif
11586             else
11587 #ifdef MOMENT
11588               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11589 #else
11590               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11591 #endif
11592               if (l.eq.j+1) then
11593                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11594               else
11595                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11596               endif
11597             endif
11598           enddo
11599         enddo
11600       enddo
11601       return
11602       end
11603 c----------------------------------------------------------------------------
11604       double precision function eello_turn6(i,jj,kk)
11605       implicit real*8 (a-h,o-z)
11606       include 'DIMENSIONS'
11607       include 'COMMON.IOUNITS'
11608       include 'COMMON.CHAIN'
11609       include 'COMMON.DERIV'
11610       include 'COMMON.INTERACT'
11611       include 'COMMON.CONTACTS'
11612       include 'COMMON.TORSION'
11613       include 'COMMON.VAR'
11614       include 'COMMON.GEO'
11615       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11616      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11617      &  ggg1(3),ggg2(3)
11618       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11619      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11620 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11621 C           the respective energy moment and not to the cluster cumulant.
11622       s1=0.0d0
11623       s8=0.0d0
11624       s13=0.0d0
11625 c
11626       eello_turn6=0.0d0
11627       j=i+4
11628       k=i+1
11629       l=i+3
11630       iti=itype2loc(itype(i))
11631       itk=itype2loc(itype(k))
11632       itk1=itype2loc(itype(k+1))
11633       itl=itype2loc(itype(l))
11634       itj=itype2loc(itype(j))
11635 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11636 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11637 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11638 cd        eello6=0.0d0
11639 cd        return
11640 cd      endif
11641 cd      write (iout,*)
11642 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11643 cd     &   ' and',k,l
11644 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11645       do iii=1,2
11646         do kkk=1,5
11647           do lll=1,3
11648             derx_turn(lll,kkk,iii)=0.0d0
11649           enddo
11650         enddo
11651       enddo
11652 cd      eij=1.0d0
11653 cd      ekl=1.0d0
11654 cd      ekont=1.0d0
11655       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11656 cd      eello6_5=0.0d0
11657 cd      write (2,*) 'eello6_5',eello6_5
11658 #ifdef MOMENT
11659       call transpose2(AEA(1,1,1),auxmat(1,1))
11660       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11661       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11662       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11663 #endif
11664       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11665       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11666       s2 = scalar2(b1(1,k),vtemp1(1))
11667 #ifdef MOMENT
11668       call transpose2(AEA(1,1,2),atemp(1,1))
11669       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11670       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11671       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11672 #endif
11673       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11674       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11675       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11676 #ifdef MOMENT
11677       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11678       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11679       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11680       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11681       ss13 = scalar2(b1(1,k),vtemp4(1))
11682       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11683 #endif
11684 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11685 c      s1=0.0d0
11686 c      s2=0.0d0
11687 c      s8=0.0d0
11688 c      s12=0.0d0
11689 c      s13=0.0d0
11690       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11691 C Derivatives in gamma(i+2)
11692       s1d =0.0d0
11693       s8d =0.0d0
11694 #ifdef MOMENT
11695       call transpose2(AEA(1,1,1),auxmatd(1,1))
11696       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11697       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11698       call transpose2(AEAderg(1,1,2),atempd(1,1))
11699       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11700       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11701 #endif
11702       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11703       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11704       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11705 c      s1d=0.0d0
11706 c      s2d=0.0d0
11707 c      s8d=0.0d0
11708 c      s12d=0.0d0
11709 c      s13d=0.0d0
11710       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11711 C Derivatives in gamma(i+3)
11712 #ifdef MOMENT
11713       call transpose2(AEA(1,1,1),auxmatd(1,1))
11714       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11715       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11716       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11717 #endif
11718       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11719       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11720       s2d = scalar2(b1(1,k),vtemp1d(1))
11721 #ifdef MOMENT
11722       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11723       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11724 #endif
11725       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11726 #ifdef MOMENT
11727       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11728       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11729       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11730 #endif
11731 c      s1d=0.0d0
11732 c      s2d=0.0d0
11733 c      s8d=0.0d0
11734 c      s12d=0.0d0
11735 c      s13d=0.0d0
11736 #ifdef MOMENT
11737       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11738      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11739 #else
11740       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11741      &               -0.5d0*ekont*(s2d+s12d)
11742 #endif
11743 C Derivatives in gamma(i+4)
11744       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11745       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11746       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11747 #ifdef MOMENT
11748       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11749       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11750       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11751 #endif
11752 c      s1d=0.0d0
11753 c      s2d=0.0d0
11754 c      s8d=0.0d0
11755 C      s12d=0.0d0
11756 c      s13d=0.0d0
11757 #ifdef MOMENT
11758       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11759 #else
11760       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11761 #endif
11762 C Derivatives in gamma(i+5)
11763 #ifdef MOMENT
11764       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11765       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11766       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11767 #endif
11768       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11769       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11770       s2d = scalar2(b1(1,k),vtemp1d(1))
11771 #ifdef MOMENT
11772       call transpose2(AEA(1,1,2),atempd(1,1))
11773       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11774       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11775 #endif
11776       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11777       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11778 #ifdef MOMENT
11779       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11780       ss13d = scalar2(b1(1,k),vtemp4d(1))
11781       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11782 #endif
11783 c      s1d=0.0d0
11784 c      s2d=0.0d0
11785 c      s8d=0.0d0
11786 c      s12d=0.0d0
11787 c      s13d=0.0d0
11788 #ifdef MOMENT
11789       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11790      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11791 #else
11792       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11793      &               -0.5d0*ekont*(s2d+s12d)
11794 #endif
11795 C Cartesian derivatives
11796       do iii=1,2
11797         do kkk=1,5
11798           do lll=1,3
11799 #ifdef MOMENT
11800             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11801             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11802             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11803 #endif
11804             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11805             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11806      &          vtemp1d(1))
11807             s2d = scalar2(b1(1,k),vtemp1d(1))
11808 #ifdef MOMENT
11809             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11810             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11811             s8d = -(atempd(1,1)+atempd(2,2))*
11812      &           scalar2(cc(1,1,l),vtemp2(1))
11813 #endif
11814             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11815      &           auxmatd(1,1))
11816             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11817             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11818 c      s1d=0.0d0
11819 c      s2d=0.0d0
11820 c      s8d=0.0d0
11821 c      s12d=0.0d0
11822 c      s13d=0.0d0
11823 #ifdef MOMENT
11824             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11825      &        - 0.5d0*(s1d+s2d)
11826 #else
11827             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11828      &        - 0.5d0*s2d
11829 #endif
11830 #ifdef MOMENT
11831             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11832      &        - 0.5d0*(s8d+s12d)
11833 #else
11834             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11835      &        - 0.5d0*s12d
11836 #endif
11837           enddo
11838         enddo
11839       enddo
11840 #ifdef MOMENT
11841       do kkk=1,5
11842         do lll=1,3
11843           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11844      &      achuj_tempd(1,1))
11845           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11846           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11847           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11848           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11849           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11850      &      vtemp4d(1))
11851           ss13d = scalar2(b1(1,k),vtemp4d(1))
11852           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11853           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11854         enddo
11855       enddo
11856 #endif
11857 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11858 cd     &  16*eel_turn6_num
11859 cd      goto 1112
11860       if (j.lt.nres-1) then
11861         j1=j+1
11862         j2=j-1
11863       else
11864         j1=j-1
11865         j2=j-2
11866       endif
11867       if (l.lt.nres-1) then
11868         l1=l+1
11869         l2=l-1
11870       else
11871         l1=l-1
11872         l2=l-2
11873       endif
11874       do ll=1,3
11875 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11876 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11877 cgrad        ghalf=0.5d0*ggg1(ll)
11878 cd        ghalf=0.0d0
11879         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11880         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11881         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11882      &    +ekont*derx_turn(ll,2,1)
11883         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11884         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11885      &    +ekont*derx_turn(ll,4,1)
11886         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11887         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11888         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11889 cgrad        ghalf=0.5d0*ggg2(ll)
11890 cd        ghalf=0.0d0
11891         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11892      &    +ekont*derx_turn(ll,2,2)
11893         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11894         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11895      &    +ekont*derx_turn(ll,4,2)
11896         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11897         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11898         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11899       enddo
11900 cd      goto 1112
11901 cgrad      do m=i+1,j-1
11902 cgrad        do ll=1,3
11903 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11904 cgrad        enddo
11905 cgrad      enddo
11906 cgrad      do m=k+1,l-1
11907 cgrad        do ll=1,3
11908 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11909 cgrad        enddo
11910 cgrad      enddo
11911 cgrad1112  continue
11912 cgrad      do m=i+2,j2
11913 cgrad        do ll=1,3
11914 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11915 cgrad        enddo
11916 cgrad      enddo
11917 cgrad      do m=k+2,l2
11918 cgrad        do ll=1,3
11919 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11920 cgrad        enddo
11921 cgrad      enddo
11922 cd      do iii=1,nres-3
11923 cd        write (2,*) iii,g_corr6_loc(iii)
11924 cd      enddo
11925       eello_turn6=ekont*eel_turn6
11926 cd      write (2,*) 'ekont',ekont
11927 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11928       return
11929       end
11930
11931 C-----------------------------------------------------------------------------
11932       double precision function scalar(u,v)
11933 !DIR$ INLINEALWAYS scalar
11934 #ifndef OSF
11935 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11936 #endif
11937       implicit none
11938       double precision u(3),v(3)
11939 cd      double precision sc
11940 cd      integer i
11941 cd      sc=0.0d0
11942 cd      do i=1,3
11943 cd        sc=sc+u(i)*v(i)
11944 cd      enddo
11945 cd      scalar=sc
11946
11947       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11948       return
11949       end
11950 crc-------------------------------------------------
11951       SUBROUTINE MATVEC2(A1,V1,V2)
11952 !DIR$ INLINEALWAYS MATVEC2
11953 #ifndef OSF
11954 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11955 #endif
11956       implicit none
11957       include 'DIMENSIONS'
11958       double precision A1(2,2),V1(2),V2(2)
11959       double precision vaux1,vaux2
11960 c      DO 1 I=1,2
11961 c        VI=0.0
11962 c        DO 3 K=1,2
11963 c    3     VI=VI+A1(I,K)*V1(K)
11964 c        Vaux(I)=VI
11965 c    1 CONTINUE
11966
11967       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11968       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11969
11970       v2(1)=vaux1
11971       v2(2)=vaux2
11972       END
11973 C---------------------------------------
11974       SUBROUTINE MATMAT2(A1,A2,A3)
11975 #ifndef OSF
11976 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11977 #endif
11978       implicit none
11979       include 'DIMENSIONS'
11980       double precision A1(2,2),A2(2,2),A3(2,2)
11981       double precision ai3_11,ai3_12,ai3_21,ai3_22
11982 c      DIMENSION AI3(2,2)
11983 c        DO  J=1,2
11984 c          A3IJ=0.0
11985 c          DO K=1,2
11986 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11987 c          enddo
11988 c          A3(I,J)=A3IJ
11989 c       enddo
11990 c      enddo
11991
11992       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11993       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11994       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11995       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11996
11997       A3(1,1)=AI3_11
11998       A3(2,1)=AI3_21
11999       A3(1,2)=AI3_12
12000       A3(2,2)=AI3_22
12001       END
12002
12003 c-------------------------------------------------------------------------
12004       double precision function scalar2(u,v)
12005 !DIR$ INLINEALWAYS scalar2
12006       implicit none
12007       double precision u(2),v(2)
12008       double precision sc
12009       integer i
12010       scalar2=u(1)*v(1)+u(2)*v(2)
12011       return
12012       end
12013
12014 C-----------------------------------------------------------------------------
12015
12016       subroutine transpose2(a,at)
12017 !DIR$ INLINEALWAYS transpose2
12018 #ifndef OSF
12019 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12020 #endif
12021       implicit none
12022       double precision a(2,2),at(2,2)
12023       at(1,1)=a(1,1)
12024       at(1,2)=a(2,1)
12025       at(2,1)=a(1,2)
12026       at(2,2)=a(2,2)
12027       return
12028       end
12029 c--------------------------------------------------------------------------
12030       subroutine transpose(n,a,at)
12031       implicit none
12032       integer n,i,j
12033       double precision a(n,n),at(n,n)
12034       do i=1,n
12035         do j=1,n
12036           at(j,i)=a(i,j)
12037         enddo
12038       enddo
12039       return
12040       end
12041 C---------------------------------------------------------------------------
12042       subroutine prodmat3(a1,a2,kk,transp,prod)
12043 !DIR$ INLINEALWAYS prodmat3
12044 #ifndef OSF
12045 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12046 #endif
12047       implicit none
12048       integer i,j
12049       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12050       logical transp
12051 crc      double precision auxmat(2,2),prod_(2,2)
12052
12053       if (transp) then
12054 crc        call transpose2(kk(1,1),auxmat(1,1))
12055 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12056 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12057
12058            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12059      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12060            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12061      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12062            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12063      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12064            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12065      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12066
12067       else
12068 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12069 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12070
12071            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12072      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12073            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12074      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12075            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12076      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12077            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12078      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12079
12080       endif
12081 c      call transpose2(a2(1,1),a2t(1,1))
12082
12083 crc      print *,transp
12084 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12085 crc      print *,((prod(i,j),i=1,2),j=1,2)
12086
12087       return
12088       end
12089 CCC----------------------------------------------
12090       subroutine Eliptransfer(eliptran)
12091       implicit none
12092       include 'DIMENSIONS'
12093       include 'COMMON.GEO'
12094       include 'COMMON.VAR'
12095       include 'COMMON.LOCAL'
12096       include 'COMMON.CHAIN'
12097       include 'COMMON.DERIV'
12098       include 'COMMON.NAMES'
12099       include 'COMMON.INTERACT'
12100       include 'COMMON.IOUNITS'
12101       include 'COMMON.CALC'
12102       include 'COMMON.CONTROL'
12103       include 'COMMON.SPLITELE'
12104       include 'COMMON.SBRIDGE'
12105 C this is done by Adasko
12106 C      print *,"wchodze"
12107 C structure of box:
12108 C      water
12109 C--bordliptop-- buffore starts
12110 C--bufliptop--- here true lipid starts
12111 C      lipid
12112 C--buflipbot--- lipid ends buffore starts
12113 C--bordlipbot--buffore ends
12114       eliptran=0.0
12115       do i=ilip_start,ilip_end
12116 C       do i=1,1
12117         if (itype(i).eq.ntyp1) cycle
12118
12119         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12120         if (positi.le.0.0) positi=positi+boxzsize
12121 C        print *,i
12122 C first for peptide groups
12123 c for each residue check if it is in lipid or lipid water border area
12124        if ((positi.gt.bordlipbot)
12125      &.and.(positi.lt.bordliptop)) then
12126 C the energy transfer exist
12127         if (positi.lt.buflipbot) then
12128 C what fraction I am in
12129          fracinbuf=1.0d0-
12130      &        ((positi-bordlipbot)/lipbufthick)
12131 C lipbufthick is thickenes of lipid buffore
12132          sslip=sscalelip(fracinbuf)
12133          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12134          eliptran=eliptran+sslip*pepliptran
12135          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12136          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12137 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12138
12139 C        print *,"doing sccale for lower part"
12140 C         print *,i,sslip,fracinbuf,ssgradlip
12141         elseif (positi.gt.bufliptop) then
12142          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12143          sslip=sscalelip(fracinbuf)
12144          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12145          eliptran=eliptran+sslip*pepliptran
12146          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12147          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12148 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12149 C          print *, "doing sscalefor top part"
12150 C         print *,i,sslip,fracinbuf,ssgradlip
12151         else
12152          eliptran=eliptran+pepliptran
12153 C         print *,"I am in true lipid"
12154         endif
12155 C       else
12156 C       eliptran=elpitran+0.0 ! I am in water
12157        endif
12158        enddo
12159 C       print *, "nic nie bylo w lipidzie?"
12160 C now multiply all by the peptide group transfer factor
12161 C       eliptran=eliptran*pepliptran
12162 C now the same for side chains
12163 CV       do i=1,1
12164        do i=ilip_start,ilip_end
12165         if (itype(i).eq.ntyp1) cycle
12166         positi=(mod(c(3,i+nres),boxzsize))
12167         if (positi.le.0) positi=positi+boxzsize
12168 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12169 c for each residue check if it is in lipid or lipid water border area
12170 C       respos=mod(c(3,i+nres),boxzsize)
12171 C       print *,positi,bordlipbot,buflipbot
12172        if ((positi.gt.bordlipbot)
12173      & .and.(positi.lt.bordliptop)) then
12174 C the energy transfer exist
12175         if (positi.lt.buflipbot) then
12176          fracinbuf=1.0d0-
12177      &     ((positi-bordlipbot)/lipbufthick)
12178 C lipbufthick is thickenes of lipid buffore
12179          sslip=sscalelip(fracinbuf)
12180          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12181          eliptran=eliptran+sslip*liptranene(itype(i))
12182          gliptranx(3,i)=gliptranx(3,i)
12183      &+ssgradlip*liptranene(itype(i))
12184          gliptranc(3,i-1)= gliptranc(3,i-1)
12185      &+ssgradlip*liptranene(itype(i))
12186 C         print *,"doing sccale for lower part"
12187         elseif (positi.gt.bufliptop) then
12188          fracinbuf=1.0d0-
12189      &((bordliptop-positi)/lipbufthick)
12190          sslip=sscalelip(fracinbuf)
12191          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12192          eliptran=eliptran+sslip*liptranene(itype(i))
12193          gliptranx(3,i)=gliptranx(3,i)
12194      &+ssgradlip*liptranene(itype(i))
12195          gliptranc(3,i-1)= gliptranc(3,i-1)
12196      &+ssgradlip*liptranene(itype(i))
12197 C          print *, "doing sscalefor top part",sslip,fracinbuf
12198         else
12199          eliptran=eliptran+liptranene(itype(i))
12200 C         print *,"I am in true lipid"
12201         endif
12202         endif ! if in lipid or buffor
12203 C       else
12204 C       eliptran=elpitran+0.0 ! I am in water
12205        enddo
12206        return
12207        end
12208 C---------------------------------------------------------
12209 C AFM soubroutine for constant force
12210       subroutine AFMforce(Eafmforce)
12211       implicit none
12212       include 'DIMENSIONS'
12213       include 'COMMON.GEO'
12214       include 'COMMON.VAR'
12215       include 'COMMON.LOCAL'
12216       include 'COMMON.CHAIN'
12217       include 'COMMON.DERIV'
12218       include 'COMMON.NAMES'
12219       include 'COMMON.INTERACT'
12220       include 'COMMON.IOUNITS'
12221       include 'COMMON.CALC'
12222       include 'COMMON.CONTROL'
12223       include 'COMMON.SPLITELE'
12224       include 'COMMON.SBRIDGE'
12225       real*8 diffafm(3)
12226       dist=0.0d0
12227       Eafmforce=0.0d0
12228       do i=1,3
12229       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12230       dist=dist+diffafm(i)**2
12231       enddo
12232       dist=dsqrt(dist)
12233       Eafmforce=-forceAFMconst*(dist-distafminit)
12234       do i=1,3
12235       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12236       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12237       enddo
12238 C      print *,'AFM',Eafmforce
12239       return
12240       end
12241 C---------------------------------------------------------
12242 C AFM subroutine with pseudoconstant velocity
12243       subroutine AFMvel(Eafmforce)
12244       implicit none
12245       include 'DIMENSIONS'
12246       include 'COMMON.GEO'
12247       include 'COMMON.VAR'
12248       include 'COMMON.LOCAL'
12249       include 'COMMON.CHAIN'
12250       include 'COMMON.DERIV'
12251       include 'COMMON.NAMES'
12252       include 'COMMON.INTERACT'
12253       include 'COMMON.IOUNITS'
12254       include 'COMMON.CALC'
12255       include 'COMMON.CONTROL'
12256       include 'COMMON.SPLITELE'
12257       include 'COMMON.SBRIDGE'
12258       real*8 diffafm(3)
12259 C Only for check grad COMMENT if not used for checkgrad
12260 C      totT=3.0d0
12261 C--------------------------------------------------------
12262 C      print *,"wchodze"
12263       dist=0.0d0
12264       Eafmforce=0.0d0
12265       do i=1,3
12266       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12267       dist=dist+diffafm(i)**2
12268       enddo
12269       dist=dsqrt(dist)
12270       Eafmforce=0.5d0*forceAFMconst
12271      & *(distafminit+totTafm*velAFMconst-dist)**2
12272 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12273       do i=1,3
12274       gradafm(i,afmend-1)=-forceAFMconst*
12275      &(distafminit+totTafm*velAFMconst-dist)
12276      &*diffafm(i)/dist
12277       gradafm(i,afmbeg-1)=forceAFMconst*
12278      &(distafminit+totTafm*velAFMconst-dist)
12279      &*diffafm(i)/dist
12280       enddo
12281 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12282       return
12283       end
12284 C-----------------------------------------------------------
12285 C first for shielding is setting of function of side-chains
12286       subroutine set_shield_fac
12287       implicit none
12288       include 'DIMENSIONS'
12289       include 'COMMON.CHAIN'
12290       include 'COMMON.DERIV'
12291       include 'COMMON.IOUNITS'
12292       include 'COMMON.SHIELD'
12293       include 'COMMON.INTERACT'
12294 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12295       double precision div77_81/0.974996043d0/,
12296      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12297
12298 C the vector between center of side_chain and peptide group
12299        double precision pep_side(3),long,side_calf(3),
12300      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12301      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12302 C the line belowe needs to be changed for FGPROC>1
12303       do i=1,nres-1
12304       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12305       ishield_list(i)=0
12306 Cif there two consequtive dummy atoms there is no peptide group between them
12307 C the line below has to be changed for FGPROC>1
12308       VolumeTotal=0.0
12309       do k=1,nres
12310        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12311        dist_pep_side=0.0
12312        dist_side_calf=0.0
12313        do j=1,3
12314 C first lets set vector conecting the ithe side-chain with kth side-chain
12315       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12316 C      pep_side(j)=2.0d0
12317 C and vector conecting the side-chain with its proper calfa
12318       side_calf(j)=c(j,k+nres)-c(j,k)
12319 C      side_calf(j)=2.0d0
12320       pept_group(j)=c(j,i)-c(j,i+1)
12321 C lets have their lenght
12322       dist_pep_side=pep_side(j)**2+dist_pep_side
12323       dist_side_calf=dist_side_calf+side_calf(j)**2
12324       dist_pept_group=dist_pept_group+pept_group(j)**2
12325       enddo
12326        dist_pep_side=dsqrt(dist_pep_side)
12327        dist_pept_group=dsqrt(dist_pept_group)
12328        dist_side_calf=dsqrt(dist_side_calf)
12329       do j=1,3
12330         pep_side_norm(j)=pep_side(j)/dist_pep_side
12331         side_calf_norm(j)=dist_side_calf
12332       enddo
12333 C now sscale fraction
12334        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12335 C       print *,buff_shield,"buff"
12336 C now sscale
12337         if (sh_frac_dist.le.0.0) cycle
12338 C If we reach here it means that this side chain reaches the shielding sphere
12339 C Lets add him to the list for gradient
12340         ishield_list(i)=ishield_list(i)+1
12341 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12342 C this list is essential otherwise problem would be O3
12343         shield_list(ishield_list(i),i)=k
12344 C Lets have the sscale value
12345         if (sh_frac_dist.gt.1.0) then
12346          scale_fac_dist=1.0d0
12347          do j=1,3
12348          sh_frac_dist_grad(j)=0.0d0
12349          enddo
12350         else
12351          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12352      &                   *(2.0*sh_frac_dist-3.0d0)
12353          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12354      &                  /dist_pep_side/buff_shield*0.5
12355 C remember for the final gradient multiply sh_frac_dist_grad(j)
12356 C for side_chain by factor -2 !
12357          do j=1,3
12358          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12359 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12360 C     &                    sh_frac_dist_grad(j)
12361          enddo
12362         endif
12363 C        if ((i.eq.3).and.(k.eq.2)) then
12364 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12365 C     & ,"TU"
12366 C        endif
12367
12368 C this is what is now we have the distance scaling now volume...
12369       short=short_r_sidechain(itype(k))
12370       long=long_r_sidechain(itype(k))
12371       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12372 C now costhet_grad
12373 C       costhet=0.0d0
12374        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12375 C       costhet_fac=0.0d0
12376        do j=1,3
12377          costhet_grad(j)=costhet_fac*pep_side(j)
12378        enddo
12379 C remember for the final gradient multiply costhet_grad(j)
12380 C for side_chain by factor -2 !
12381 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12382 C pep_side0pept_group is vector multiplication
12383       pep_side0pept_group=0.0
12384       do j=1,3
12385       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12386       enddo
12387       cosalfa=(pep_side0pept_group/
12388      & (dist_pep_side*dist_side_calf))
12389       fac_alfa_sin=1.0-cosalfa**2
12390       fac_alfa_sin=dsqrt(fac_alfa_sin)
12391       rkprim=fac_alfa_sin*(long-short)+short
12392 C now costhet_grad
12393        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12394        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12395
12396        do j=1,3
12397          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12398      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12399      &*(long-short)/fac_alfa_sin*cosalfa/
12400      &((dist_pep_side*dist_side_calf))*
12401      &((side_calf(j))-cosalfa*
12402      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12403
12404         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12405      &*(long-short)/fac_alfa_sin*cosalfa
12406      &/((dist_pep_side*dist_side_calf))*
12407      &(pep_side(j)-
12408      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12409        enddo
12410
12411       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12412      &                    /VSolvSphere_div
12413      &                    *wshield
12414 C now the gradient...
12415 C grad_shield is gradient of Calfa for peptide groups
12416 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12417 C     &               costhet,cosphi
12418 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12419 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12420       do j=1,3
12421       grad_shield(j,i)=grad_shield(j,i)
12422 C gradient po skalowaniu
12423      &                +(sh_frac_dist_grad(j)
12424 C  gradient po costhet
12425      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12426      &-scale_fac_dist*(cosphi_grad_long(j))
12427      &/(1.0-cosphi) )*div77_81
12428      &*VofOverlap
12429 C grad_shield_side is Cbeta sidechain gradient
12430       grad_shield_side(j,ishield_list(i),i)=
12431      &        (sh_frac_dist_grad(j)*(-2.0d0)
12432      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12433      &       +scale_fac_dist*(cosphi_grad_long(j))
12434      &        *2.0d0/(1.0-cosphi))
12435      &        *div77_81*VofOverlap
12436
12437        grad_shield_loc(j,ishield_list(i),i)=
12438      &   scale_fac_dist*cosphi_grad_loc(j)
12439      &        *2.0d0/(1.0-cosphi)
12440      &        *div77_81*VofOverlap
12441       enddo
12442       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12443       enddo
12444       fac_shield(i)=VolumeTotal*div77_81+div4_81
12445 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12446       enddo
12447       return
12448       end
12449 C--------------------------------------------------------------------------
12450       double precision function tschebyshev(m,n,x,y)
12451       implicit none
12452       include "DIMENSIONS"
12453       integer i,m,n
12454       double precision x(n),y,yy(0:maxvar),aux
12455 c Tschebyshev polynomial. Note that the first term is omitted
12456 c m=0: the constant term is included
12457 c m=1: the constant term is not included
12458       yy(0)=1.0d0
12459       yy(1)=y
12460       do i=2,n
12461         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12462       enddo
12463       aux=0.0d0
12464       do i=m,n
12465         aux=aux+x(i)*yy(i)
12466       enddo
12467       tschebyshev=aux
12468       return
12469       end
12470 C--------------------------------------------------------------------------
12471       double precision function gradtschebyshev(m,n,x,y)
12472       implicit none
12473       include "DIMENSIONS"
12474       integer i,m,n
12475       double precision x(n+1),y,yy(0:maxvar),aux
12476 c Tschebyshev polynomial. Note that the first term is omitted
12477 c m=0: the constant term is included
12478 c m=1: the constant term is not included
12479       yy(0)=1.0d0
12480       yy(1)=2.0d0*y
12481       do i=2,n
12482         yy(i)=2*y*yy(i-1)-yy(i-2)
12483       enddo
12484       aux=0.0d0
12485       do i=m,n
12486         aux=aux+x(i+1)*yy(i)*(i+1)
12487 C        print *, x(i+1),yy(i),i
12488       enddo
12489       gradtschebyshev=aux
12490       return
12491       end
12492 C------------------------------------------------------------------------
12493 C first for shielding is setting of function of side-chains
12494       subroutine set_shield_fac2
12495       implicit none
12496       include 'DIMENSIONS'
12497       include 'COMMON.CHAIN'
12498       include 'COMMON.DERIV'
12499       include 'COMMON.IOUNITS'
12500       include 'COMMON.SHIELD'
12501       include 'COMMON.INTERACT'
12502 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12503       double precision div77_81/0.974996043d0/,
12504      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12505
12506 C the vector between center of side_chain and peptide group
12507        double precision pep_side(3),long,side_calf(3),
12508      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12509      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12510 C the line belowe needs to be changed for FGPROC>1
12511       do i=1,nres-1
12512       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12513       ishield_list(i)=0
12514 Cif there two consequtive dummy atoms there is no peptide group between them
12515 C the line below has to be changed for FGPROC>1
12516       VolumeTotal=0.0
12517       do k=1,nres
12518        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12519        dist_pep_side=0.0
12520        dist_side_calf=0.0
12521        do j=1,3
12522 C first lets set vector conecting the ithe side-chain with kth side-chain
12523       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12524 C      pep_side(j)=2.0d0
12525 C and vector conecting the side-chain with its proper calfa
12526       side_calf(j)=c(j,k+nres)-c(j,k)
12527 C      side_calf(j)=2.0d0
12528       pept_group(j)=c(j,i)-c(j,i+1)
12529 C lets have their lenght
12530       dist_pep_side=pep_side(j)**2+dist_pep_side
12531       dist_side_calf=dist_side_calf+side_calf(j)**2
12532       dist_pept_group=dist_pept_group+pept_group(j)**2
12533       enddo
12534        dist_pep_side=dsqrt(dist_pep_side)
12535        dist_pept_group=dsqrt(dist_pept_group)
12536        dist_side_calf=dsqrt(dist_side_calf)
12537       do j=1,3
12538         pep_side_norm(j)=pep_side(j)/dist_pep_side
12539         side_calf_norm(j)=dist_side_calf
12540       enddo
12541 C now sscale fraction
12542        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12543 C       print *,buff_shield,"buff"
12544 C now sscale
12545         if (sh_frac_dist.le.0.0) cycle
12546 C If we reach here it means that this side chain reaches the shielding sphere
12547 C Lets add him to the list for gradient
12548         ishield_list(i)=ishield_list(i)+1
12549 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12550 C this list is essential otherwise problem would be O3
12551         shield_list(ishield_list(i),i)=k
12552 C Lets have the sscale value
12553         if (sh_frac_dist.gt.1.0) then
12554          scale_fac_dist=1.0d0
12555          do j=1,3
12556          sh_frac_dist_grad(j)=0.0d0
12557          enddo
12558         else
12559          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12560      &                   *(2.0d0*sh_frac_dist-3.0d0)
12561          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12562      &                  /dist_pep_side/buff_shield*0.5d0
12563 C remember for the final gradient multiply sh_frac_dist_grad(j)
12564 C for side_chain by factor -2 !
12565          do j=1,3
12566          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12567 C         sh_frac_dist_grad(j)=0.0d0
12568 C         scale_fac_dist=1.0d0
12569 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12570 C     &                    sh_frac_dist_grad(j)
12571          enddo
12572         endif
12573 C this is what is now we have the distance scaling now volume...
12574       short=short_r_sidechain(itype(k))
12575       long=long_r_sidechain(itype(k))
12576       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12577       sinthet=short/dist_pep_side*costhet
12578 C now costhet_grad
12579 C       costhet=0.6d0
12580 C       sinthet=0.8
12581        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12582 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12583 C     &             -short/dist_pep_side**2/costhet)
12584 C       costhet_fac=0.0d0
12585        do j=1,3
12586          costhet_grad(j)=costhet_fac*pep_side(j)
12587        enddo
12588 C remember for the final gradient multiply costhet_grad(j)
12589 C for side_chain by factor -2 !
12590 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12591 C pep_side0pept_group is vector multiplication
12592       pep_side0pept_group=0.0d0
12593       do j=1,3
12594       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12595       enddo
12596       cosalfa=(pep_side0pept_group/
12597      & (dist_pep_side*dist_side_calf))
12598       fac_alfa_sin=1.0d0-cosalfa**2
12599       fac_alfa_sin=dsqrt(fac_alfa_sin)
12600       rkprim=fac_alfa_sin*(long-short)+short
12601 C      rkprim=short
12602
12603 C now costhet_grad
12604        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12605 C       cosphi=0.6
12606        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12607        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12608      &      dist_pep_side**2)
12609 C       sinphi=0.8
12610        do j=1,3
12611          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12612      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12613      &*(long-short)/fac_alfa_sin*cosalfa/
12614      &((dist_pep_side*dist_side_calf))*
12615      &((side_calf(j))-cosalfa*
12616      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12617 C       cosphi_grad_long(j)=0.0d0
12618         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12619      &*(long-short)/fac_alfa_sin*cosalfa
12620      &/((dist_pep_side*dist_side_calf))*
12621      &(pep_side(j)-
12622      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12623 C       cosphi_grad_loc(j)=0.0d0
12624        enddo
12625 C      print *,sinphi,sinthet
12626 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12627 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12628       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12629      &                    /VSolvSphere_div
12630 C     &                    *wshield
12631 C now the gradient...
12632       do j=1,3
12633       grad_shield(j,i)=grad_shield(j,i)
12634 C gradient po skalowaniu
12635      &                +(sh_frac_dist_grad(j)*VofOverlap
12636 C  gradient po costhet
12637      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12638      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12639      &       sinphi/sinthet*costhet*costhet_grad(j)
12640      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12641      & )*wshield
12642 C grad_shield_side is Cbeta sidechain gradient
12643       grad_shield_side(j,ishield_list(i),i)=
12644      &        (sh_frac_dist_grad(j)*(-2.0d0)
12645      &        *VofOverlap
12646      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12647      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12648      &       sinphi/sinthet*costhet*costhet_grad(j)
12649      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12650      &       )*wshield
12651
12652        grad_shield_loc(j,ishield_list(i),i)=
12653      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12654      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12655      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12656      &        ))
12657      &        *wshield
12658       enddo
12659 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12660 c     & scale_fac_dist
12661       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12662       enddo
12663       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12664 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12665 c     &  " wshield",wshield
12666 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12667       enddo
12668       return
12669       end
12670 C-----------------------------------------------------------------------
12671 C-----------------------------------------------------------
12672 C This subroutine is to mimic the histone like structure but as well can be
12673 C utilizet to nanostructures (infinit) small modification has to be used to
12674 C make it finite (z gradient at the ends has to be changes as well as the x,y
12675 C gradient has to be modified at the ends
12676 C The energy function is Kihara potential
12677 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12678 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12679 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12680 C simple Kihara potential
12681       subroutine calctube(Etube)
12682       implicit none
12683       include 'DIMENSIONS'
12684       include 'COMMON.GEO'
12685       include 'COMMON.VAR'
12686       include 'COMMON.LOCAL'
12687       include 'COMMON.CHAIN'
12688       include 'COMMON.DERIV'
12689       include 'COMMON.NAMES'
12690       include 'COMMON.INTERACT'
12691       include 'COMMON.IOUNITS'
12692       include 'COMMON.CALC'
12693       include 'COMMON.CONTROL'
12694       include 'COMMON.SPLITELE'
12695       include 'COMMON.SBRIDGE'
12696       double precision tub_r,vectube(3),enetube(maxres*2)
12697       Etube=0.0d0
12698       do i=1,2*nres
12699         enetube(i)=0.0d0
12700       enddo
12701 C first we calculate the distance from tube center
12702 C first sugare-phosphate group for NARES this would be peptide group
12703 C for UNRES
12704       do i=1,nres
12705 C lets ommit dummy atoms for now
12706        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12707 C now calculate distance from center of tube and direction vectors
12708       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12709           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12710       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12711           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12712       vectube(1)=vectube(1)-tubecenter(1)
12713       vectube(2)=vectube(2)-tubecenter(2)
12714
12715 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12716 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12717
12718 C as the tube is infinity we do not calculate the Z-vector use of Z
12719 C as chosen axis
12720       vectube(3)=0.0d0
12721 C now calculte the distance
12722        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12723 C now normalize vector
12724       vectube(1)=vectube(1)/tub_r
12725       vectube(2)=vectube(2)/tub_r
12726 C calculte rdiffrence between r and r0
12727       rdiff=tub_r-tubeR0
12728 C and its 6 power
12729       rdiff6=rdiff**6.0d0
12730 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12731        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12732 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12733 C       print *,rdiff,rdiff6,pep_aa_tube
12734 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12735 C now we calculate gradient
12736        fac=(-12.0d0*pep_aa_tube/rdiff6+
12737      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12738 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12739 C     &rdiff,fac
12740
12741 C now direction of gg_tube vector
12742         do j=1,3
12743         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12744         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12745         enddo
12746         enddo
12747 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12748         do i=1,nres
12749 C Lets not jump over memory as we use many times iti
12750          iti=itype(i)
12751 C lets ommit dummy atoms for now
12752          if ((iti.eq.ntyp1)
12753 C in UNRES uncomment the line below as GLY has no side-chain...
12754 C      .or.(iti.eq.10)
12755      &   ) cycle
12756           vectube(1)=c(1,i+nres)
12757           vectube(1)=mod(vectube(1),boxxsize)
12758           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12759           vectube(2)=c(2,i+nres)
12760           vectube(2)=mod(vectube(2),boxxsize)
12761           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12762
12763       vectube(1)=vectube(1)-tubecenter(1)
12764       vectube(2)=vectube(2)-tubecenter(2)
12765
12766 C as the tube is infinity we do not calculate the Z-vector use of Z
12767 C as chosen axis
12768       vectube(3)=0.0d0
12769 C now calculte the distance
12770        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12771 C now normalize vector
12772       vectube(1)=vectube(1)/tub_r
12773       vectube(2)=vectube(2)/tub_r
12774 C calculte rdiffrence between r and r0
12775       rdiff=tub_r-tubeR0
12776 C and its 6 power
12777       rdiff6=rdiff**6.0d0
12778 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12779        sc_aa_tube=sc_aa_tube_par(iti)
12780        sc_bb_tube=sc_bb_tube_par(iti)
12781        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12782 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12783 C now we calculate gradient
12784        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12785      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12786 C now direction of gg_tube vector
12787          do j=1,3
12788           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12789           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12790          enddo
12791         enddo
12792         do i=1,2*nres
12793           Etube=Etube+enetube(i)
12794         enddo
12795 C        print *,"ETUBE", etube
12796         return
12797         end
12798 C TO DO 1) add to total energy
12799 C       2) add to gradient summation
12800 C       3) add reading parameters (AND of course oppening of PARAM file)
12801 C       4) add reading the center of tube
12802 C       5) add COMMONs
12803 C       6) add to zerograd
12804
12805 C-----------------------------------------------------------------------
12806 C-----------------------------------------------------------
12807 C This subroutine is to mimic the histone like structure but as well can be
12808 C utilizet to nanostructures (infinit) small modification has to be used to
12809 C make it finite (z gradient at the ends has to be changes as well as the x,y
12810 C gradient has to be modified at the ends
12811 C The energy function is Kihara potential
12812 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12813 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12814 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12815 C simple Kihara potential
12816       subroutine calctube2(Etube)
12817       implicit none
12818       include 'DIMENSIONS'
12819       include 'COMMON.GEO'
12820       include 'COMMON.VAR'
12821       include 'COMMON.LOCAL'
12822       include 'COMMON.CHAIN'
12823       include 'COMMON.DERIV'
12824       include 'COMMON.NAMES'
12825       include 'COMMON.INTERACT'
12826       include 'COMMON.IOUNITS'
12827       include 'COMMON.CALC'
12828       include 'COMMON.CONTROL'
12829       include 'COMMON.SPLITELE'
12830       include 'COMMON.SBRIDGE'
12831       double precision tub_r,vectube(3),enetube(maxres*2)
12832       Etube=0.0d0
12833       do i=1,2*nres
12834         enetube(i)=0.0d0
12835       enddo
12836 C first we calculate the distance from tube center
12837 C first sugare-phosphate group for NARES this would be peptide group
12838 C for UNRES
12839       do i=1,nres
12840 C lets ommit dummy atoms for now
12841        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12842 C now calculate distance from center of tube and direction vectors
12843       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12844           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12845       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12846           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12847       vectube(1)=vectube(1)-tubecenter(1)
12848       vectube(2)=vectube(2)-tubecenter(2)
12849
12850 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12851 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12852
12853 C as the tube is infinity we do not calculate the Z-vector use of Z
12854 C as chosen axis
12855       vectube(3)=0.0d0
12856 C now calculte the distance
12857        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12858 C now normalize vector
12859       vectube(1)=vectube(1)/tub_r
12860       vectube(2)=vectube(2)/tub_r
12861 C calculte rdiffrence between r and r0
12862       rdiff=tub_r-tubeR0
12863 C and its 6 power
12864       rdiff6=rdiff**6.0d0
12865 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12866        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12867 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12868 C       print *,rdiff,rdiff6,pep_aa_tube
12869 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12870 C now we calculate gradient
12871        fac=(-12.0d0*pep_aa_tube/rdiff6+
12872      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12873 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12874 C     &rdiff,fac
12875
12876 C now direction of gg_tube vector
12877         do j=1,3
12878         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12879         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12880         enddo
12881         enddo
12882 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12883         do i=1,nres
12884 C Lets not jump over memory as we use many times iti
12885          iti=itype(i)
12886 C lets ommit dummy atoms for now
12887          if ((iti.eq.ntyp1)
12888 C in UNRES uncomment the line below as GLY has no side-chain...
12889      &      .or.(iti.eq.10)
12890      &   ) cycle
12891           vectube(1)=c(1,i+nres)
12892           vectube(1)=mod(vectube(1),boxxsize)
12893           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12894           vectube(2)=c(2,i+nres)
12895           vectube(2)=mod(vectube(2),boxxsize)
12896           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12897
12898       vectube(1)=vectube(1)-tubecenter(1)
12899       vectube(2)=vectube(2)-tubecenter(2)
12900 C THIS FRAGMENT MAKES TUBE FINITE
12901         positi=(mod(c(3,i+nres),boxzsize))
12902         if (positi.le.0) positi=positi+boxzsize
12903 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12904 c for each residue check if it is in lipid or lipid water border area
12905 C       respos=mod(c(3,i+nres),boxzsize)
12906        print *,positi,bordtubebot,buftubebot,bordtubetop
12907        if ((positi.gt.bordtubebot)
12908      & .and.(positi.lt.bordtubetop)) then
12909 C the energy transfer exist
12910         if (positi.lt.buftubebot) then
12911          fracinbuf=1.0d0-
12912      &     ((positi-bordtubebot)/tubebufthick)
12913 C lipbufthick is thickenes of lipid buffore
12914          sstube=sscalelip(fracinbuf)
12915          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12916          print *,ssgradtube, sstube,tubetranene(itype(i))
12917          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12918          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12919      &+ssgradtube*tubetranene(itype(i))
12920          gg_tube(3,i-1)= gg_tube(3,i-1)
12921      &+ssgradtube*tubetranene(itype(i))
12922 C         print *,"doing sccale for lower part"
12923         elseif (positi.gt.buftubetop) then
12924          fracinbuf=1.0d0-
12925      &((bordtubetop-positi)/tubebufthick)
12926          sstube=sscalelip(fracinbuf)
12927          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12928          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12929 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12930 C     &+ssgradtube*tubetranene(itype(i))
12931 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12932 C     &+ssgradtube*tubetranene(itype(i))
12933 C          print *, "doing sscalefor top part",sslip,fracinbuf
12934         else
12935          sstube=1.0d0
12936          ssgradtube=0.0d0
12937          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12938 C         print *,"I am in true lipid"
12939         endif
12940         else
12941 C          sstube=0.0d0
12942 C          ssgradtube=0.0d0
12943         cycle
12944         endif ! if in lipid or buffor
12945 CEND OF FINITE FRAGMENT
12946 C as the tube is infinity we do not calculate the Z-vector use of Z
12947 C as chosen axis
12948       vectube(3)=0.0d0
12949 C now calculte the distance
12950        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12951 C now normalize vector
12952       vectube(1)=vectube(1)/tub_r
12953       vectube(2)=vectube(2)/tub_r
12954 C calculte rdiffrence between r and r0
12955       rdiff=tub_r-tubeR0
12956 C and its 6 power
12957       rdiff6=rdiff**6.0d0
12958 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12959        sc_aa_tube=sc_aa_tube_par(iti)
12960        sc_bb_tube=sc_bb_tube_par(iti)
12961        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12962      &                 *sstube+enetube(i+nres)
12963 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12964 C now we calculate gradient
12965        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12966      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12967 C now direction of gg_tube vector
12968          do j=1,3
12969           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12970           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12971          enddo
12972          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12973      &+ssgradtube*enetube(i+nres)/sstube
12974          gg_tube(3,i-1)= gg_tube(3,i-1)
12975      &+ssgradtube*enetube(i+nres)/sstube
12976
12977         enddo
12978         do i=1,2*nres
12979           Etube=Etube+enetube(i)
12980         enddo
12981 C        print *,"ETUBE", etube
12982         return
12983         end
12984 C TO DO 1) add to total energy
12985 C       2) add to gradient summation
12986 C       3) add reading parameters (AND of course oppening of PARAM file)
12987 C       4) add reading the center of tube
12988 C       5) add COMMONs
12989 C       6) add to zerograd
12990 c----------------------------------------------------------------------------
12991       subroutine e_saxs(Esaxs_constr)
12992       implicit none
12993       include 'DIMENSIONS'
12994 #ifdef MPI
12995       include "mpif.h"
12996       include "COMMON.SETUP"
12997       integer IERR
12998 #endif
12999       include 'COMMON.SBRIDGE'
13000       include 'COMMON.CHAIN'
13001       include 'COMMON.GEO'
13002       include 'COMMON.DERIV'
13003       include 'COMMON.LOCAL'
13004       include 'COMMON.INTERACT'
13005       include 'COMMON.VAR'
13006       include 'COMMON.IOUNITS'
13007       include 'COMMON.MD'
13008 #ifdef LANG0
13009       include 'COMMON.LANGEVIN.lang0'
13010 #else
13011       include 'COMMON.LANGEVIN'
13012 #endif
13013       include 'COMMON.CONTROL'
13014       include 'COMMON.SAXS'
13015       include 'COMMON.NAMES'
13016       include 'COMMON.TIME1'
13017       include 'COMMON.FFIELD'
13018 c
13019       double precision Esaxs_constr
13020       integer i,iint,j,k,l
13021       double precision PgradC(maxSAXS,3,maxres),
13022      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13023 #ifdef MPI
13024       double precision PgradC_(maxSAXS,3,maxres),
13025      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13026 #endif
13027       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13028      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13029      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13030      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13031       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13032       double precision dist,mygauss,mygaussder
13033       external dist
13034       integer llicz,lllicz
13035       double precision time01
13036 c  SAXS restraint penalty function
13037 #ifdef DEBUG
13038       write(iout,*) "------- SAXS penalty function start -------"
13039       write (iout,*) "nsaxs",nsaxs
13040       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13041       write (iout,*) "Psaxs"
13042       do i=1,nsaxs
13043         write (iout,'(i5,e15.5)') i, Psaxs(i)
13044       enddo
13045 #endif
13046 #ifdef TIMING
13047       time01=MPI_Wtime()
13048 #endif
13049       Esaxs_constr = 0.0d0
13050       do k=1,nsaxs
13051         Pcalc(k)=0.0d0
13052         do j=1,nres
13053           do l=1,3
13054             PgradC(k,l,j)=0.0d0
13055             PgradX(k,l,j)=0.0d0
13056           enddo
13057         enddo
13058       enddo
13059 c      lllicz=0
13060       do i=iatsc_s,iatsc_e
13061        if (itype(i).eq.ntyp1) cycle
13062        do iint=1,nint_gr(i)
13063          do j=istart(i,iint),iend(i,iint)
13064            if (itype(j).eq.ntyp1) cycle
13065 #ifdef ALLSAXS
13066            dijCACA=dist(i,j)
13067            dijCASC=dist(i,j+nres)
13068            dijSCCA=dist(i+nres,j)
13069            dijSCSC=dist(i+nres,j+nres)
13070            sigma2CACA=2.0d0/(pstok**2)
13071            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13072            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13073            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13074            do k=1,nsaxs
13075              dk = distsaxs(k)
13076              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13077              if (itype(j).ne.10) then
13078              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13079              else
13080              endif
13081              expCASC = 0.0d0
13082              if (itype(i).ne.10) then
13083              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13084              else
13085              expSCCA = 0.0d0
13086              endif
13087              if (itype(i).ne.10 .and. itype(j).ne.10) then
13088              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13089              else
13090              expSCSC = 0.0d0
13091              endif
13092              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13093 #ifdef DEBUG
13094              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13095 #endif
13096              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13097              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13098              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13099              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13100              do l=1,3
13101 c CA CA
13102                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13103                PgradC(k,l,i) = PgradC(k,l,i)-aux
13104                PgradC(k,l,j) = PgradC(k,l,j)+aux
13105 c CA SC
13106                if (itype(j).ne.10) then
13107                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13108                PgradC(k,l,i) = PgradC(k,l,i)-aux
13109                PgradC(k,l,j) = PgradC(k,l,j)+aux
13110                PgradX(k,l,j) = PgradX(k,l,j)+aux
13111                endif
13112 c SC CA
13113                if (itype(i).ne.10) then
13114                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13115                PgradX(k,l,i) = PgradX(k,l,i)-aux
13116                PgradC(k,l,i) = PgradC(k,l,i)-aux
13117                PgradC(k,l,j) = PgradC(k,l,j)+aux
13118                endif
13119 c SC SC
13120                if (itype(i).ne.10 .and. itype(j).ne.10) then
13121                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13122                PgradC(k,l,i) = PgradC(k,l,i)-aux
13123                PgradC(k,l,j) = PgradC(k,l,j)+aux
13124                PgradX(k,l,i) = PgradX(k,l,i)-aux
13125                PgradX(k,l,j) = PgradX(k,l,j)+aux
13126                endif
13127              enddo ! l
13128            enddo ! k
13129 #else
13130            dijCACA=dist(i,j)
13131            sigma2CACA=scal_rad**2*0.25d0/
13132      &        (restok(itype(j))**2+restok(itype(i))**2)
13133 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13134 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13135 #ifdef MYGAUSS
13136            sigmaCACA=dsqrt(sigma2CACA)
13137            threesig=3.0d0/sigmaCACA
13138 c           llicz=0
13139            do k=1,nsaxs
13140              dk = distsaxs(k)
13141              if (dabs(dijCACA-dk).ge.threesig) cycle
13142 c             llicz=llicz+1
13143 c             lllicz=lllicz+1
13144              aux = sigmaCACA*(dijCACA-dk)
13145              expCACA = mygauss(aux)
13146 c             if (expcaca.eq.0.0d0) cycle
13147              Pcalc(k) = Pcalc(k)+expCACA
13148              CACAgrad = -sigmaCACA*mygaussder(aux)
13149 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13150              do l=1,3
13151                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13152                PgradC(k,l,i) = PgradC(k,l,i)-aux
13153                PgradC(k,l,j) = PgradC(k,l,j)+aux
13154              enddo ! l
13155            enddo ! k
13156 c           write (iout,*) "i",i," j",j," llicz",llicz
13157 #else
13158            IF (saxs_cutoff.eq.0) THEN
13159            do k=1,nsaxs
13160              dk = distsaxs(k)
13161              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13162              Pcalc(k) = Pcalc(k)+expCACA
13163              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13164              do l=1,3
13165                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13166                PgradC(k,l,i) = PgradC(k,l,i)-aux
13167                PgradC(k,l,j) = PgradC(k,l,j)+aux
13168              enddo ! l
13169            enddo ! k
13170            ELSE
13171            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13172            do k=1,nsaxs
13173              dk = distsaxs(k)
13174 c             write (2,*) "ijk",i,j,k
13175              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13176              if (sss2.eq.0.0d0) cycle
13177              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13178              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13179      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13180      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13181      &           sss2,ssgrad2
13182              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13183              Pcalc(k) = Pcalc(k)+expCACA
13184 #ifdef DEBUG
13185              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13186 #endif
13187              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13188      &             ssgrad2*expCACA/sss2
13189              do l=1,3
13190 c CA CA
13191                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13192                PgradC(k,l,i) = PgradC(k,l,i)+aux
13193                PgradC(k,l,j) = PgradC(k,l,j)-aux
13194              enddo ! l
13195            enddo ! k
13196            ENDIF
13197 #endif
13198 #endif
13199          enddo ! j
13200        enddo ! iint
13201       enddo ! i
13202 c#ifdef TIMING
13203 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13204 c#endif
13205 c      write (iout,*) "lllicz",lllicz
13206 c#ifdef TIMING
13207 c      time01=MPI_Wtime()
13208 c#endif
13209 #ifdef MPI
13210       if (nfgtasks.gt.1) then
13211        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13212      &    MPI_SUM,FG_COMM,IERR)
13213 c        if (fg_rank.eq.king) then
13214           do k=1,nsaxs
13215             Pcalc(k) = Pcalc_(k)
13216           enddo
13217 c        endif
13218 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13219 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13220 c        if (fg_rank.eq.king) then
13221 c          do i=1,nres
13222 c            do l=1,3
13223 c              do k=1,nsaxs
13224 c                PgradC(k,l,i) = PgradC_(k,l,i)
13225 c              enddo
13226 c            enddo
13227 c          enddo
13228 c        endif
13229 #ifdef ALLSAXS
13230 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13231 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13232 c        if (fg_rank.eq.king) then
13233 c          do i=1,nres
13234 c            do l=1,3
13235 c              do k=1,nsaxs
13236 c                PgradX(k,l,i) = PgradX_(k,l,i)
13237 c              enddo
13238 c            enddo
13239 c          enddo
13240 c        endif
13241 #endif
13242       endif
13243 #endif
13244       Cnorm = 0.0d0
13245       do k=1,nsaxs
13246         Cnorm = Cnorm + Pcalc(k)
13247       enddo
13248 #ifdef MPI
13249       if (fg_rank.eq.king) then
13250 #endif
13251       Esaxs_constr = dlog(Cnorm)-wsaxs0
13252       do k=1,nsaxs
13253         if (Pcalc(k).gt.0.0d0)
13254      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13255 #ifdef DEBUG
13256         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13257 #endif
13258       enddo
13259 #ifdef DEBUG
13260       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13261 #endif
13262 #ifdef MPI
13263       endif
13264 #endif
13265       gsaxsC=0.0d0
13266       gsaxsX=0.0d0
13267       do i=nnt,nct
13268         do l=1,3
13269           auxC=0.0d0
13270           auxC1=0.0d0
13271           auxX=0.0d0
13272           auxX1=0.d0
13273           do k=1,nsaxs
13274             if (Pcalc(k).gt.0)
13275      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13276             auxC1 = auxC1+PgradC(k,l,i)
13277 #ifdef ALLSAXS
13278             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13279             auxX1 = auxX1+PgradX(k,l,i)
13280 #endif
13281           enddo
13282           gsaxsC(l,i) = auxC - auxC1/Cnorm
13283 #ifdef ALLSAXS
13284           gsaxsX(l,i) = auxX - auxX1/Cnorm
13285 #endif
13286 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13287 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13288 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13289 c     *     " gradX",wsaxs*gsaxsX(l,i)
13290         enddo
13291       enddo
13292 #ifdef TIMING
13293       time_SAXS=time_SAXS+MPI_Wtime()-time01
13294 #endif
13295 #ifdef DEBUG
13296       write (iout,*) "gsaxsc"
13297       do i=nnt,nct
13298         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13299       enddo
13300 #endif
13301 #ifdef MPI
13302 c      endif
13303 #endif
13304       return
13305       end
13306 c----------------------------------------------------------------------------
13307       subroutine e_saxsC(Esaxs_constr)
13308       implicit none
13309       include 'DIMENSIONS'
13310 #ifdef MPI
13311       include "mpif.h"
13312       include "COMMON.SETUP"
13313       integer IERR
13314 #endif
13315       include 'COMMON.SBRIDGE'
13316       include 'COMMON.CHAIN'
13317       include 'COMMON.GEO'
13318       include 'COMMON.DERIV'
13319       include 'COMMON.LOCAL'
13320       include 'COMMON.INTERACT'
13321       include 'COMMON.VAR'
13322       include 'COMMON.IOUNITS'
13323       include 'COMMON.MD'
13324 #ifdef LANG0
13325       include 'COMMON.LANGEVIN.lang0'
13326 #else
13327       include 'COMMON.LANGEVIN'
13328 #endif
13329       include 'COMMON.CONTROL'
13330       include 'COMMON.SAXS'
13331       include 'COMMON.NAMES'
13332       include 'COMMON.TIME1'
13333       include 'COMMON.FFIELD'
13334 c
13335       double precision Esaxs_constr
13336       integer i,iint,j,k,l
13337       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13338 #ifdef MPI
13339       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13340 #endif
13341       double precision dk,dijCASPH,dijSCSPH,
13342      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13343      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13344      & auxX,auxX1,Cnorm
13345 c  SAXS restraint penalty function
13346 #ifdef DEBUG
13347       write(iout,*) "------- SAXS penalty function start -------"
13348       write (iout,*) "nsaxs",nsaxs
13349
13350       do i=nnt,nct
13351         print *,MyRank,"C",i,(C(j,i),j=1,3)
13352       enddo
13353       do i=nnt,nct
13354         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13355       enddo
13356 #endif
13357       Esaxs_constr = 0.0d0
13358       logPtot=0.0d0
13359       do j=isaxs_start,isaxs_end
13360         Pcalc=0.0d0
13361         do i=1,nres
13362           do l=1,3
13363             PgradC(l,i)=0.0d0
13364             PgradX(l,i)=0.0d0
13365           enddo
13366         enddo
13367         do i=nnt,nct
13368           if (itype(i).eq.ntyp1) cycle
13369           dijCASPH=0.0d0
13370           dijSCSPH=0.0d0
13371           do l=1,3
13372             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13373           enddo
13374           if (itype(i).ne.10) then
13375           do l=1,3
13376             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13377           enddo
13378           endif
13379           sigma2CA=2.0d0/pstok**2
13380           sigma2SC=4.0d0/restok(itype(i))**2
13381           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13382           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13383           Pcalc = Pcalc+expCASPH+expSCSPH
13384 #ifdef DEBUG
13385           write(*,*) "processor i j Pcalc",
13386      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13387 #endif
13388           CASPHgrad = sigma2CA*expCASPH
13389           SCSPHgrad = sigma2SC*expSCSPH
13390           do l=1,3
13391             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13392             PgradX(l,i) = PgradX(l,i) + aux
13393             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13394           enddo ! l
13395         enddo ! i
13396         do i=nnt,nct
13397           do l=1,3
13398             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13399             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13400           enddo
13401         enddo
13402         logPtot = logPtot - dlog(Pcalc)
13403 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13404 c     &    " logPtot",logPtot
13405       enddo ! j
13406 #ifdef MPI
13407       if (nfgtasks.gt.1) then
13408 c        write (iout,*) "logPtot before reduction",logPtot
13409         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13410      &    MPI_SUM,king,FG_COMM,IERR)
13411         logPtot = logPtot_
13412 c        write (iout,*) "logPtot after reduction",logPtot
13413         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13414      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13415         if (fg_rank.eq.king) then
13416           do i=1,nres
13417             do l=1,3
13418               gsaxsC(l,i) = gsaxsC_(l,i)
13419             enddo
13420           enddo
13421         endif
13422         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13423      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13424         if (fg_rank.eq.king) then
13425           do i=1,nres
13426             do l=1,3
13427               gsaxsX(l,i) = gsaxsX_(l,i)
13428             enddo
13429           enddo
13430         endif
13431       endif
13432 #endif
13433       Esaxs_constr = logPtot
13434       return
13435       end
13436 c----------------------------------------------------------------------------
13437       double precision function sscale2(r,r_cut,r0,rlamb)
13438       implicit none
13439       double precision r,gamm,r_cut,r0,rlamb,rr
13440       rr = dabs(r-r0)
13441 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13442 c      write (2,*) "rr",rr
13443       if(rr.lt.r_cut-rlamb) then
13444         sscale2=1.0d0
13445       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13446         gamm=(rr-(r_cut-rlamb))/rlamb
13447         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13448       else
13449         sscale2=0d0
13450       endif
13451       return
13452       end
13453 C-----------------------------------------------------------------------
13454       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13455       implicit none
13456       double precision r,gamm,r_cut,r0,rlamb,rr
13457       rr = dabs(r-r0)
13458       if(rr.lt.r_cut-rlamb) then
13459         sscalgrad2=0.0d0
13460       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13461         gamm=(rr-(r_cut-rlamb))/rlamb
13462         if (r.ge.r0) then
13463           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13464         else
13465           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13466         endif
13467       else
13468         sscalgrad2=0.0d0
13469       endif
13470       return
13471       end