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

   1       subroutine etotal(energia)
   2       implicit none
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  34      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  35      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  36      & eliptran,Eafmforce,Etube,
  37      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  38       integer n_corr,n_corr1
  39 #ifdef MPI
  40 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  41 c     & " nfgtasks",nfgtasks
  42       if (nfgtasks.gt.1) then
  43         time00=MPI_Wtime()
  44 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  45         if (fg_rank.eq.0) then
  46           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  47 c          print *,"Processor",myrank," BROADCAST iorder"
  48 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  49 C FG slaves as WEIGHTS array.
  50           weights_(1)=wsc
  51           weights_(2)=wscp
  52           weights_(3)=welec
  53           weights_(4)=wcorr
  54           weights_(5)=wcorr5
  55           weights_(6)=wcorr6
  56           weights_(7)=wel_loc
  57           weights_(8)=wturn3
  58           weights_(9)=wturn4
  59           weights_(10)=wturn6
  60           weights_(11)=wang
  61           weights_(12)=wscloc
  62           weights_(13)=wtor
  63           weights_(14)=wtor_d
  64           weights_(15)=wstrain
  65           weights_(16)=wvdwpp
  66           weights_(17)=wbond
  67           weights_(18)=scal14
  68           weights_(21)=wsccor
  69           weights_(22)=wtube
  70           weights_(26)=wsaxs
  71           weights_(28)=wdfa_dist
  72           weights_(29)=wdfa_tor
  73           weights_(30)=wdfa_nei
  74           weights_(31)=wdfa_beta
  75 C FG Master broadcasts the WEIGHTS_ array
  76           call MPI_Bcast(weights_(1),n_ene,
  77      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  78         else
  79 C FG slaves receive the WEIGHTS array
  80           call MPI_Bcast(weights(1),n_ene,
  81      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  82           wsc=weights(1)
  83           wscp=weights(2)
  84           welec=weights(3)
  85           wcorr=weights(4)
  86           wcorr5=weights(5)
  87           wcorr6=weights(6)
  88           wel_loc=weights(7)
  89           wturn3=weights(8)
  90           wturn4=weights(9)
  91           wturn6=weights(10)
  92           wang=weights(11)
  93           wscloc=weights(12)
  94           wtor=weights(13)
  95           wtor_d=weights(14)
  96           wstrain=weights(15)
  97           wvdwpp=weights(16)
  98           wbond=weights(17)
  99           scal14=weights(18)
 100           wsccor=weights(21)
 101           wtube=weights(22)
 102           wsaxs=weights(26)
 103           wdfa_dist=weights_(28)
 104           wdfa_tor=weights_(29)
 105           wdfa_nei=weights_(30)
 106           wdfa_beta=weights_(31)
 107         endif
 108         time_Bcast=time_Bcast+MPI_Wtime()-time00
 109         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 110 c        call chainbuild_cart
 111       endif
 112 #ifndef DFA
 113       edfadis=0.0d0
 114       edfator=0.0d0
 115       edfanei=0.0d0
 116       edfabet=0.0d0
 117 #endif
 118 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 119 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 120 #else
 121 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 122 c        call int_from_cart1(.false.)
 123 c      endif
 124 #endif
 125 #ifdef TIMING
 126       time00=MPI_Wtime()
 127 #endif
 128 C
 129 C Compute the side-chain and electrostatic interaction energy
 130 C
 131 C      print *,ipot
 132       goto (101,102,103,104,105,106) ipot
 133 C Lennard-Jones potential.
 134   101 call elj(evdw)
 135 cd    print '(a)','Exit ELJ'
 136       goto 107
 137 C Lennard-Jones-Kihara potential (shifted).
 138   102 call eljk(evdw)
 139       goto 107
 140 C Berne-Pechukas potential (dilated LJ, angular dependence).
 141   103 call ebp(evdw)
 142       goto 107
 143 C Gay-Berne potential (shifted LJ, angular dependence).
 144   104 call egb(evdw)
 145 C      print *,"bylem w egb"
 146       goto 107
 147 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 148   105 call egbv(evdw)
 149       goto 107
 150 C Soft-sphere potential
 151   106 call e_softsphere(evdw)
 152 C
 153 C Calculate electrostatic (H-bonding) energy of the main chain.
 154 C
 155   107 continue
 156 #ifdef DFA
 157 C     BARTEK for dfa test!
 158       if (wdfa_dist.gt.0) then
 159         call edfad(edfadis)
 160       else
 161         edfadis=0
 162       endif
 163 c      print*, 'edfad is finished!', edfadis
 164       if (wdfa_tor.gt.0) then
 165         call edfat(edfator)
 166       else
 167         edfator=0
 168       endif
 169 c      print*, 'edfat is finished!', edfator
 170       if (wdfa_nei.gt.0) then
 171         call edfan(edfanei)
 172       else
 173         edfanei=0
 174       endif
 175 c      print*, 'edfan is finished!', edfanei
 176       if (wdfa_beta.gt.0) then
 177         call edfab(edfabet)
 178       else
 179         edfabet=0
 180       endif
 181 #endif
 182 cmc
 183 cmc Sep-06: egb takes care of dynamic ss bonds too
 184 cmc
 185 c      if (dyn_ss) call dyn_set_nss
 186
 187 c      print *,"Processor",myrank," computed USCSC"
 188 #ifdef TIMING
 189       time01=MPI_Wtime()
 190 #endif
 191       call vec_and_deriv
 192 #ifdef TIMING
 193       time_vec=time_vec+MPI_Wtime()-time01
 194 #endif
 195 C Introduction of shielding effect first for each peptide group
 196 C the shielding factor is set this factor is describing how each
 197 C peptide group is shielded by side-chains
 198 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 199 C      write (iout,*) "shield_mode",shield_mode
 200       if (shield_mode.eq.1) then
 201        call set_shield_fac
 202       else if  (shield_mode.eq.2) then
 203        call set_shield_fac2
 204       endif
 205 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 206       if (ipot.lt.6) then
 207 #ifdef SPLITELE
 208          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 209      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 210      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 211      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 212 #else
 213          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 214      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 215      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 216      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 217 #endif
 218             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 219          else
 220             ees=0.0d0
 221             evdw1=0.0d0
 222             eel_loc=0.0d0
 223             eello_turn3=0.0d0
 224             eello_turn4=0.0d0
 225          endif
 226       else
 227         write (iout,*) "Soft-spheer ELEC potential"
 228 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 229 c     &   eello_turn4)
 230       endif
 231 c#ifdef TIMING
 232 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 233 c#endif
 234 c      print *,"Processor",myrank," computed UELEC"
 235 C
 236 C Calculate excluded-volume interaction energy between peptide groups
 237 C and side chains.
 238 C
 239       if (ipot.lt.6) then
 240        if(wscp.gt.0d0) then
 241         call escp(evdw2,evdw2_14)
 242        else
 243         evdw2=0
 244         evdw2_14=0
 245        endif
 246       else
 247 c        write (iout,*) "Soft-sphere SCP potential"
 248         call escp_soft_sphere(evdw2,evdw2_14)
 249       endif
 250 c
 251 c Calculate the bond-stretching energy
 252 c
 253       call ebond(estr)
 254 C
 255 C Calculate the disulfide-bridge and other energy and the contributions
 256 C from other distance constraints.
 257 cd      write (iout,*) 'Calling EHPB'
 258       call edis(ehpb)
 259 cd    print *,'EHPB exitted succesfully.'
 260 C
 261 C Calculate the virtual-bond-angle energy.
 262 C
 263       if (wang.gt.0d0) then
 264        if (tor_mode.eq.0) then
 265          call ebend(ebe)
 266        else
 267 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 268 C energy function
 269          call ebend_kcc(ebe)
 270        endif
 271       else
 272         ebe=0.0d0
 273       endif
 274       ethetacnstr=0.0d0
 275       if (with_theta_constr) call etheta_constr(ethetacnstr)
 276 c      print *,"Processor",myrank," computed UB"
 277 C
 278 C Calculate the SC local energy.
 279 C
 280 C      print *,"TU DOCHODZE?"
 281       call esc(escloc)
 282 c      print *,"Processor",myrank," computed USC"
 283 C
 284 C Calculate the virtual-bond torsional energy.
 285 C
 286 cd    print *,'nterm=',nterm
 287 C      print *,"tor",tor_mode
 288       if (wtor.gt.0.0d0) then
 289          if (tor_mode.eq.0) then
 290            call etor(etors)
 291          else
 292 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 293 C energy function
 294            call etor_kcc(etors)
 295          endif
 296       else
 297         etors=0.0d0
 298       endif
 299       edihcnstr=0.0d0
 300       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 301 c      print *,"Processor",myrank," computed Utor"
 302       if (constr_homology.ge.1) then
 303         call e_modeller(ehomology_constr)
 304 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 305 c     &  'Processor',fg_rank,' CG group',kolor,
 306 c     &  ' absolute rank',MyRank
 307       else
 308         ehomology_constr=0.0d0
 309       endif
 310 C
 311 C 6/23/01 Calculate double-torsional energy
 312 C
 313       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 314         call etor_d(etors_d)
 315       else
 316         etors_d=0
 317       endif
 318 c      print *,"Processor",myrank," computed Utord"
 319 C
 320 C 21/5/07 Calculate local sicdechain correlation energy
 321 C
 322       if (wsccor.gt.0.0d0) then
 323         call eback_sc_corr(esccor)
 324       else
 325         esccor=0.0d0
 326       endif
 327 C      print *,"PRZED MULIt"
 328 c      print *,"Processor",myrank," computed Usccorr"
 329 C
 330 C 12/1/95 Multi-body terms
 331 C
 332       n_corr=0
 333       n_corr1=0
 334       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 335      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 336          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 337 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 338 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 339 c        call flush(iout)
 340       else
 341          ecorr=0.0d0
 342          ecorr5=0.0d0
 343          ecorr6=0.0d0
 344          eturn6=0.0d0
 345       endif
 346       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 347 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 348 c     &     n_corr,n_corr1
 349 c         call flush(iout)
 350          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 351 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 352 c     &     n_corr1
 353 c         call flush(iout)
 354       endif
 355 c      print *,"Processor",myrank," computed Ucorr"
 356 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 357       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 358         call e_saxs(Esaxs_constr)
 359 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 360       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 361         call e_saxsC(Esaxs_constr)
 362 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 363       else
 364         Esaxs_constr = 0.0d0
 365       endif
 366 C
 367 C If performing constraint dynamics, call the constraint energy
 368 C  after the equilibration time
 369 c      if(usampl.and.totT.gt.eq_time) then
 370 c      write (iout,*) "usampl",usampl
 371       if(usampl) then
 372          call EconstrQ
 373          if (loc_qlike) then
 374            call Econstr_back_qlike
 375          else
 376            call Econstr_back
 377          endif
 378       else
 379          Uconst=0.0d0
 380          Uconst_back=0.0d0
 381       endif
 382 C 01/27/2015 added by adasko
 383 C the energy component below is energy transfer into lipid environment
 384 C based on partition function
 385 C      print *,"przed lipidami"
 386       if (wliptran.gt.0) then
 387         call Eliptransfer(eliptran)
 388       endif
 389 C      print *,"za lipidami"
 390       if (AFMlog.gt.0) then
 391         call AFMforce(Eafmforce)
 392       else if (selfguide.gt.0) then
 393         call AFMvel(Eafmforce)
 394       endif
 395       if (TUBElog.eq.1) then
 396 C      print *,"just before call"
 397         call calctube(Etube)
 398        elseif (TUBElog.eq.2) then
 399         call calctube2(Etube)
 400        else
 401        Etube=0.0d0
 402        endif
 403
 404 #ifdef TIMING
 405       time_enecalc=time_enecalc+MPI_Wtime()-time00
 406 #endif
 407 c      print *,"Processor",myrank," computed Uconstr"
 408 #ifdef TIMING
 409       time00=MPI_Wtime()
 410 #endif
 411 c
 412 C Sum the energies
 413 C
 414       energia(1)=evdw
 415 #ifdef SCP14
 416       energia(2)=evdw2-evdw2_14
 417       energia(18)=evdw2_14
 418 #else
 419       energia(2)=evdw2
 420       energia(18)=0.0d0
 421 #endif
 422 #ifdef SPLITELE
 423       energia(3)=ees
 424       energia(16)=evdw1
 425 #else
 426       energia(3)=ees+evdw1
 427       energia(16)=0.0d0
 428 #endif
 429       energia(4)=ecorr
 430       energia(5)=ecorr5
 431       energia(6)=ecorr6
 432       energia(7)=eel_loc
 433       energia(8)=eello_turn3
 434       energia(9)=eello_turn4
 435       energia(10)=eturn6
 436       energia(11)=ebe
 437       energia(12)=escloc
 438       energia(13)=etors
 439       energia(14)=etors_d
 440       energia(15)=ehpb
 441       energia(19)=edihcnstr
 442       energia(17)=estr
 443       energia(20)=Uconst+Uconst_back
 444       energia(21)=esccor
 445       energia(22)=eliptran
 446       energia(23)=Eafmforce
 447       energia(24)=ethetacnstr
 448       energia(25)=Etube
 449       energia(26)=Esaxs_constr
 450       energia(27)=ehomology_constr
 451       energia(28)=edfadis
 452       energia(29)=edfator
 453       energia(30)=edfanei
 454       energia(31)=edfabet
 455 c      write (iout,*) "esaxs_constr",energia(26)
 456 c    Here are the energies showed per procesor if the are more processors
 457 c    per molecule then we sum it up in sum_energy subroutine
 458 c      print *," Processor",myrank," calls SUM_ENERGY"
 459       call sum_energy(energia,.true.)
 460 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 461       if (dyn_ss) call dyn_set_nss
 462 c      print *," Processor",myrank," left SUM_ENERGY"
 463 #ifdef TIMING
 464       time_sumene=time_sumene+MPI_Wtime()-time00
 465 #endif
 466       return
 467       end
 468 c-------------------------------------------------------------------------------
 469       subroutine sum_energy(energia,reduce)
 470       implicit none
 471       include 'DIMENSIONS'
 472 #ifndef ISNAN
 473       external proc_proc
 474 #ifdef WINPGI
 475 cMS$ATTRIBUTES C ::  proc_proc
 476 #endif
 477 #endif
 478 #ifdef MPI
 479       include "mpif.h"
 480       integer ierr
 481       double precision time00
 482 #endif
 483       include 'COMMON.SETUP'
 484       include 'COMMON.IOUNITS'
 485       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 486       include 'COMMON.FFIELD'
 487       include 'COMMON.DERIV'
 488       include 'COMMON.INTERACT'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.CHAIN'
 491       include 'COMMON.VAR'
 492       include 'COMMON.CONTROL'
 493       include 'COMMON.TIME1'
 494       logical reduce
 495       integer i
 496       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 497      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 498      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 499      & eliptran,Eafmforce,Etube,
 500      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 501       double precision Uconst,etot
 502 #ifdef MPI
 503       if (nfgtasks.gt.1 .and. reduce) then
 504 #ifdef DEBUG
 505         write (iout,*) "energies before REDUCE"
 506         call enerprint(energia)
 507         call flush(iout)
 508 #endif
 509         do i=0,n_ene
 510           enebuff(i)=energia(i)
 511         enddo
 512         time00=MPI_Wtime()
 513         call MPI_Barrier(FG_COMM,IERR)
 514         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 515         time00=MPI_Wtime()
 516         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 517      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 518 #ifdef DEBUG
 519         write (iout,*) "energies after REDUCE"
 520         call enerprint(energia)
 521         call flush(iout)
 522 #endif
 523         time_Reduce=time_Reduce+MPI_Wtime()-time00
 524       endif
 525       if (fg_rank.eq.0) then
 526 #endif
 527       evdw=energia(1)
 528 #ifdef SCP14
 529       evdw2=energia(2)+energia(18)
 530       evdw2_14=energia(18)
 531 #else
 532       evdw2=energia(2)
 533 #endif
 534 #ifdef SPLITELE
 535       ees=energia(3)
 536       evdw1=energia(16)
 537 #else
 538       ees=energia(3)
 539       evdw1=0.0d0
 540 #endif
 541       ecorr=energia(4)
 542       ecorr5=energia(5)
 543       ecorr6=energia(6)
 544       eel_loc=energia(7)
 545       eello_turn3=energia(8)
 546       eello_turn4=energia(9)
 547       eturn6=energia(10)
 548       ebe=energia(11)
 549       escloc=energia(12)
 550       etors=energia(13)
 551       etors_d=energia(14)
 552       ehpb=energia(15)
 553       edihcnstr=energia(19)
 554       estr=energia(17)
 555       Uconst=energia(20)
 556       esccor=energia(21)
 557       eliptran=energia(22)
 558       Eafmforce=energia(23)
 559       ethetacnstr=energia(24)
 560       Etube=energia(25)
 561       esaxs_constr=energia(26)
 562       ehomology_constr=energia(27)
 563       edfadis=energia(28)
 564       edfator=energia(29)
 565       edfanei=energia(30)
 566       edfabet=energia(31)
 567 #ifdef SPLITELE
 568       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 569      & +wang*ebe+wtor*etors+wscloc*escloc
 570      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 571      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 572      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 573      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 574      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 575      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 576      & +wdfa_beta*edfabet
 577 #else
 578       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 579      & +wang*ebe+wtor*etors+wscloc*escloc
 580      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 581      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 582      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 583      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 584      & +Eafmforce
 585      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 586      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 587      & +wdfa_beta*edfabet
 588 #endif
 589       energia(0)=etot
 590 c detecting NaNQ
 591 #ifdef ISNAN
 592 #ifdef AIX
 593       if (isnan(etot).ne.0) energia(0)=1.0d+99
 594 #else
 595       if (isnan(etot)) energia(0)=1.0d+99
 596 #endif
 597 #else
 598       i=0
 599 #ifdef WINPGI
 600       idumm=proc_proc(etot,i)
 601 #else
 602       call proc_proc(etot,i)
 603 #endif
 604       if(i.eq.1)energia(0)=1.0d+99
 605 #endif
 606 #ifdef MPI
 607       endif
 608 #endif
 609       return
 610       end
 611 c-------------------------------------------------------------------------------
 612       subroutine sum_gradient
 613       implicit none
 614       include 'DIMENSIONS'
 615 #ifndef ISNAN
 616       external proc_proc
 617 #ifdef WINPGI
 618 cMS$ATTRIBUTES C ::  proc_proc
 619 #endif
 620 #endif
 621 #ifdef MPI
 622       include 'mpif.h'
 623       integer ierror,ierr
 624       double precision time00,time01
 625 #endif
 626       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 627      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 628      & ,gloc_scbuf(3,-1:maxres)
 629       include 'COMMON.SETUP'
 630       include 'COMMON.IOUNITS'
 631       include 'COMMON.FFIELD'
 632       include 'COMMON.DERIV'
 633       include 'COMMON.INTERACT'
 634       include 'COMMON.SBRIDGE'
 635       include 'COMMON.CHAIN'
 636       include 'COMMON.VAR'
 637       include 'COMMON.CONTROL'
 638       include 'COMMON.TIME1'
 639       include 'COMMON.MAXGRAD'
 640       include 'COMMON.SCCOR'
 641 c      include 'COMMON.MD'
 642       include 'COMMON.QRESTR'
 643       integer i,j,k
 644       double precision scalar
 645       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 646      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 647      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 648      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 649      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 650      &gsclocx_norm
 651 #ifdef TIMING
 652       time01=MPI_Wtime()
 653 #endif
 654 #ifdef DEBUG
 655       write (iout,*) "sum_gradient gvdwc, gvdwx"
 656       do i=1,nres
 657         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 658      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 659       enddo
 660       call flush(iout)
 661 #endif
 662 #ifdef DEBUG
 663       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 664       do i=0,nres
 665         write (iout,'(i3,3e15.5,5x,3e15.5)')
 666      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 667       enddo
 668       call flush(iout)
 669 #endif
 670 #ifdef MPI
 671 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 672         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 673      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 674 #endif
 675 C
 676 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 677 C            in virtual-bond-vector coordinates
 678 C
 679 #ifdef DEBUG
 680 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 681 c      do i=1,nres-1
 682 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 683 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 684 c      enddo
 685 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 686 c      do i=1,nres-1
 687 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 688 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 689 c      enddo
 690       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 691       do i=1,nres
 692         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 693      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 694      &   g_corr5_loc(i)
 695       enddo
 696       call flush(iout)
 697 #endif
 698 #ifdef DEBUG
 699       write (iout,*) "gsaxsc"
 700       do i=1,nres
 701         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 702       enddo
 703       call flush(iout)
 704 #endif
 705 #ifdef SPLITELE
 706       do i=0,nct
 707         do j=1,3
 708           gradbufc(j,i)=wsc*gvdwc(j,i)+
 709      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 710      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 711      &                wel_loc*gel_loc_long(j,i)+
 712      &                wcorr*gradcorr_long(j,i)+
 713      &                wcorr5*gradcorr5_long(j,i)+
 714      &                wcorr6*gradcorr6_long(j,i)+
 715      &                wturn6*gcorr6_turn_long(j,i)+
 716      &                wstrain*ghpbc(j,i)
 717      &                +wliptran*gliptranc(j,i)
 718      &                +gradafm(j,i)
 719      &                +welec*gshieldc(j,i)
 720      &                +wcorr*gshieldc_ec(j,i)
 721      &                +wturn3*gshieldc_t3(j,i)
 722      &                +wturn4*gshieldc_t4(j,i)
 723      &                +wel_loc*gshieldc_ll(j,i)
 724      &                +wtube*gg_tube(j,i)
 725      &                +wsaxs*gsaxsc(j,i)
 726         enddo
 727       enddo
 728 #else
 729       do i=0,nct
 730         do j=1,3
 731           gradbufc(j,i)=wsc*gvdwc(j,i)+
 732      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 733      &                welec*gelc_long(j,i)+
 734      &                wbond*gradb(j,i)+
 735      &                wel_loc*gel_loc_long(j,i)+
 736      &                wcorr*gradcorr_long(j,i)+
 737      &                wcorr5*gradcorr5_long(j,i)+
 738      &                wcorr6*gradcorr6_long(j,i)+
 739      &                wturn6*gcorr6_turn_long(j,i)+
 740      &                wstrain*ghpbc(j,i)
 741      &                +wliptran*gliptranc(j,i)
 742      &                +gradafm(j,i)
 743      &                 +welec*gshieldc(j,i)
 744      &                 +wcorr*gshieldc_ec(j,i)
 745      &                 +wturn4*gshieldc_t4(j,i)
 746      &                 +wel_loc*gshieldc_ll(j,i)
 747      &                +wtube*gg_tube(j,i)
 748      &                +wsaxs*gsaxsc(j,i)
 749         enddo
 750       enddo
 751 #endif
 752       do i=1,nct
 753         do j=1,3
 754           gradbufc(j,i)=gradbufc(j,i)+
 755      &                wdfa_dist*gdfad(j,i)+
 756      &                wdfa_tor*gdfat(j,i)+
 757      &                wdfa_nei*gdfan(j,i)+
 758      &                wdfa_beta*gdfab(j,i)
 759         enddo
 760       enddo
 761 #ifdef DEBUG
 762       write (iout,*) "gradc from gradbufc"
 763       do i=1,nres
 764         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 765       enddo
 766       call flush(iout)
 767 #endif
 768 #ifdef MPI
 769       if (nfgtasks.gt.1) then
 770       time00=MPI_Wtime()
 771 #ifdef DEBUG
 772       write (iout,*) "gradbufc before allreduce"
 773       do i=1,nres
 774         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 775       enddo
 776       call flush(iout)
 777 #endif
 778       do i=0,nres
 779         do j=1,3
 780           gradbufc_sum(j,i)=gradbufc(j,i)
 781         enddo
 782       enddo
 783 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 784 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 785 c      time_reduce=time_reduce+MPI_Wtime()-time00
 786 #ifdef DEBUG
 787 c      write (iout,*) "gradbufc_sum after allreduce"
 788 c      do i=1,nres
 789 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 790 c      enddo
 791 c      call flush(iout)
 792 #endif
 793 #ifdef TIMING
 794 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 795 #endif
 796       do i=nnt,nres
 797         do k=1,3
 798           gradbufc(k,i)=0.0d0
 799         enddo
 800       enddo
 801 #ifdef DEBUG
 802       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 803       write (iout,*) (i," jgrad_start",jgrad_start(i),
 804      &                  " jgrad_end  ",jgrad_end(i),
 805      &                  i=igrad_start,igrad_end)
 806 #endif
 807 c
 808 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 809 c do not parallelize this part.
 810 c
 811 c      do i=igrad_start,igrad_end
 812 c        do j=jgrad_start(i),jgrad_end(i)
 813 c          do k=1,3
 814 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 815 c          enddo
 816 c        enddo
 817 c      enddo
 818       do j=1,3
 819         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 820       enddo
 821       do i=nres-2,-1,-1
 822         do j=1,3
 823           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 824         enddo
 825       enddo
 826 #ifdef DEBUG
 827       write (iout,*) "gradbufc after summing"
 828       do i=1,nres
 829         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 830       enddo
 831       call flush(iout)
 832 #endif
 833       else
 834 #endif
 835 #ifdef DEBUG
 836       write (iout,*) "gradbufc"
 837       do i=1,nres
 838         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 839       enddo
 840       call flush(iout)
 841 #endif
 842       do i=-1,nres
 843         do j=1,3
 844           gradbufc_sum(j,i)=gradbufc(j,i)
 845           gradbufc(j,i)=0.0d0
 846         enddo
 847       enddo
 848       do j=1,3
 849         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 850       enddo
 851       do i=nres-2,-1,-1
 852         do j=1,3
 853           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 854         enddo
 855       enddo
 856 c      do i=nnt,nres-1
 857 c        do k=1,3
 858 c          gradbufc(k,i)=0.0d0
 859 c        enddo
 860 c        do j=i+1,nres
 861 c          do k=1,3
 862 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 863 c          enddo
 864 c        enddo
 865 c      enddo
 866 #ifdef DEBUG
 867       write (iout,*) "gradbufc after summing"
 868       do i=1,nres
 869         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 870       enddo
 871       call flush(iout)
 872 #endif
 873 #ifdef MPI
 874       endif
 875 #endif
 876       do k=1,3
 877         gradbufc(k,nres)=0.0d0
 878       enddo
 879       do i=-1,nct
 880         do j=1,3
 881 #ifdef SPLITELE
 882 C          print *,gradbufc(1,13)
 883 C          print *,welec*gelc(1,13)
 884 C          print *,wel_loc*gel_loc(1,13)
 885 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 886 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 887 C          print *,wel_loc*gel_loc_long(1,13)
 888 C          print *,gradafm(1,13),"AFM"
 889           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 890      &                wel_loc*gel_loc(j,i)+
 891      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 892      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 893      &                wel_loc*gel_loc_long(j,i)+
 894      &                wcorr*gradcorr_long(j,i)+
 895      &                wcorr5*gradcorr5_long(j,i)+
 896      &                wcorr6*gradcorr6_long(j,i)+
 897      &                wturn6*gcorr6_turn_long(j,i))+
 898      &                wbond*gradb(j,i)+
 899      &                wcorr*gradcorr(j,i)+
 900      &                wturn3*gcorr3_turn(j,i)+
 901      &                wturn4*gcorr4_turn(j,i)+
 902      &                wcorr5*gradcorr5(j,i)+
 903      &                wcorr6*gradcorr6(j,i)+
 904      &                wturn6*gcorr6_turn(j,i)+
 905      &                wsccor*gsccorc(j,i)
 906      &               +wscloc*gscloc(j,i)
 907      &               +wliptran*gliptranc(j,i)
 908      &                +gradafm(j,i)
 909      &                 +welec*gshieldc(j,i)
 910      &                 +welec*gshieldc_loc(j,i)
 911      &                 +wcorr*gshieldc_ec(j,i)
 912      &                 +wcorr*gshieldc_loc_ec(j,i)
 913      &                 +wturn3*gshieldc_t3(j,i)
 914      &                 +wturn3*gshieldc_loc_t3(j,i)
 915      &                 +wturn4*gshieldc_t4(j,i)
 916      &                 +wturn4*gshieldc_loc_t4(j,i)
 917      &                 +wel_loc*gshieldc_ll(j,i)
 918      &                 +wel_loc*gshieldc_loc_ll(j,i)
 919      &                +wtube*gg_tube(j,i)
 920
 921 #else
 922           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 923      &                wel_loc*gel_loc(j,i)+
 924      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 925      &                welec*gelc_long(j,i)+
 926      &                wel_loc*gel_loc_long(j,i)+
 927      &                wcorr*gcorr_long(j,i)+
 928      &                wcorr5*gradcorr5_long(j,i)+
 929      &                wcorr6*gradcorr6_long(j,i)+
 930      &                wturn6*gcorr6_turn_long(j,i))+
 931      &                wbond*gradb(j,i)+
 932      &                wcorr*gradcorr(j,i)+
 933      &                wturn3*gcorr3_turn(j,i)+
 934      &                wturn4*gcorr4_turn(j,i)+
 935      &                wcorr5*gradcorr5(j,i)+
 936      &                wcorr6*gradcorr6(j,i)+
 937      &                wturn6*gcorr6_turn(j,i)+
 938      &                wsccor*gsccorc(j,i)
 939      &               +wscloc*gscloc(j,i)
 940      &               +wliptran*gliptranc(j,i)
 941      &                +gradafm(j,i)
 942      &                 +welec*gshieldc(j,i)
 943      &                 +welec*gshieldc_loc(j,i)
 944      &                 +wcorr*gshieldc_ec(j,i)
 945      &                 +wcorr*gshieldc_loc_ec(j,i)
 946      &                 +wturn3*gshieldc_t3(j,i)
 947      &                 +wturn3*gshieldc_loc_t3(j,i)
 948      &                 +wturn4*gshieldc_t4(j,i)
 949      &                 +wturn4*gshieldc_loc_t4(j,i)
 950      &                 +wel_loc*gshieldc_ll(j,i)
 951      &                 +wel_loc*gshieldc_loc_ll(j,i)
 952      &                +wtube*gg_tube(j,i)
 953
 954
 955 #endif
 956           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 957      &                  wbond*gradbx(j,i)+
 958      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 959      &                  wsccor*gsccorx(j,i)
 960      &                 +wscloc*gsclocx(j,i)
 961      &                 +wliptran*gliptranx(j,i)
 962      &                 +welec*gshieldx(j,i)
 963      &                 +wcorr*gshieldx_ec(j,i)
 964      &                 +wturn3*gshieldx_t3(j,i)
 965      &                 +wturn4*gshieldx_t4(j,i)
 966      &                 +wel_loc*gshieldx_ll(j,i)
 967      &                 +wtube*gg_tube_sc(j,i)
 968      &                 +wsaxs*gsaxsx(j,i)
 969
 970
 971
 972         enddo
 973       enddo
 974       if (constr_homology.gt.0) then
 975         do i=1,nct
 976           do j=1,3
 977             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 978             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 979           enddo
 980         enddo
 981       endif
 982 #ifdef DEBUG
 983       write (iout,*) "gradc gradx gloc after adding"
 984       do i=1,nres
 985         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 986      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 987       enddo
 988 #endif
 989 #ifdef DEBUG
 990       write (iout,*) "gloc before adding corr"
 991       do i=1,4*nres
 992         write (iout,*) i,gloc(i,icg)
 993       enddo
 994 #endif
 995       do i=1,nres-3
 996         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 997      &   +wcorr5*g_corr5_loc(i)
 998      &   +wcorr6*g_corr6_loc(i)
 999      &   +wturn4*gel_loc_turn4(i)
1000      &   +wturn3*gel_loc_turn3(i)
1001      &   +wturn6*gel_loc_turn6(i)
1002      &   +wel_loc*gel_loc_loc(i)
1003       enddo
1004 #ifdef DEBUG
1005       write (iout,*) "gloc after adding corr"
1006       do i=1,4*nres
1007         write (iout,*) i,gloc(i,icg)
1008       enddo
1009 #endif
1010 #ifdef MPI
1011       if (nfgtasks.gt.1) then
1012         do j=1,3
1013           do i=1,nres
1014             gradbufc(j,i)=gradc(j,i,icg)
1015             gradbufx(j,i)=gradx(j,i,icg)
1016           enddo
1017         enddo
1018         do i=1,4*nres
1019           glocbuf(i)=gloc(i,icg)
1020         enddo
1021 c#define DEBUG
1022 #ifdef DEBUG
1023       write (iout,*) "gloc_sc before reduce"
1024       do i=1,nres
1025        do j=1,1
1026         write (iout,*) i,j,gloc_sc(j,i,icg)
1027        enddo
1028       enddo
1029 #endif
1030 c#undef DEBUG
1031         do i=1,nres
1032          do j=1,3
1033           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1034          enddo
1035         enddo
1036         time00=MPI_Wtime()
1037         call MPI_Barrier(FG_COMM,IERR)
1038         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1039         time00=MPI_Wtime()
1040         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1041      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1042         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1043      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1044         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1045      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1046         time_reduce=time_reduce+MPI_Wtime()-time00
1047         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1048      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1049         time_reduce=time_reduce+MPI_Wtime()-time00
1050 #ifdef DEBUG
1051       write (iout,*) "gradc after reduce"
1052       do i=1,nres
1053        do j=1,3
1054         write (iout,*) i,j,gradc(j,i,icg)
1055        enddo
1056       enddo
1057 #endif
1058 #ifdef DEBUG
1059       write (iout,*) "gloc_sc after reduce"
1060       do i=1,nres
1061        do j=1,1
1062         write (iout,*) i,j,gloc_sc(j,i,icg)
1063        enddo
1064       enddo
1065 #endif
1066 #ifdef DEBUG
1067       write (iout,*) "gloc after reduce"
1068       do i=1,4*nres
1069         write (iout,*) i,gloc(i,icg)
1070       enddo
1071 #endif
1072       endif
1073 #endif
1074       if (gnorm_check) then
1075 c
1076 c Compute the maximum elements of the gradient
1077 c
1078       gvdwc_max=0.0d0
1079       gvdwc_scp_max=0.0d0
1080       gelc_max=0.0d0
1081       gvdwpp_max=0.0d0
1082       gradb_max=0.0d0
1083       ghpbc_max=0.0d0
1084       gradcorr_max=0.0d0
1085       gel_loc_max=0.0d0
1086       gcorr3_turn_max=0.0d0
1087       gcorr4_turn_max=0.0d0
1088       gradcorr5_max=0.0d0
1089       gradcorr6_max=0.0d0
1090       gcorr6_turn_max=0.0d0
1091       gsccorrc_max=0.0d0
1092       gscloc_max=0.0d0
1093       gvdwx_max=0.0d0
1094       gradx_scp_max=0.0d0
1095       ghpbx_max=0.0d0
1096       gradxorr_max=0.0d0
1097       gsccorrx_max=0.0d0
1098       gsclocx_max=0.0d0
1099       do i=1,nct
1100         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1101         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1102         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1103         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1104      &   gvdwc_scp_max=gvdwc_scp_norm
1105         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1106         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1107         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1108         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1109         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1110         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1111         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1112         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1113         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1114         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1115         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1116         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1117         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1118      &    gcorr3_turn(1,i)))
1119         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1120      &    gcorr3_turn_max=gcorr3_turn_norm
1121         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1122      &    gcorr4_turn(1,i)))
1123         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1124      &    gcorr4_turn_max=gcorr4_turn_norm
1125         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1126         if (gradcorr5_norm.gt.gradcorr5_max)
1127      &    gradcorr5_max=gradcorr5_norm
1128         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1129         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1130         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1131      &    gcorr6_turn(1,i)))
1132         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1133      &    gcorr6_turn_max=gcorr6_turn_norm
1134         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1135         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1136         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1137         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1138         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1139         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1140         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1141         if (gradx_scp_norm.gt.gradx_scp_max)
1142      &    gradx_scp_max=gradx_scp_norm
1143         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1144         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1145         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1146         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1147         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1148         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1149         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1150         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1151       enddo
1152       if (gradout) then
1153 #if (defined AIX || defined CRAY)
1154         open(istat,file=statname,position="append")
1155 #else
1156         open(istat,file=statname,access="append")
1157 #endif
1158         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1159      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1160      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1161      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1162      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1163      &     gsccorrx_max,gsclocx_max
1164         close(istat)
1165         if (gvdwc_max.gt.1.0d4) then
1166           write (iout,*) "gvdwc gvdwx gradb gradbx"
1167           do i=nnt,nct
1168             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1169      &        gradb(j,i),gradbx(j,i),j=1,3)
1170           enddo
1171           call pdbout(0.0d0,'cipiszcze',iout)
1172           call flush(iout)
1173         endif
1174       endif
1175       endif
1176 #ifdef DEBUG
1177       write (iout,*) "gradc gradx gloc"
1178       do i=1,nres
1179         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1180      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1181       enddo
1182 #endif
1183 #ifdef TIMING
1184       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1185 #endif
1186       return
1187       end
1188 c-------------------------------------------------------------------------------
1189       subroutine rescale_weights(t_bath)
1190       implicit none
1191 #ifdef MPI
1192       include 'mpif.h'
1193       integer ierror
1194 #endif
1195       include 'DIMENSIONS'
1196       include 'COMMON.IOUNITS'
1197       include 'COMMON.FFIELD'
1198       include 'COMMON.SBRIDGE'
1199       include 'COMMON.CONTROL'
1200       double precision t_bath
1201       double precision facT,facT2,facT3,facT4,facT5
1202       double precision kfac /2.4d0/
1203       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1204 c      facT=temp0/t_bath
1205 c      facT=2*temp0/(t_bath+temp0)
1206       if (rescale_mode.eq.0) then
1207         facT=1.0d0
1208         facT2=1.0d0
1209         facT3=1.0d0
1210         facT4=1.0d0
1211         facT5=1.0d0
1212       else if (rescale_mode.eq.1) then
1213         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1214         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1215         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1216         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1217         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1218       else if (rescale_mode.eq.2) then
1219         x=t_bath/temp0
1220         x2=x*x
1221         x3=x2*x
1222         x4=x3*x
1223         x5=x4*x
1224         facT=licznik/dlog(dexp(x)+dexp(-x))
1225         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1226         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1227         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1228         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1229       else
1230         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1231         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1232 #ifdef MPI
1233        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1234 #endif
1235        stop 555
1236       endif
1237       if (shield_mode.gt.0) then
1238        wscp=weights(2)*fact
1239        wsc=weights(1)*fact
1240        wvdwpp=weights(16)*fact
1241       endif
1242       welec=weights(3)*fact
1243       wcorr=weights(4)*fact3
1244       wcorr5=weights(5)*fact4
1245       wcorr6=weights(6)*fact5
1246       wel_loc=weights(7)*fact2
1247       wturn3=weights(8)*fact2
1248       wturn4=weights(9)*fact3
1249       wturn6=weights(10)*fact5
1250       wtor=weights(13)*fact
1251       wtor_d=weights(14)*fact2
1252       wsccor=weights(21)*fact
1253       if (scale_umb) wumb=t_bath/temp0
1254 c      write (iout,*) "scale_umb",scale_umb
1255 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1256
1257       return
1258       end
1259 C------------------------------------------------------------------------
1260       subroutine enerprint(energia)
1261       implicit none
1262       include 'DIMENSIONS'
1263       include 'COMMON.IOUNITS'
1264       include 'COMMON.FFIELD'
1265       include 'COMMON.SBRIDGE'
1266       include 'COMMON.QRESTR'
1267       double precision energia(0:n_ene)
1268       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1269      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1270      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1271      & eello_turn6,
1272      & eliptran,Eafmforce,Etube,
1273      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1274       etot=energia(0)
1275       evdw=energia(1)
1276       evdw2=energia(2)
1277 #ifdef SCP14
1278       evdw2=energia(2)+energia(18)
1279 #else
1280       evdw2=energia(2)
1281 #endif
1282       ees=energia(3)
1283 #ifdef SPLITELE
1284       evdw1=energia(16)
1285 #endif
1286       ecorr=energia(4)
1287       ecorr5=energia(5)
1288       ecorr6=energia(6)
1289       eel_loc=energia(7)
1290       eello_turn3=energia(8)
1291       eello_turn4=energia(9)
1292       eello_turn6=energia(10)
1293       ebe=energia(11)
1294       escloc=energia(12)
1295       etors=energia(13)
1296       etors_d=energia(14)
1297       ehpb=energia(15)
1298       edihcnstr=energia(19)
1299       estr=energia(17)
1300       Uconst=energia(20)
1301       esccor=energia(21)
1302       eliptran=energia(22)
1303       Eafmforce=energia(23)
1304       ethetacnstr=energia(24)
1305       etube=energia(25)
1306       esaxs=energia(26)
1307       ehomology_constr=energia(27)
1308 C     Bartek
1309       edfadis = energia(28)
1310       edfator = energia(29)
1311       edfanei = energia(30)
1312       edfabet = energia(31)
1313 #ifdef SPLITELE
1314       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1315      &  estr,wbond,ebe,wang,
1316      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1317      &  ecorr,wcorr,
1318      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1319      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1320      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1321      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1322      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1323      &  edfabet,wdfa_beta,
1324      &  etot
1325    10 format (/'Virtual-chain energies:'//
1326      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1327      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1328      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1329      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1330      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1331      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1332      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1333      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1334      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1335      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1336      & ' (SS bridges & dist. cnstr.)'/
1337      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1338      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1339      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1340      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1341      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1342      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1343      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1344      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1345      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1346      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1347      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1348      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1349      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1350      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1351      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1352      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1353      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1354      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1355      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1356      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1357      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1358      & 'ETOT=  ',1pE16.6,' (total)')
1359
1360 #else
1361       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1362      &  estr,wbond,ebe,wang,
1363      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1364      &  ecorr,wcorr,
1365      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1366      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1367      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1368      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1369      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1370      &  edfabet,wdfa_beta,
1371      &  etot
1372    10 format (/'Virtual-chain energies:'//
1373      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1374      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1375      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1376      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1377      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1378      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1379      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1380      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1381      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1382      & ' (SS bridges & dist. restr.)'/
1383      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1384      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1385      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1386      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1387      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1388      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1389      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1390      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1391      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1392      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1393      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1394      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1395      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1396      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1397      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1398      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1399      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1400      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1401      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1402      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1403      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1404      & 'ETOT=  ',1pE16.6,' (total)')
1405 #endif
1406       return
1407       end
1408 C-----------------------------------------------------------------------
1409       subroutine elj(evdw)
1410 C
1411 C This subroutine calculates the interaction energy of nonbonded side chains
1412 C assuming the LJ potential of interaction.
1413 C
1414       implicit none
1415       double precision accur
1416       include 'DIMENSIONS'
1417       parameter (accur=1.0d-10)
1418       include 'COMMON.GEO'
1419       include 'COMMON.VAR'
1420       include 'COMMON.LOCAL'
1421       include 'COMMON.CHAIN'
1422       include 'COMMON.DERIV'
1423       include 'COMMON.INTERACT'
1424       include 'COMMON.TORSION'
1425       include 'COMMON.SBRIDGE'
1426       include 'COMMON.NAMES'
1427       include 'COMMON.IOUNITS'
1428       include 'COMMON.CONTACTS'
1429       double precision gg(3)
1430       double precision evdw,evdwij
1431       integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1432       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1433      & sigij,r0ij,rcut
1434       double precision fcont,fprimcont
1435 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1436       evdw=0.0D0
1437       do i=iatsc_s,iatsc_e
1438         itypi=iabs(itype(i))
1439         if (itypi.eq.ntyp1) cycle
1440         itypi1=iabs(itype(i+1))
1441         xi=c(1,nres+i)
1442         yi=c(2,nres+i)
1443         zi=c(3,nres+i)
1444 C Change 12/1/95
1445         num_conti=0
1446 C
1447 C Calculate SC interaction energy.
1448 C
1449         do iint=1,nint_gr(i)
1450 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1451 cd   &                  'iend=',iend(i,iint)
1452           do j=istart(i,iint),iend(i,iint)
1453             itypj=iabs(itype(j))
1454             if (itypj.eq.ntyp1) cycle
1455             xj=c(1,nres+j)-xi
1456             yj=c(2,nres+j)-yi
1457             zj=c(3,nres+j)-zi
1458 C Change 12/1/95 to calculate four-body interactions
1459             rij=xj*xj+yj*yj+zj*zj
1460             rrij=1.0D0/rij
1461 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1462             eps0ij=eps(itypi,itypj)
1463             fac=rrij**expon2
1464 C have you changed here?
1465             e1=fac*fac*aa
1466             e2=fac*bb
1467             evdwij=e1+e2
1468 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1469 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1470 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1471 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1472 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1473 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1474             evdw=evdw+evdwij
1475 C
1476 C Calculate the components of the gradient in DC and X
1477 C
1478             fac=-rrij*(e1+evdwij)
1479             gg(1)=xj*fac
1480             gg(2)=yj*fac
1481             gg(3)=zj*fac
1482             do k=1,3
1483               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1484               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1485               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1486               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1487             enddo
1488 cgrad            do k=i,j-1
1489 cgrad              do l=1,3
1490 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1491 cgrad              enddo
1492 cgrad            enddo
1493 C
1494 C 12/1/95, revised on 5/20/97
1495 C
1496 C Calculate the contact function. The ith column of the array JCONT will
1497 C contain the numbers of atoms that make contacts with the atom I (of numbers
1498 C greater than I). The arrays FACONT and GACONT will contain the values of
1499 C the contact function and its derivative.
1500 C
1501 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1502 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1503 C Uncomment next line, if the correlation interactions are contact function only
1504             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1505               rij=dsqrt(rij)
1506               sigij=sigma(itypi,itypj)
1507               r0ij=rs0(itypi,itypj)
1508 C
1509 C Check whether the SC's are not too far to make a contact.
1510 C
1511               rcut=1.5d0*r0ij
1512               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1513 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1514 C
1515               if (fcont.gt.0.0D0) then
1516 C If the SC-SC distance if close to sigma, apply spline.
1517 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1518 cAdam &             fcont1,fprimcont1)
1519 cAdam           fcont1=1.0d0-fcont1
1520 cAdam           if (fcont1.gt.0.0d0) then
1521 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1522 cAdam             fcont=fcont*fcont1
1523 cAdam           endif
1524 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1525 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1526 cga             do k=1,3
1527 cga               gg(k)=gg(k)*eps0ij
1528 cga             enddo
1529 cga             eps0ij=-evdwij*eps0ij
1530 C Uncomment for AL's type of SC correlation interactions.
1531 cadam           eps0ij=-evdwij
1532                 num_conti=num_conti+1
1533                 jcont(num_conti,i)=j
1534                 facont(num_conti,i)=fcont*eps0ij
1535                 fprimcont=eps0ij*fprimcont/rij
1536                 fcont=expon*fcont
1537 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1538 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1539 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1540 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1541                 gacont(1,num_conti,i)=-fprimcont*xj
1542                 gacont(2,num_conti,i)=-fprimcont*yj
1543                 gacont(3,num_conti,i)=-fprimcont*zj
1544 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1545 cd              write (iout,'(2i3,3f10.5)')
1546 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1547               endif
1548             endif
1549           enddo      ! j
1550         enddo        ! iint
1551 C Change 12/1/95
1552         num_cont(i)=num_conti
1553       enddo          ! i
1554       do i=1,nct
1555         do j=1,3
1556           gvdwc(j,i)=expon*gvdwc(j,i)
1557           gvdwx(j,i)=expon*gvdwx(j,i)
1558         enddo
1559       enddo
1560 C******************************************************************************
1561 C
1562 C                              N O T E !!!
1563 C
1564 C To save time, the factor of EXPON has been extracted from ALL components
1565 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1566 C use!
1567 C
1568 C******************************************************************************
1569       return
1570       end
1571 C-----------------------------------------------------------------------------
1572       subroutine eljk(evdw)
1573 C
1574 C This subroutine calculates the interaction energy of nonbonded side chains
1575 C assuming the LJK potential of interaction.
1576 C
1577       implicit none
1578       include 'DIMENSIONS'
1579       include 'COMMON.GEO'
1580       include 'COMMON.VAR'
1581       include 'COMMON.LOCAL'
1582       include 'COMMON.CHAIN'
1583       include 'COMMON.DERIV'
1584       include 'COMMON.INTERACT'
1585       include 'COMMON.IOUNITS'
1586       include 'COMMON.NAMES'
1587       double precision gg(3)
1588       double precision evdw,evdwij
1589       integer i,j,k,itypi,itypj,itypi1,iint
1590       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1591      & fac_augm,e_augm,r_inv_ij,r_shift_inv
1592       logical scheck
1593 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1594       evdw=0.0D0
1595       do i=iatsc_s,iatsc_e
1596         itypi=iabs(itype(i))
1597         if (itypi.eq.ntyp1) cycle
1598         itypi1=iabs(itype(i+1))
1599         xi=c(1,nres+i)
1600         yi=c(2,nres+i)
1601         zi=c(3,nres+i)
1602 C
1603 C Calculate SC interaction energy.
1604 C
1605         do iint=1,nint_gr(i)
1606           do j=istart(i,iint),iend(i,iint)
1607             itypj=iabs(itype(j))
1608             if (itypj.eq.ntyp1) cycle
1609             xj=c(1,nres+j)-xi
1610             yj=c(2,nres+j)-yi
1611             zj=c(3,nres+j)-zi
1612             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1613             fac_augm=rrij**expon
1614             e_augm=augm(itypi,itypj)*fac_augm
1615             r_inv_ij=dsqrt(rrij)
1616             rij=1.0D0/r_inv_ij
1617             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1618             fac=r_shift_inv**expon
1619 C have you changed here?
1620             e1=fac*fac*aa
1621             e2=fac*bb
1622             evdwij=e_augm+e1+e2
1623 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1624 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1625 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1626 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1627 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1628 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1629 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1630             evdw=evdw+evdwij
1631 C
1632 C Calculate the components of the gradient in DC and X
1633 C
1634             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1635             gg(1)=xj*fac
1636             gg(2)=yj*fac
1637             gg(3)=zj*fac
1638             do k=1,3
1639               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1640               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1641               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1642               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1643             enddo
1644 cgrad            do k=i,j-1
1645 cgrad              do l=1,3
1646 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1647 cgrad              enddo
1648 cgrad            enddo
1649           enddo      ! j
1650         enddo        ! iint
1651       enddo          ! i
1652       do i=1,nct
1653         do j=1,3
1654           gvdwc(j,i)=expon*gvdwc(j,i)
1655           gvdwx(j,i)=expon*gvdwx(j,i)
1656         enddo
1657       enddo
1658       return
1659       end
1660 C-----------------------------------------------------------------------------
1661       subroutine ebp(evdw)
1662 C
1663 C This subroutine calculates the interaction energy of nonbonded side chains
1664 C assuming the Berne-Pechukas potential of interaction.
1665 C
1666       implicit none
1667       include 'DIMENSIONS'
1668       include 'COMMON.GEO'
1669       include 'COMMON.VAR'
1670       include 'COMMON.LOCAL'
1671       include 'COMMON.CHAIN'
1672       include 'COMMON.DERIV'
1673       include 'COMMON.NAMES'
1674       include 'COMMON.INTERACT'
1675       include 'COMMON.IOUNITS'
1676       include 'COMMON.CALC'
1677       integer icall
1678       common /srutu/ icall
1679       double precision evdw
1680       integer itypi,itypj,itypi1,iint,ind
1681       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1682 c     double precision rrsave(maxdim)
1683       logical lprn
1684       evdw=0.0D0
1685 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1686       evdw=0.0D0
1687 c     if (icall.eq.0) then
1688 c       lprn=.true.
1689 c     else
1690         lprn=.false.
1691 c     endif
1692       ind=0
1693       do i=iatsc_s,iatsc_e
1694         itypi=iabs(itype(i))
1695         if (itypi.eq.ntyp1) cycle
1696         itypi1=iabs(itype(i+1))
1697         xi=c(1,nres+i)
1698         yi=c(2,nres+i)
1699         zi=c(3,nres+i)
1700         dxi=dc_norm(1,nres+i)
1701         dyi=dc_norm(2,nres+i)
1702         dzi=dc_norm(3,nres+i)
1703 c        dsci_inv=dsc_inv(itypi)
1704         dsci_inv=vbld_inv(i+nres)
1705 C
1706 C Calculate SC interaction energy.
1707 C
1708         do iint=1,nint_gr(i)
1709           do j=istart(i,iint),iend(i,iint)
1710             ind=ind+1
1711             itypj=iabs(itype(j))
1712             if (itypj.eq.ntyp1) cycle
1713 c            dscj_inv=dsc_inv(itypj)
1714             dscj_inv=vbld_inv(j+nres)
1715             chi1=chi(itypi,itypj)
1716             chi2=chi(itypj,itypi)
1717             chi12=chi1*chi2
1718             chip1=chip(itypi)
1719             chip2=chip(itypj)
1720             chip12=chip1*chip2
1721             alf1=alp(itypi)
1722             alf2=alp(itypj)
1723             alf12=0.5D0*(alf1+alf2)
1724 C For diagnostics only!!!
1725 c           chi1=0.0D0
1726 c           chi2=0.0D0
1727 c           chi12=0.0D0
1728 c           chip1=0.0D0
1729 c           chip2=0.0D0
1730 c           chip12=0.0D0
1731 c           alf1=0.0D0
1732 c           alf2=0.0D0
1733 c           alf12=0.0D0
1734             xj=c(1,nres+j)-xi
1735             yj=c(2,nres+j)-yi
1736             zj=c(3,nres+j)-zi
1737             dxj=dc_norm(1,nres+j)
1738             dyj=dc_norm(2,nres+j)
1739             dzj=dc_norm(3,nres+j)
1740             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1741 cd          if (icall.eq.0) then
1742 cd            rrsave(ind)=rrij
1743 cd          else
1744 cd            rrij=rrsave(ind)
1745 cd          endif
1746             rij=dsqrt(rrij)
1747 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1748             call sc_angular
1749 C Calculate whole angle-dependent part of epsilon and contributions
1750 C to its derivatives
1751 C have you changed here?
1752             fac=(rrij*sigsq)**expon2
1753             e1=fac*fac*aa
1754             e2=fac*bb
1755             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1756             eps2der=evdwij*eps3rt
1757             eps3der=evdwij*eps2rt
1758             evdwij=evdwij*eps2rt*eps3rt
1759             evdw=evdw+evdwij
1760             if (lprn) then
1761             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1762             epsi=bb**2/aa
1763 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1764 cd     &        restyp(itypi),i,restyp(itypj),j,
1765 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1766 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1767 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1768 cd     &        evdwij
1769             endif
1770 C Calculate gradient components.
1771             e1=e1*eps1*eps2rt**2*eps3rt**2
1772             fac=-expon*(e1+evdwij)
1773             sigder=fac/sigsq
1774             fac=rrij*fac
1775 C Calculate radial part of the gradient
1776             gg(1)=xj*fac
1777             gg(2)=yj*fac
1778             gg(3)=zj*fac
1779 C Calculate the angular part of the gradient and sum add the contributions
1780 C to the appropriate components of the Cartesian gradient.
1781             call sc_grad
1782           enddo      ! j
1783         enddo        ! iint
1784       enddo          ! i
1785 c     stop
1786       return
1787       end
1788 C-----------------------------------------------------------------------------
1789       subroutine egb(evdw)
1790 C
1791 C This subroutine calculates the interaction energy of nonbonded side chains
1792 C assuming the Gay-Berne potential of interaction.
1793 C
1794       implicit none
1795       include 'DIMENSIONS'
1796       include 'COMMON.GEO'
1797       include 'COMMON.VAR'
1798       include 'COMMON.LOCAL'
1799       include 'COMMON.CHAIN'
1800       include 'COMMON.DERIV'
1801       include 'COMMON.NAMES'
1802       include 'COMMON.INTERACT'
1803       include 'COMMON.IOUNITS'
1804       include 'COMMON.CALC'
1805       include 'COMMON.CONTROL'
1806       include 'COMMON.SPLITELE'
1807       include 'COMMON.SBRIDGE'
1808       logical lprn
1809       integer xshift,yshift,zshift,subchap
1810       double precision evdw
1811       integer itypi,itypj,itypi1,iint,ind
1812       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1813       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1814      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1815      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1816       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1817       evdw=0.0D0
1818 ccccc      energy_dec=.false.
1819 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1820       evdw=0.0D0
1821       lprn=.false.
1822 c     if (icall.eq.0) lprn=.false.
1823       ind=0
1824 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1825 C we have the original box)
1826 C      do xshift=-1,1
1827 C      do yshift=-1,1
1828 C      do zshift=-1,1
1829       do i=iatsc_s,iatsc_e
1830         itypi=iabs(itype(i))
1831         if (itypi.eq.ntyp1) cycle
1832         itypi1=iabs(itype(i+1))
1833         xi=c(1,nres+i)
1834         yi=c(2,nres+i)
1835         zi=c(3,nres+i)
1836 C Return atom into box, boxxsize is size of box in x dimension
1837 c  134   continue
1838 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1839 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1840 C Condition for being inside the proper box
1841 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1842 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1843 c        go to 134
1844 c        endif
1845 c  135   continue
1846 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1847 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1848 C Condition for being inside the proper box
1849 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1850 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1851 c        go to 135
1852 c        endif
1853 c  136   continue
1854 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1855 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1856 C Condition for being inside the proper box
1857 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1858 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1859 c        go to 136
1860 c        endif
1861           xi=mod(xi,boxxsize)
1862           if (xi.lt.0) xi=xi+boxxsize
1863           yi=mod(yi,boxysize)
1864           if (yi.lt.0) yi=yi+boxysize
1865           zi=mod(zi,boxzsize)
1866           if (zi.lt.0) zi=zi+boxzsize
1867 C define scaling factor for lipids
1868
1869 C        if (positi.le.0) positi=positi+boxzsize
1870 C        print *,i
1871 C first for peptide groups
1872 c for each residue check if it is in lipid or lipid water border area
1873        if ((zi.gt.bordlipbot)
1874      &.and.(zi.lt.bordliptop)) then
1875 C the energy transfer exist
1876         if (zi.lt.buflipbot) then
1877 C what fraction I am in
1878          fracinbuf=1.0d0-
1879      &        ((zi-bordlipbot)/lipbufthick)
1880 C lipbufthick is thickenes of lipid buffore
1881          sslipi=sscalelip(fracinbuf)
1882          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1883         elseif (zi.gt.bufliptop) then
1884          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1885          sslipi=sscalelip(fracinbuf)
1886          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1887         else
1888          sslipi=1.0d0
1889          ssgradlipi=0.0
1890         endif
1891        else
1892          sslipi=0.0d0
1893          ssgradlipi=0.0
1894        endif
1895
1896 C          xi=xi+xshift*boxxsize
1897 C          yi=yi+yshift*boxysize
1898 C          zi=zi+zshift*boxzsize
1899
1900         dxi=dc_norm(1,nres+i)
1901         dyi=dc_norm(2,nres+i)
1902         dzi=dc_norm(3,nres+i)
1903 c        dsci_inv=dsc_inv(itypi)
1904         dsci_inv=vbld_inv(i+nres)
1905 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1906 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1907 C
1908 C Calculate SC interaction energy.
1909 C
1910         do iint=1,nint_gr(i)
1911           do j=istart(i,iint),iend(i,iint)
1912             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1913
1914 c              write(iout,*) "PRZED ZWYKLE", evdwij
1915               call dyn_ssbond_ene(i,j,evdwij)
1916 c              write(iout,*) "PO ZWYKLE", evdwij
1917
1918               evdw=evdw+evdwij
1919               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1920      &                        'evdw',i,j,evdwij,' ss'
1921 C triple bond artifac removal
1922              do k=j+1,iend(i,iint)
1923 C search over all next residues
1924               if (dyn_ss_mask(k)) then
1925 C check if they are cysteins
1926 C              write(iout,*) 'k=',k
1927
1928 c              write(iout,*) "PRZED TRI", evdwij
1929                evdwij_przed_tri=evdwij
1930               call triple_ssbond_ene(i,j,k,evdwij)
1931 c               if(evdwij_przed_tri.ne.evdwij) then
1932 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1933 c               endif
1934
1935 c              write(iout,*) "PO TRI", evdwij
1936 C call the energy function that removes the artifical triple disulfide
1937 C bond the soubroutine is located in ssMD.F
1938               evdw=evdw+evdwij
1939               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1940      &                        'evdw',i,j,evdwij,'tss'
1941               endif!dyn_ss_mask(k)
1942              enddo! k
1943             ELSE
1944             ind=ind+1
1945             itypj=iabs(itype(j))
1946             if (itypj.eq.ntyp1) cycle
1947 c            dscj_inv=dsc_inv(itypj)
1948             dscj_inv=vbld_inv(j+nres)
1949 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1950 c     &       1.0d0/vbld(j+nres)
1951 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1952             sig0ij=sigma(itypi,itypj)
1953             chi1=chi(itypi,itypj)
1954             chi2=chi(itypj,itypi)
1955             chi12=chi1*chi2
1956             chip1=chip(itypi)
1957             chip2=chip(itypj)
1958             chip12=chip1*chip2
1959             alf1=alp(itypi)
1960             alf2=alp(itypj)
1961             alf12=0.5D0*(alf1+alf2)
1962 C For diagnostics only!!!
1963 c           chi1=0.0D0
1964 c           chi2=0.0D0
1965 c           chi12=0.0D0
1966 c           chip1=0.0D0
1967 c           chip2=0.0D0
1968 c           chip12=0.0D0
1969 c           alf1=0.0D0
1970 c           alf2=0.0D0
1971 c           alf12=0.0D0
1972             xj=c(1,nres+j)
1973             yj=c(2,nres+j)
1974             zj=c(3,nres+j)
1975 C Return atom J into box the original box
1976 c  137   continue
1977 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1978 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1979 C Condition for being inside the proper box
1980 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1981 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1982 c        go to 137
1983 c        endif
1984 c  138   continue
1985 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1986 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1987 C Condition for being inside the proper box
1988 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1989 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1990 c        go to 138
1991 c        endif
1992 c  139   continue
1993 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1994 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1995 C Condition for being inside the proper box
1996 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1997 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1998 c        go to 139
1999 c        endif
2000           xj=mod(xj,boxxsize)
2001           if (xj.lt.0) xj=xj+boxxsize
2002           yj=mod(yj,boxysize)
2003           if (yj.lt.0) yj=yj+boxysize
2004           zj=mod(zj,boxzsize)
2005           if (zj.lt.0) zj=zj+boxzsize
2006        if ((zj.gt.bordlipbot)
2007      &.and.(zj.lt.bordliptop)) then
2008 C the energy transfer exist
2009         if (zj.lt.buflipbot) then
2010 C what fraction I am in
2011          fracinbuf=1.0d0-
2012      &        ((zj-bordlipbot)/lipbufthick)
2013 C lipbufthick is thickenes of lipid buffore
2014          sslipj=sscalelip(fracinbuf)
2015          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2016         elseif (zj.gt.bufliptop) then
2017          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2018          sslipj=sscalelip(fracinbuf)
2019          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2020         else
2021          sslipj=1.0d0
2022          ssgradlipj=0.0
2023         endif
2024        else
2025          sslipj=0.0d0
2026          ssgradlipj=0.0
2027        endif
2028       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2029      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2030       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2031      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2032 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2033 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2034 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2035 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2036 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2037       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2038       xj_safe=xj
2039       yj_safe=yj
2040       zj_safe=zj
2041       subchap=0
2042       do xshift=-1,1
2043       do yshift=-1,1
2044       do zshift=-1,1
2045           xj=xj_safe+xshift*boxxsize
2046           yj=yj_safe+yshift*boxysize
2047           zj=zj_safe+zshift*boxzsize
2048           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2049           if(dist_temp.lt.dist_init) then
2050             dist_init=dist_temp
2051             xj_temp=xj
2052             yj_temp=yj
2053             zj_temp=zj
2054             subchap=1
2055           endif
2056        enddo
2057        enddo
2058        enddo
2059        if (subchap.eq.1) then
2060           xj=xj_temp-xi
2061           yj=yj_temp-yi
2062           zj=zj_temp-zi
2063        else
2064           xj=xj_safe-xi
2065           yj=yj_safe-yi
2066           zj=zj_safe-zi
2067        endif
2068             dxj=dc_norm(1,nres+j)
2069             dyj=dc_norm(2,nres+j)
2070             dzj=dc_norm(3,nres+j)
2071 C            xj=xj-xi
2072 C            yj=yj-yi
2073 C            zj=zj-zi
2074 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2075 c            write (iout,*) "j",j," dc_norm",
2076 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2077             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2078             rij=dsqrt(rrij)
2079             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2080             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2081
2082 c            write (iout,'(a7,4f8.3)')
2083 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2084             if (sss.gt.0.0d0) then
2085 C Calculate angle-dependent terms of energy and contributions to their
2086 C derivatives.
2087             call sc_angular
2088             sigsq=1.0D0/sigsq
2089             sig=sig0ij*dsqrt(sigsq)
2090             rij_shift=1.0D0/rij-sig+sig0ij
2091 c for diagnostics; uncomment
2092 c            rij_shift=1.2*sig0ij
2093 C I hate to put IF's in the loops, but here don't have another choice!!!!
2094             if (rij_shift.le.0.0D0) then
2095               evdw=1.0D20
2096 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2097 cd     &        restyp(itypi),i,restyp(itypj),j,
2098 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2099               return
2100             endif
2101             sigder=-sig*sigsq
2102 c---------------------------------------------------------------
2103             rij_shift=1.0D0/rij_shift
2104             fac=rij_shift**expon
2105 C here to start with
2106 C            if (c(i,3).gt.
2107             faclip=fac
2108             e1=fac*fac*aa
2109             e2=fac*bb
2110             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2111             eps2der=evdwij*eps3rt
2112             eps3der=evdwij*eps2rt
2113 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2114 C     &((sslipi+sslipj)/2.0d0+
2115 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2116 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2117 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2118             evdwij=evdwij*eps2rt*eps3rt
2119             evdw=evdw+evdwij*sss
2120             if (lprn) then
2121             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2122             epsi=bb**2/aa
2123             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2124      &        restyp(itypi),i,restyp(itypj),j,
2125      &        epsi,sigm,chi1,chi2,chip1,chip2,
2126      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2127      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2128      &        evdwij
2129             endif
2130
2131             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2132      &                        'evdw',i,j,evdwij
2133
2134 C Calculate gradient components.
2135             e1=e1*eps1*eps2rt**2*eps3rt**2
2136             fac=-expon*(e1+evdwij)*rij_shift
2137             sigder=fac*sigder
2138             fac=rij*fac
2139 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2140 c     &      evdwij,fac,sigma(itypi,itypj),expon
2141             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2142 c            fac=0.0d0
2143 C Calculate the radial part of the gradient
2144             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2145      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2146      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2147      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2148             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2149             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2150 C            gg_lipi(3)=0.0d0
2151 C            gg_lipj(3)=0.0d0
2152             gg(1)=xj*fac
2153             gg(2)=yj*fac
2154             gg(3)=zj*fac
2155 C Calculate angular part of the gradient.
2156             call sc_grad
2157             endif
2158             ENDIF    ! dyn_ss
2159           enddo      ! j
2160         enddo        ! iint
2161       enddo          ! i
2162 C      enddo          ! zshift
2163 C      enddo          ! yshift
2164 C      enddo          ! xshift
2165 c      write (iout,*) "Number of loop steps in EGB:",ind
2166 cccc      energy_dec=.false.
2167       return
2168       end
2169 C-----------------------------------------------------------------------------
2170       subroutine egbv(evdw)
2171 C
2172 C This subroutine calculates the interaction energy of nonbonded side chains
2173 C assuming the Gay-Berne-Vorobjev potential of interaction.
2174 C
2175       implicit none
2176       include 'DIMENSIONS'
2177       include 'COMMON.GEO'
2178       include 'COMMON.VAR'
2179       include 'COMMON.LOCAL'
2180       include 'COMMON.CHAIN'
2181       include 'COMMON.DERIV'
2182       include 'COMMON.NAMES'
2183       include 'COMMON.INTERACT'
2184       include 'COMMON.IOUNITS'
2185       include 'COMMON.CALC'
2186       integer xshift,yshift,zshift,subchap
2187       integer icall
2188       common /srutu/ icall
2189       logical lprn
2190       double precision evdw
2191       integer itypi,itypj,itypi1,iint,ind
2192       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2193      & xi,yi,zi,fac_augm,e_augm
2194       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2195      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2196      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
2197       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2198       evdw=0.0D0
2199 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2200       evdw=0.0D0
2201       lprn=.false.
2202 c     if (icall.eq.0) lprn=.true.
2203       ind=0
2204       do i=iatsc_s,iatsc_e
2205         itypi=iabs(itype(i))
2206         if (itypi.eq.ntyp1) cycle
2207         itypi1=iabs(itype(i+1))
2208         xi=c(1,nres+i)
2209         yi=c(2,nres+i)
2210         zi=c(3,nres+i)
2211           xi=mod(xi,boxxsize)
2212           if (xi.lt.0) xi=xi+boxxsize
2213           yi=mod(yi,boxysize)
2214           if (yi.lt.0) yi=yi+boxysize
2215           zi=mod(zi,boxzsize)
2216           if (zi.lt.0) zi=zi+boxzsize
2217 C define scaling factor for lipids
2218
2219 C        if (positi.le.0) positi=positi+boxzsize
2220 C        print *,i
2221 C first for peptide groups
2222 c for each residue check if it is in lipid or lipid water border area
2223        if ((zi.gt.bordlipbot)
2224      &.and.(zi.lt.bordliptop)) then
2225 C the energy transfer exist
2226         if (zi.lt.buflipbot) then
2227 C what fraction I am in
2228          fracinbuf=1.0d0-
2229      &        ((zi-bordlipbot)/lipbufthick)
2230 C lipbufthick is thickenes of lipid buffore
2231          sslipi=sscalelip(fracinbuf)
2232          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2233         elseif (zi.gt.bufliptop) then
2234          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2235          sslipi=sscalelip(fracinbuf)
2236          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2237         else
2238          sslipi=1.0d0
2239          ssgradlipi=0.0
2240         endif
2241        else
2242          sslipi=0.0d0
2243          ssgradlipi=0.0
2244        endif
2245
2246         dxi=dc_norm(1,nres+i)
2247         dyi=dc_norm(2,nres+i)
2248         dzi=dc_norm(3,nres+i)
2249 c        dsci_inv=dsc_inv(itypi)
2250         dsci_inv=vbld_inv(i+nres)
2251 C
2252 C Calculate SC interaction energy.
2253 C
2254         do iint=1,nint_gr(i)
2255           do j=istart(i,iint),iend(i,iint)
2256             ind=ind+1
2257             itypj=iabs(itype(j))
2258             if (itypj.eq.ntyp1) cycle
2259 c            dscj_inv=dsc_inv(itypj)
2260             dscj_inv=vbld_inv(j+nres)
2261             sig0ij=sigma(itypi,itypj)
2262             r0ij=r0(itypi,itypj)
2263             chi1=chi(itypi,itypj)
2264             chi2=chi(itypj,itypi)
2265             chi12=chi1*chi2
2266             chip1=chip(itypi)
2267             chip2=chip(itypj)
2268             chip12=chip1*chip2
2269             alf1=alp(itypi)
2270             alf2=alp(itypj)
2271             alf12=0.5D0*(alf1+alf2)
2272 C For diagnostics only!!!
2273 c           chi1=0.0D0
2274 c           chi2=0.0D0
2275 c           chi12=0.0D0
2276 c           chip1=0.0D0
2277 c           chip2=0.0D0
2278 c           chip12=0.0D0
2279 c           alf1=0.0D0
2280 c           alf2=0.0D0
2281 c           alf12=0.0D0
2282 C            xj=c(1,nres+j)-xi
2283 C            yj=c(2,nres+j)-yi
2284 C            zj=c(3,nres+j)-zi
2285           xj=mod(xj,boxxsize)
2286           if (xj.lt.0) xj=xj+boxxsize
2287           yj=mod(yj,boxysize)
2288           if (yj.lt.0) yj=yj+boxysize
2289           zj=mod(zj,boxzsize)
2290           if (zj.lt.0) zj=zj+boxzsize
2291        if ((zj.gt.bordlipbot)
2292      &.and.(zj.lt.bordliptop)) then
2293 C the energy transfer exist
2294         if (zj.lt.buflipbot) then
2295 C what fraction I am in
2296          fracinbuf=1.0d0-
2297      &        ((zj-bordlipbot)/lipbufthick)
2298 C lipbufthick is thickenes of lipid buffore
2299          sslipj=sscalelip(fracinbuf)
2300          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2301         elseif (zj.gt.bufliptop) then
2302          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2303          sslipj=sscalelip(fracinbuf)
2304          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2305         else
2306          sslipj=1.0d0
2307          ssgradlipj=0.0
2308         endif
2309        else
2310          sslipj=0.0d0
2311          ssgradlipj=0.0
2312        endif
2313       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2314      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2315       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2316      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2317 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2318 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2319 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2320       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2321       xj_safe=xj
2322       yj_safe=yj
2323       zj_safe=zj
2324       subchap=0
2325       do xshift=-1,1
2326       do yshift=-1,1
2327       do zshift=-1,1
2328           xj=xj_safe+xshift*boxxsize
2329           yj=yj_safe+yshift*boxysize
2330           zj=zj_safe+zshift*boxzsize
2331           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2332           if(dist_temp.lt.dist_init) then
2333             dist_init=dist_temp
2334             xj_temp=xj
2335             yj_temp=yj
2336             zj_temp=zj
2337             subchap=1
2338           endif
2339        enddo
2340        enddo
2341        enddo
2342        if (subchap.eq.1) then
2343           xj=xj_temp-xi
2344           yj=yj_temp-yi
2345           zj=zj_temp-zi
2346        else
2347           xj=xj_safe-xi
2348           yj=yj_safe-yi
2349           zj=zj_safe-zi
2350        endif
2351             dxj=dc_norm(1,nres+j)
2352             dyj=dc_norm(2,nres+j)
2353             dzj=dc_norm(3,nres+j)
2354             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2355             rij=dsqrt(rrij)
2356 C Calculate angle-dependent terms of energy and contributions to their
2357 C derivatives.
2358             call sc_angular
2359             sigsq=1.0D0/sigsq
2360             sig=sig0ij*dsqrt(sigsq)
2361             rij_shift=1.0D0/rij-sig+r0ij
2362 C I hate to put IF's in the loops, but here don't have another choice!!!!
2363             if (rij_shift.le.0.0D0) then
2364               evdw=1.0D20
2365               return
2366             endif
2367             sigder=-sig*sigsq
2368 c---------------------------------------------------------------
2369             rij_shift=1.0D0/rij_shift
2370             fac=rij_shift**expon
2371             e1=fac*fac*aa
2372             e2=fac*bb
2373             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2374             eps2der=evdwij*eps3rt
2375             eps3der=evdwij*eps2rt
2376             fac_augm=rrij**expon
2377             e_augm=augm(itypi,itypj)*fac_augm
2378             evdwij=evdwij*eps2rt*eps3rt
2379             evdw=evdw+evdwij+e_augm
2380             if (lprn) then
2381             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2382             epsi=bb**2/aa
2383             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2384      &        restyp(itypi),i,restyp(itypj),j,
2385      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2386      &        chi1,chi2,chip1,chip2,
2387      &        eps1,eps2rt**2,eps3rt**2,
2388      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2389      &        evdwij+e_augm
2390             endif
2391 C Calculate gradient components.
2392             e1=e1*eps1*eps2rt**2*eps3rt**2
2393             fac=-expon*(e1+evdwij)*rij_shift
2394             sigder=fac*sigder
2395             fac=rij*fac-2*expon*rrij*e_augm
2396             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2397 C Calculate the radial part of the gradient
2398             gg(1)=xj*fac
2399             gg(2)=yj*fac
2400             gg(3)=zj*fac
2401 C Calculate angular part of the gradient.
2402             call sc_grad
2403           enddo      ! j
2404         enddo        ! iint
2405       enddo          ! i
2406       end
2407 C-----------------------------------------------------------------------------
2408       subroutine sc_angular
2409 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2410 C om12. Called by ebp, egb, and egbv.
2411       implicit none
2412       include 'COMMON.CALC'
2413       include 'COMMON.IOUNITS'
2414       erij(1)=xj*rij
2415       erij(2)=yj*rij
2416       erij(3)=zj*rij
2417       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2418       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2419       om12=dxi*dxj+dyi*dyj+dzi*dzj
2420       chiom12=chi12*om12
2421 C Calculate eps1(om12) and its derivative in om12
2422       faceps1=1.0D0-om12*chiom12
2423       faceps1_inv=1.0D0/faceps1
2424       eps1=dsqrt(faceps1_inv)
2425 C Following variable is eps1*deps1/dom12
2426       eps1_om12=faceps1_inv*chiom12
2427 c diagnostics only
2428 c      faceps1_inv=om12
2429 c      eps1=om12
2430 c      eps1_om12=1.0d0
2431 c      write (iout,*) "om12",om12," eps1",eps1
2432 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2433 C and om12.
2434       om1om2=om1*om2
2435       chiom1=chi1*om1
2436       chiom2=chi2*om2
2437       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2438       sigsq=1.0D0-facsig*faceps1_inv
2439       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2440       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2441       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2442 c diagnostics only
2443 c      sigsq=1.0d0
2444 c      sigsq_om1=0.0d0
2445 c      sigsq_om2=0.0d0
2446 c      sigsq_om12=0.0d0
2447 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2448 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2449 c     &    " eps1",eps1
2450 C Calculate eps2 and its derivatives in om1, om2, and om12.
2451       chipom1=chip1*om1
2452       chipom2=chip2*om2
2453       chipom12=chip12*om12
2454       facp=1.0D0-om12*chipom12
2455       facp_inv=1.0D0/facp
2456       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2457 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2458 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2459 C Following variable is the square root of eps2
2460       eps2rt=1.0D0-facp1*facp_inv
2461 C Following three variables are the derivatives of the square root of eps
2462 C in om1, om2, and om12.
2463       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2464       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2465       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2466 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2467       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2468 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2469 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2470 c     &  " eps2rt_om12",eps2rt_om12
2471 C Calculate whole angle-dependent part of epsilon and contributions
2472 C to its derivatives
2473       return
2474       end
2475 C----------------------------------------------------------------------------
2476       subroutine sc_grad
2477       implicit real*8 (a-h,o-z)
2478       include 'DIMENSIONS'
2479       include 'COMMON.CHAIN'
2480       include 'COMMON.DERIV'
2481       include 'COMMON.CALC'
2482       include 'COMMON.IOUNITS'
2483       double precision dcosom1(3),dcosom2(3)
2484 cc      print *,'sss=',sss
2485       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2486       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2487       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2488      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2489 c diagnostics only
2490 c      eom1=0.0d0
2491 c      eom2=0.0d0
2492 c      eom12=evdwij*eps1_om12
2493 c end diagnostics
2494 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2495 c     &  " sigder",sigder
2496 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2497 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2498       do k=1,3
2499         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2500         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2501       enddo
2502       do k=1,3
2503         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2504       enddo
2505 c      write (iout,*) "gg",(gg(k),k=1,3)
2506       do k=1,3
2507         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2508      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2509      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2510         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2511      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2512      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2513 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2514 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2515 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2516 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2517       enddo
2518 C
2519 C Calculate the components of the gradient in DC and X
2520 C
2521 cgrad      do k=i,j-1
2522 cgrad        do l=1,3
2523 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2524 cgrad        enddo
2525 cgrad      enddo
2526       do l=1,3
2527         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2528         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2529       enddo
2530       return
2531       end
2532 C-----------------------------------------------------------------------
2533       subroutine e_softsphere(evdw)
2534 C
2535 C This subroutine calculates the interaction energy of nonbonded side chains
2536 C assuming the LJ potential of interaction.
2537 C
2538       implicit real*8 (a-h,o-z)
2539       include 'DIMENSIONS'
2540       parameter (accur=1.0d-10)
2541       include 'COMMON.GEO'
2542       include 'COMMON.VAR'
2543       include 'COMMON.LOCAL'
2544       include 'COMMON.CHAIN'
2545       include 'COMMON.DERIV'
2546       include 'COMMON.INTERACT'
2547       include 'COMMON.TORSION'
2548       include 'COMMON.SBRIDGE'
2549       include 'COMMON.NAMES'
2550       include 'COMMON.IOUNITS'
2551       include 'COMMON.CONTACTS'
2552       dimension gg(3)
2553 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2554       evdw=0.0D0
2555       do i=iatsc_s,iatsc_e
2556         itypi=iabs(itype(i))
2557         if (itypi.eq.ntyp1) cycle
2558         itypi1=iabs(itype(i+1))
2559         xi=c(1,nres+i)
2560         yi=c(2,nres+i)
2561         zi=c(3,nres+i)
2562 C
2563 C Calculate SC interaction energy.
2564 C
2565         do iint=1,nint_gr(i)
2566 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2567 cd   &                  'iend=',iend(i,iint)
2568           do j=istart(i,iint),iend(i,iint)
2569             itypj=iabs(itype(j))
2570             if (itypj.eq.ntyp1) cycle
2571             xj=c(1,nres+j)-xi
2572             yj=c(2,nres+j)-yi
2573             zj=c(3,nres+j)-zi
2574             rij=xj*xj+yj*yj+zj*zj
2575 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2576             r0ij=r0(itypi,itypj)
2577             r0ijsq=r0ij*r0ij
2578 c            print *,i,j,r0ij,dsqrt(rij)
2579             if (rij.lt.r0ijsq) then
2580               evdwij=0.25d0*(rij-r0ijsq)**2
2581               fac=rij-r0ijsq
2582             else
2583               evdwij=0.0d0
2584               fac=0.0d0
2585             endif
2586             evdw=evdw+evdwij
2587 C
2588 C Calculate the components of the gradient in DC and X
2589 C
2590             gg(1)=xj*fac
2591             gg(2)=yj*fac
2592             gg(3)=zj*fac
2593             do k=1,3
2594               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2595               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2596               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2597               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2598             enddo
2599 cgrad            do k=i,j-1
2600 cgrad              do l=1,3
2601 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2602 cgrad              enddo
2603 cgrad            enddo
2604           enddo ! j
2605         enddo ! iint
2606       enddo ! i
2607       return
2608       end
2609 C--------------------------------------------------------------------------
2610       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2611      &              eello_turn4)
2612 C
2613 C Soft-sphere potential of p-p interaction
2614 C
2615       implicit real*8 (a-h,o-z)
2616       include 'DIMENSIONS'
2617       include 'COMMON.CONTROL'
2618       include 'COMMON.IOUNITS'
2619       include 'COMMON.GEO'
2620       include 'COMMON.VAR'
2621       include 'COMMON.LOCAL'
2622       include 'COMMON.CHAIN'
2623       include 'COMMON.DERIV'
2624       include 'COMMON.INTERACT'
2625       include 'COMMON.CONTACTS'
2626       include 'COMMON.TORSION'
2627       include 'COMMON.VECTORS'
2628       include 'COMMON.FFIELD'
2629       dimension ggg(3)
2630       integer xshift,yshift,zshift
2631 C      write(iout,*) 'In EELEC_soft_sphere'
2632       ees=0.0D0
2633       evdw1=0.0D0
2634       eel_loc=0.0d0
2635       eello_turn3=0.0d0
2636       eello_turn4=0.0d0
2637       ind=0
2638       do i=iatel_s,iatel_e
2639         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2640         dxi=dc(1,i)
2641         dyi=dc(2,i)
2642         dzi=dc(3,i)
2643         xmedi=c(1,i)+0.5d0*dxi
2644         ymedi=c(2,i)+0.5d0*dyi
2645         zmedi=c(3,i)+0.5d0*dzi
2646           xmedi=mod(xmedi,boxxsize)
2647           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2648           ymedi=mod(ymedi,boxysize)
2649           if (ymedi.lt.0) ymedi=ymedi+boxysize
2650           zmedi=mod(zmedi,boxzsize)
2651           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2652         num_conti=0
2653 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2654         do j=ielstart(i),ielend(i)
2655           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2656           ind=ind+1
2657           iteli=itel(i)
2658           itelj=itel(j)
2659           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2660           r0ij=rpp(iteli,itelj)
2661           r0ijsq=r0ij*r0ij
2662           dxj=dc(1,j)
2663           dyj=dc(2,j)
2664           dzj=dc(3,j)
2665           xj=c(1,j)+0.5D0*dxj
2666           yj=c(2,j)+0.5D0*dyj
2667           zj=c(3,j)+0.5D0*dzj
2668           xj=mod(xj,boxxsize)
2669           if (xj.lt.0) xj=xj+boxxsize
2670           yj=mod(yj,boxysize)
2671           if (yj.lt.0) yj=yj+boxysize
2672           zj=mod(zj,boxzsize)
2673           if (zj.lt.0) zj=zj+boxzsize
2674       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2675       xj_safe=xj
2676       yj_safe=yj
2677       zj_safe=zj
2678       isubchap=0
2679       do xshift=-1,1
2680       do yshift=-1,1
2681       do zshift=-1,1
2682           xj=xj_safe+xshift*boxxsize
2683           yj=yj_safe+yshift*boxysize
2684           zj=zj_safe+zshift*boxzsize
2685           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2686           if(dist_temp.lt.dist_init) then
2687             dist_init=dist_temp
2688             xj_temp=xj
2689             yj_temp=yj
2690             zj_temp=zj
2691             isubchap=1
2692           endif
2693        enddo
2694        enddo
2695        enddo
2696        if (isubchap.eq.1) then
2697           xj=xj_temp-xmedi
2698           yj=yj_temp-ymedi
2699           zj=zj_temp-zmedi
2700        else
2701           xj=xj_safe-xmedi
2702           yj=yj_safe-ymedi
2703           zj=zj_safe-zmedi
2704        endif
2705           rij=xj*xj+yj*yj+zj*zj
2706             sss=sscale(sqrt(rij))
2707             sssgrad=sscagrad(sqrt(rij))
2708           if (rij.lt.r0ijsq) then
2709             evdw1ij=0.25d0*(rij-r0ijsq)**2
2710             fac=rij-r0ijsq
2711           else
2712             evdw1ij=0.0d0
2713             fac=0.0d0
2714           endif
2715           evdw1=evdw1+evdw1ij*sss
2716 C
2717 C Calculate contributions to the Cartesian gradient.
2718 C
2719           ggg(1)=fac*xj*sssgrad
2720           ggg(2)=fac*yj*sssgrad
2721           ggg(3)=fac*zj*sssgrad
2722           do k=1,3
2723             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2724             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2725           enddo
2726 *
2727 * Loop over residues i+1 thru j-1.
2728 *
2729 cgrad          do k=i+1,j-1
2730 cgrad            do l=1,3
2731 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2732 cgrad            enddo
2733 cgrad          enddo
2734         enddo ! j
2735       enddo   ! i
2736 cgrad      do i=nnt,nct-1
2737 cgrad        do k=1,3
2738 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2739 cgrad        enddo
2740 cgrad        do j=i+1,nct-1
2741 cgrad          do k=1,3
2742 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2743 cgrad          enddo
2744 cgrad        enddo
2745 cgrad      enddo
2746       return
2747       end
2748 c------------------------------------------------------------------------------
2749       subroutine vec_and_deriv
2750       implicit real*8 (a-h,o-z)
2751       include 'DIMENSIONS'
2752 #ifdef MPI
2753       include 'mpif.h'
2754 #endif
2755       include 'COMMON.IOUNITS'
2756       include 'COMMON.GEO'
2757       include 'COMMON.VAR'
2758       include 'COMMON.LOCAL'
2759       include 'COMMON.CHAIN'
2760       include 'COMMON.VECTORS'
2761       include 'COMMON.SETUP'
2762       include 'COMMON.TIME1'
2763       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2764 C Compute the local reference systems. For reference system (i), the
2765 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2766 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2767 #ifdef PARVEC
2768       do i=ivec_start,ivec_end
2769 #else
2770       do i=1,nres-1
2771 #endif
2772           if (i.eq.nres-1) then
2773 C Case of the last full residue
2774 C Compute the Z-axis
2775             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2776             costh=dcos(pi-theta(nres))
2777             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2778             do k=1,3
2779               uz(k,i)=fac*uz(k,i)
2780             enddo
2781 C Compute the derivatives of uz
2782             uzder(1,1,1)= 0.0d0
2783             uzder(2,1,1)=-dc_norm(3,i-1)
2784             uzder(3,1,1)= dc_norm(2,i-1)
2785             uzder(1,2,1)= dc_norm(3,i-1)
2786             uzder(2,2,1)= 0.0d0
2787             uzder(3,2,1)=-dc_norm(1,i-1)
2788             uzder(1,3,1)=-dc_norm(2,i-1)
2789             uzder(2,3,1)= dc_norm(1,i-1)
2790             uzder(3,3,1)= 0.0d0
2791             uzder(1,1,2)= 0.0d0
2792             uzder(2,1,2)= dc_norm(3,i)
2793             uzder(3,1,2)=-dc_norm(2,i)
2794             uzder(1,2,2)=-dc_norm(3,i)
2795             uzder(2,2,2)= 0.0d0
2796             uzder(3,2,2)= dc_norm(1,i)
2797             uzder(1,3,2)= dc_norm(2,i)
2798             uzder(2,3,2)=-dc_norm(1,i)
2799             uzder(3,3,2)= 0.0d0
2800 C Compute the Y-axis
2801             facy=fac
2802             do k=1,3
2803               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2804             enddo
2805 C Compute the derivatives of uy
2806             do j=1,3
2807               do k=1,3
2808                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2809      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2810                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2811               enddo
2812               uyder(j,j,1)=uyder(j,j,1)-costh
2813               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2814             enddo
2815             do j=1,2
2816               do k=1,3
2817                 do l=1,3
2818                   uygrad(l,k,j,i)=uyder(l,k,j)
2819                   uzgrad(l,k,j,i)=uzder(l,k,j)
2820                 enddo
2821               enddo
2822             enddo
2823             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2824             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2825             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2826             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2827           else
2828 C Other residues
2829 C Compute the Z-axis
2830             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2831             costh=dcos(pi-theta(i+2))
2832             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2833             do k=1,3
2834               uz(k,i)=fac*uz(k,i)
2835             enddo
2836 C Compute the derivatives of uz
2837             uzder(1,1,1)= 0.0d0
2838             uzder(2,1,1)=-dc_norm(3,i+1)
2839             uzder(3,1,1)= dc_norm(2,i+1)
2840             uzder(1,2,1)= dc_norm(3,i+1)
2841             uzder(2,2,1)= 0.0d0
2842             uzder(3,2,1)=-dc_norm(1,i+1)
2843             uzder(1,3,1)=-dc_norm(2,i+1)
2844             uzder(2,3,1)= dc_norm(1,i+1)
2845             uzder(3,3,1)= 0.0d0
2846             uzder(1,1,2)= 0.0d0
2847             uzder(2,1,2)= dc_norm(3,i)
2848             uzder(3,1,2)=-dc_norm(2,i)
2849             uzder(1,2,2)=-dc_norm(3,i)
2850             uzder(2,2,2)= 0.0d0
2851             uzder(3,2,2)= dc_norm(1,i)
2852             uzder(1,3,2)= dc_norm(2,i)
2853             uzder(2,3,2)=-dc_norm(1,i)
2854             uzder(3,3,2)= 0.0d0
2855 C Compute the Y-axis
2856             facy=fac
2857             do k=1,3
2858               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2859             enddo
2860 C Compute the derivatives of uy
2861             do j=1,3
2862               do k=1,3
2863                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2864      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2865                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2866               enddo
2867               uyder(j,j,1)=uyder(j,j,1)-costh
2868               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2869             enddo
2870             do j=1,2
2871               do k=1,3
2872                 do l=1,3
2873                   uygrad(l,k,j,i)=uyder(l,k,j)
2874                   uzgrad(l,k,j,i)=uzder(l,k,j)
2875                 enddo
2876               enddo
2877             enddo
2878             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2879             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2880             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2881             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2882           endif
2883       enddo
2884       do i=1,nres-1
2885         vbld_inv_temp(1)=vbld_inv(i+1)
2886         if (i.lt.nres-1) then
2887           vbld_inv_temp(2)=vbld_inv(i+2)
2888           else
2889           vbld_inv_temp(2)=vbld_inv(i)
2890           endif
2891         do j=1,2
2892           do k=1,3
2893             do l=1,3
2894               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2895               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2896             enddo
2897           enddo
2898         enddo
2899       enddo
2900 #if defined(PARVEC) && defined(MPI)
2901       if (nfgtasks1.gt.1) then
2902         time00=MPI_Wtime()
2903 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2904 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2905 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2906         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2907      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2908      &   FG_COMM1,IERR)
2909         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2910      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2911      &   FG_COMM1,IERR)
2912         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2913      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2914      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2915         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2916      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2917      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2918         time_gather=time_gather+MPI_Wtime()-time00
2919       endif
2920 #endif
2921 #ifdef DEBUG
2922       if (fg_rank.eq.0) then
2923         write (iout,*) "Arrays UY and UZ"
2924         do i=1,nres-1
2925           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2926      &     (uz(k,i),k=1,3)
2927         enddo
2928       endif
2929 #endif
2930       return
2931       end
2932 C--------------------------------------------------------------------------
2933       subroutine set_matrices
2934       implicit real*8 (a-h,o-z)
2935       include 'DIMENSIONS'
2936 #ifdef MPI
2937       include "mpif.h"
2938       include "COMMON.SETUP"
2939       integer IERR
2940       integer status(MPI_STATUS_SIZE)
2941 #endif
2942       include 'COMMON.IOUNITS'
2943       include 'COMMON.GEO'
2944       include 'COMMON.VAR'
2945       include 'COMMON.LOCAL'
2946       include 'COMMON.CHAIN'
2947       include 'COMMON.DERIV'
2948       include 'COMMON.INTERACT'
2949       include 'COMMON.CONTACTS'
2950       include 'COMMON.TORSION'
2951       include 'COMMON.VECTORS'
2952       include 'COMMON.FFIELD'
2953       double precision auxvec(2),auxmat(2,2)
2954 C
2955 C Compute the virtual-bond-torsional-angle dependent quantities needed
2956 C to calculate the el-loc multibody terms of various order.
2957 C
2958 c      write(iout,*) 'nphi=',nphi,nres
2959 c      write(iout,*) "itype2loc",itype2loc
2960 #ifdef PARMAT
2961       do i=ivec_start+2,ivec_end+2
2962 #else
2963       do i=3,nres+1
2964 #endif
2965         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2966           iti = itype2loc(itype(i-2))
2967         else
2968           iti=nloctyp
2969         endif
2970 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2971         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2972           iti1 = itype2loc(itype(i-1))
2973         else
2974           iti1=nloctyp
2975         endif
2976         write(iout,*),"i",i,i-2," iti",iti," iti1",iti1
2977 #ifdef NEWCORR
2978         cost1=dcos(theta(i-1))
2979         sint1=dsin(theta(i-1))
2980         sint1sq=sint1*sint1
2981         sint1cub=sint1sq*sint1
2982         sint1cost1=2*sint1*cost1
2983 c        write (iout,*) "bnew1",i,iti
2984 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2985 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2986 c        write (iout,*) "bnew2",i,iti
2987 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2988 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2989         do k=1,2
2990           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2991           b1(k,i-2)=sint1*b1k
2992           gtb1(k,i-2)=cost1*b1k-sint1sq*
2993      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2994           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2995           b2(k,i-2)=sint1*b2k
2996           gtb2(k,i-2)=cost1*b2k-sint1sq*
2997      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2998         enddo
2999         do k=1,2
3000           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3001           cc(1,k,i-2)=sint1sq*aux
3002           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3003      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3004           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3005           dd(1,k,i-2)=sint1sq*aux
3006           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3007      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3008         enddo
3009         cc(2,1,i-2)=cc(1,2,i-2)
3010         cc(2,2,i-2)=-cc(1,1,i-2)
3011         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3012         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3013         dd(2,1,i-2)=dd(1,2,i-2)
3014         dd(2,2,i-2)=-dd(1,1,i-2)
3015         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3016         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3017         do k=1,2
3018           do l=1,2
3019             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3020             EE(l,k,i-2)=sint1sq*aux
3021             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3022           enddo
3023         enddo
3024         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3025         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3026         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3027         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3028         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3029         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3030         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3031 c        b1tilde(1,i-2)=b1(1,i-2)
3032 c        b1tilde(2,i-2)=-b1(2,i-2)
3033 c        b2tilde(1,i-2)=b2(1,i-2)
3034 c        b2tilde(2,i-2)=-b2(2,i-2)
3035 #ifdef DEBUG
3036         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3037         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3038         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3039         write (iout,*) 'theta=', theta(i-1)
3040 #endif
3041 #else
3042         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3043           iti = itype2loc(itype(i-2))
3044         else
3045           iti=nloctyp
3046         endif
3047 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3048 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3049         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3050           iti1 = itype2loc(itype(i-1))
3051         else
3052           iti1=nloctyp
3053         endif
3054         b1(1,i-2)=b(3,iti)
3055         b1(2,i-2)=b(5,iti)
3056         b2(1,i-2)=b(2,iti)
3057         b2(2,i-2)=b(4,iti)
3058         do k=1,2
3059           do l=1,2
3060            CC(k,l,i-2)=ccold(k,l,iti)
3061            DD(k,l,i-2)=ddold(k,l,iti)
3062            EE(k,l,i-2)=eeold(k,l,iti)
3063            gtEE(k,l,i-2)=0.0d0
3064           enddo
3065         enddo
3066 #endif
3067         b1tilde(1,i-2)= b1(1,i-2)
3068         b1tilde(2,i-2)=-b1(2,i-2)
3069         b2tilde(1,i-2)= b2(1,i-2)
3070         b2tilde(2,i-2)=-b2(2,i-2)
3071 c
3072         Ctilde(1,1,i-2)= CC(1,1,i-2)
3073         Ctilde(1,2,i-2)= CC(1,2,i-2)
3074         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3075         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3076 c
3077         Dtilde(1,1,i-2)= DD(1,1,i-2)
3078         Dtilde(1,2,i-2)= DD(1,2,i-2)
3079         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3080         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3081 #ifdef DEBUG
3082         write(iout,*) "i",i," iti",iti
3083         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3084         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3085 #endif
3086       enddo
3087 #ifdef PARMAT
3088       do i=ivec_start+2,ivec_end+2
3089 #else
3090       do i=3,nres+1
3091 #endif
3092         if (i .lt. nres+1) then
3093           sin1=dsin(phi(i))
3094           cos1=dcos(phi(i))
3095           sintab(i-2)=sin1
3096           costab(i-2)=cos1
3097           obrot(1,i-2)=cos1
3098           obrot(2,i-2)=sin1
3099           sin2=dsin(2*phi(i))
3100           cos2=dcos(2*phi(i))
3101           sintab2(i-2)=sin2
3102           costab2(i-2)=cos2
3103           obrot2(1,i-2)=cos2
3104           obrot2(2,i-2)=sin2
3105           Ug(1,1,i-2)=-cos1
3106           Ug(1,2,i-2)=-sin1
3107           Ug(2,1,i-2)=-sin1
3108           Ug(2,2,i-2)= cos1
3109           Ug2(1,1,i-2)=-cos2
3110           Ug2(1,2,i-2)=-sin2
3111           Ug2(2,1,i-2)=-sin2
3112           Ug2(2,2,i-2)= cos2
3113         else
3114           costab(i-2)=1.0d0
3115           sintab(i-2)=0.0d0
3116           obrot(1,i-2)=1.0d0
3117           obrot(2,i-2)=0.0d0
3118           obrot2(1,i-2)=0.0d0
3119           obrot2(2,i-2)=0.0d0
3120           Ug(1,1,i-2)=1.0d0
3121           Ug(1,2,i-2)=0.0d0
3122           Ug(2,1,i-2)=0.0d0
3123           Ug(2,2,i-2)=1.0d0
3124           Ug2(1,1,i-2)=0.0d0
3125           Ug2(1,2,i-2)=0.0d0
3126           Ug2(2,1,i-2)=0.0d0
3127           Ug2(2,2,i-2)=0.0d0
3128         endif
3129         if (i .gt. 3 .and. i .lt. nres+1) then
3130           obrot_der(1,i-2)=-sin1
3131           obrot_der(2,i-2)= cos1
3132           Ugder(1,1,i-2)= sin1
3133           Ugder(1,2,i-2)=-cos1
3134           Ugder(2,1,i-2)=-cos1
3135           Ugder(2,2,i-2)=-sin1
3136           dwacos2=cos2+cos2
3137           dwasin2=sin2+sin2
3138           obrot2_der(1,i-2)=-dwasin2
3139           obrot2_der(2,i-2)= dwacos2
3140           Ug2der(1,1,i-2)= dwasin2
3141           Ug2der(1,2,i-2)=-dwacos2
3142           Ug2der(2,1,i-2)=-dwacos2
3143           Ug2der(2,2,i-2)=-dwasin2
3144         else
3145           obrot_der(1,i-2)=0.0d0
3146           obrot_der(2,i-2)=0.0d0
3147           Ugder(1,1,i-2)=0.0d0
3148           Ugder(1,2,i-2)=0.0d0
3149           Ugder(2,1,i-2)=0.0d0
3150           Ugder(2,2,i-2)=0.0d0
3151           obrot2_der(1,i-2)=0.0d0
3152           obrot2_der(2,i-2)=0.0d0
3153           Ug2der(1,1,i-2)=0.0d0
3154           Ug2der(1,2,i-2)=0.0d0
3155           Ug2der(2,1,i-2)=0.0d0
3156           Ug2der(2,2,i-2)=0.0d0
3157         endif
3158 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3159         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3160           iti = itype2loc(itype(i-2))
3161         else
3162           iti=nloctyp
3163         endif
3164 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3165         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3166           iti1 = itype2loc(itype(i-1))
3167         else
3168           iti1=nloctyp
3169         endif
3170 cd        write (iout,*) '*******i',i,' iti1',iti
3171 cd        write (iout,*) 'b1',b1(:,iti)
3172 cd        write (iout,*) 'b2',b2(:,iti)
3173 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3174 c        if (i .gt. iatel_s+2) then
3175         if (i .gt. nnt+2) then
3176           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3177 #ifdef NEWCORR
3178           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3179 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3180 #endif
3181 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3182 c     &    EE(1,2,iti),EE(2,2,i)
3183           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3184           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3185 c          write(iout,*) "Macierz EUG",
3186 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3187 c     &    eug(2,2,i-2)
3188           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3189      &    then
3190           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3191           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3192           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3193           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3194           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3195           endif
3196         else
3197           do k=1,2
3198             Ub2(k,i-2)=0.0d0
3199             Ctobr(k,i-2)=0.0d0
3200             Dtobr2(k,i-2)=0.0d0
3201             do l=1,2
3202               EUg(l,k,i-2)=0.0d0
3203               CUg(l,k,i-2)=0.0d0
3204               DUg(l,k,i-2)=0.0d0
3205               DtUg2(l,k,i-2)=0.0d0
3206             enddo
3207           enddo
3208         endif
3209         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3210         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3211         do k=1,2
3212           muder(k,i-2)=Ub2der(k,i-2)
3213         enddo
3214 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3215         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3216           if (itype(i-1).le.ntyp) then
3217             iti1 = itype2loc(itype(i-1))
3218           else
3219             iti1=nloctyp
3220           endif
3221         else
3222           iti1=nloctyp
3223         endif
3224         do k=1,2
3225           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3226 c          mu(k,i-2)=b1(k,i-1)
3227 c          mu(k,i-2)=Ub2(k,i-2)
3228         enddo
3229 #define MUOUT
3230 #ifdef MUOUT
3231         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3232      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3233      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3234      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3235      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3236      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3237 #endif
3238 #undef MUOUT
3239 cd        write (iout,*) 'mu1',mu1(:,i-2)
3240 cd        write (iout,*) 'mu2',mu2(:,i-2)
3241 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3242         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3243      &  then
3244         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3245         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3246         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3247         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3248         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3249 C Vectors and matrices dependent on a single virtual-bond dihedral.
3250         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3251         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3252         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3253         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3254         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3255         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3256         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3257         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3258         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3259         endif
3260       enddo
3261 C Matrices dependent on two consecutive virtual-bond dihedrals.
3262 C The order of matrices is from left to right.
3263       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3264      &then
3265 c      do i=max0(ivec_start,2),ivec_end
3266       do i=2,nres-1
3267         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3268         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3269         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3270         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3271         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3272         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3273         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3274         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3275       enddo
3276       endif
3277 #if defined(MPI) && defined(PARMAT)
3278 #ifdef DEBUG
3279 c      if (fg_rank.eq.0) then
3280         write (iout,*) "Arrays UG and UGDER before GATHER"
3281         do i=1,nres-1
3282           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3283      &     ((ug(l,k,i),l=1,2),k=1,2),
3284      &     ((ugder(l,k,i),l=1,2),k=1,2)
3285         enddo
3286         write (iout,*) "Arrays UG2 and UG2DER"
3287         do i=1,nres-1
3288           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3289      &     ((ug2(l,k,i),l=1,2),k=1,2),
3290      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3291         enddo
3292         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3293         do i=1,nres-1
3294           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3295      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3296      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3297         enddo
3298         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3299         do i=1,nres-1
3300           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3301      &     costab(i),sintab(i),costab2(i),sintab2(i)
3302         enddo
3303         write (iout,*) "Array MUDER"
3304         do i=1,nres-1
3305           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3306         enddo
3307 c      endif
3308 #endif
3309       if (nfgtasks.gt.1) then
3310         time00=MPI_Wtime()
3311 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3312 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3313 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3314 #ifdef MATGATHER
3315         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3316      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3317      &   FG_COMM1,IERR)
3318         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3319      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3320      &   FG_COMM1,IERR)
3321         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3322      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3323      &   FG_COMM1,IERR)
3324         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3325      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3326      &   FG_COMM1,IERR)
3327         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3328      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3329      &   FG_COMM1,IERR)
3330         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3331      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3332      &   FG_COMM1,IERR)
3333         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3334      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3335      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3336         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3337      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3338      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3339         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3340      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3341      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3342         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3343      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3344      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3345         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3346      &  then
3347         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3348      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3349      &   FG_COMM1,IERR)
3350         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3351      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3352      &   FG_COMM1,IERR)
3353         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3354      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3355      &   FG_COMM1,IERR)
3356        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3357      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3358      &   FG_COMM1,IERR)
3359         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3360      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3361      &   FG_COMM1,IERR)
3362         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3363      &   ivec_count(fg_rank1),
3364      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3365      &   FG_COMM1,IERR)
3366         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3367      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3368      &   FG_COMM1,IERR)
3369         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3370      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3371      &   FG_COMM1,IERR)
3372         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3373      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3374      &   FG_COMM1,IERR)
3375         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3376      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3377      &   FG_COMM1,IERR)
3378         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3379      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3380      &   FG_COMM1,IERR)
3381         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3382      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3383      &   FG_COMM1,IERR)
3384         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3385      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3386      &   FG_COMM1,IERR)
3387         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3388      &   ivec_count(fg_rank1),
3389      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3390      &   FG_COMM1,IERR)
3391         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3392      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3393      &   FG_COMM1,IERR)
3394        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3395      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3396      &   FG_COMM1,IERR)
3397         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3398      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3399      &   FG_COMM1,IERR)
3400        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3401      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3402      &   FG_COMM1,IERR)
3403         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3404      &   ivec_count(fg_rank1),
3405      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3406      &   FG_COMM1,IERR)
3407         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3408      &   ivec_count(fg_rank1),
3409      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3410      &   FG_COMM1,IERR)
3411         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3412      &   ivec_count(fg_rank1),
3413      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3414      &   MPI_MAT2,FG_COMM1,IERR)
3415         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3416      &   ivec_count(fg_rank1),
3417      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3418      &   MPI_MAT2,FG_COMM1,IERR)
3419         endif
3420 #else
3421 c Passes matrix info through the ring
3422       isend=fg_rank1
3423       irecv=fg_rank1-1
3424       if (irecv.lt.0) irecv=nfgtasks1-1
3425       iprev=irecv
3426       inext=fg_rank1+1
3427       if (inext.ge.nfgtasks1) inext=0
3428       do i=1,nfgtasks1-1
3429 c        write (iout,*) "isend",isend," irecv",irecv
3430 c        call flush(iout)
3431         lensend=lentyp(isend)
3432         lenrecv=lentyp(irecv)
3433 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3434 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3435 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3436 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3437 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3438 c        write (iout,*) "Gather ROTAT1"
3439 c        call flush(iout)
3440 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3441 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3442 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3443 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3444 c        write (iout,*) "Gather ROTAT2"
3445 c        call flush(iout)
3446         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3447      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3448      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3449      &   iprev,4400+irecv,FG_COMM,status,IERR)
3450 c        write (iout,*) "Gather ROTAT_OLD"
3451 c        call flush(iout)
3452         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3453      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3454      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3455      &   iprev,5500+irecv,FG_COMM,status,IERR)
3456 c        write (iout,*) "Gather PRECOMP11"
3457 c        call flush(iout)
3458         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3459      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3460      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3461      &   iprev,6600+irecv,FG_COMM,status,IERR)
3462 c        write (iout,*) "Gather PRECOMP12"
3463 c        call flush(iout)
3464         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3465      &  then
3466         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3467      &   MPI_ROTAT2(lensend),inext,7700+isend,
3468      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3469      &   iprev,7700+irecv,FG_COMM,status,IERR)
3470 c        write (iout,*) "Gather PRECOMP21"
3471 c        call flush(iout)
3472         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3473      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3474      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3475      &   iprev,8800+irecv,FG_COMM,status,IERR)
3476 c        write (iout,*) "Gather PRECOMP22"
3477 c        call flush(iout)
3478         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3479      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3480      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3481      &   MPI_PRECOMP23(lenrecv),
3482      &   iprev,9900+irecv,FG_COMM,status,IERR)
3483 c        write (iout,*) "Gather PRECOMP23"
3484 c        call flush(iout)
3485         endif
3486         isend=irecv
3487         irecv=irecv-1
3488         if (irecv.lt.0) irecv=nfgtasks1-1
3489       enddo
3490 #endif
3491         time_gather=time_gather+MPI_Wtime()-time00
3492       endif
3493 #ifdef DEBUG
3494 c      if (fg_rank.eq.0) then
3495         write (iout,*) "Arrays UG and UGDER"
3496         do i=1,nres-1
3497           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3498      &     ((ug(l,k,i),l=1,2),k=1,2),
3499      &     ((ugder(l,k,i),l=1,2),k=1,2)
3500         enddo
3501         write (iout,*) "Arrays UG2 and UG2DER"
3502         do i=1,nres-1
3503           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3504      &     ((ug2(l,k,i),l=1,2),k=1,2),
3505      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3506         enddo
3507         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3508         do i=1,nres-1
3509           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3510      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3511      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3512         enddo
3513         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3514         do i=1,nres-1
3515           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3516      &     costab(i),sintab(i),costab2(i),sintab2(i)
3517         enddo
3518         write (iout,*) "Array MUDER"
3519         do i=1,nres-1
3520           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3521         enddo
3522 c      endif
3523 #endif
3524 #endif
3525 cd      do i=1,nres
3526 cd        iti = itype2loc(itype(i))
3527 cd        write (iout,*) i
3528 cd        do j=1,2
3529 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3530 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3531 cd        enddo
3532 cd      enddo
3533       return
3534       end
3535 C-----------------------------------------------------------------------------
3536       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3537 C
3538 C This subroutine calculates the average interaction energy and its gradient
3539 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3540 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3541 C The potential depends both on the distance of peptide-group centers and on
3542 C the orientation of the CA-CA virtual bonds.
3543 C
3544       implicit real*8 (a-h,o-z)
3545 #ifdef MPI
3546       include 'mpif.h'
3547 #endif
3548       include 'DIMENSIONS'
3549       include 'COMMON.CONTROL'
3550       include 'COMMON.SETUP'
3551       include 'COMMON.IOUNITS'
3552       include 'COMMON.GEO'
3553       include 'COMMON.VAR'
3554       include 'COMMON.LOCAL'
3555       include 'COMMON.CHAIN'
3556       include 'COMMON.DERIV'
3557       include 'COMMON.INTERACT'
3558       include 'COMMON.CONTACTS'
3559       include 'COMMON.TORSION'
3560       include 'COMMON.VECTORS'
3561       include 'COMMON.FFIELD'
3562       include 'COMMON.TIME1'
3563       include 'COMMON.SPLITELE'
3564       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3565      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3566       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3567      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3568       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3569      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3570      &    num_conti,j1,j2
3571 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3572 #ifdef MOMENT
3573       double precision scal_el /1.0d0/
3574 #else
3575       double precision scal_el /0.5d0/
3576 #endif
3577 C 12/13/98
3578 C 13-go grudnia roku pamietnego...
3579       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3580      &                   0.0d0,1.0d0,0.0d0,
3581      &                   0.0d0,0.0d0,1.0d0/
3582 cd      write(iout,*) 'In EELEC'
3583 cd      do i=1,nloctyp
3584 cd        write(iout,*) 'Type',i
3585 cd        write(iout,*) 'B1',B1(:,i)
3586 cd        write(iout,*) 'B2',B2(:,i)
3587 cd        write(iout,*) 'CC',CC(:,:,i)
3588 cd        write(iout,*) 'DD',DD(:,:,i)
3589 cd        write(iout,*) 'EE',EE(:,:,i)
3590 cd      enddo
3591 cd      call check_vecgrad
3592 cd      stop
3593       if (icheckgrad.eq.1) then
3594         do i=1,nres-1
3595           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3596           do k=1,3
3597             dc_norm(k,i)=dc(k,i)*fac
3598           enddo
3599 c          write (iout,*) 'i',i,' fac',fac
3600         enddo
3601       endif
3602       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3603      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3604      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3605 c        call vec_and_deriv
3606 #ifdef TIMING
3607         time01=MPI_Wtime()
3608 #endif
3609         call set_matrices
3610 #ifdef TIMING
3611         time_mat=time_mat+MPI_Wtime()-time01
3612 #endif
3613       endif
3614 cd      do i=1,nres-1
3615 cd        write (iout,*) 'i=',i
3616 cd        do k=1,3
3617 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3618 cd        enddo
3619 cd        do k=1,3
3620 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3621 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3622 cd        enddo
3623 cd      enddo
3624       t_eelecij=0.0d0
3625       ees=0.0D0
3626       evdw1=0.0D0
3627       eel_loc=0.0d0
3628       eello_turn3=0.0d0
3629       eello_turn4=0.0d0
3630       ind=0
3631       do i=1,nres
3632         num_cont_hb(i)=0
3633       enddo
3634 cd      print '(a)','Enter EELEC'
3635 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3636       do i=1,nres
3637         gel_loc_loc(i)=0.0d0
3638         gcorr_loc(i)=0.0d0
3639       enddo
3640 c
3641 c
3642 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3643 C
3644 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3645 C
3646 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3647       do i=iturn3_start,iturn3_end
3648 c        if (i.le.1) cycle
3649 C        write(iout,*) "tu jest i",i
3650         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3651 C changes suggested by Ana to avoid out of bounds
3652 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3653 c     & .or.((i+4).gt.nres)
3654 c     & .or.((i-1).le.0)
3655 C end of changes by Ana
3656      &  .or. itype(i+2).eq.ntyp1
3657      &  .or. itype(i+3).eq.ntyp1) cycle
3658 C Adam: Instructions below will switch off existing interactions
3659 c        if(i.gt.1)then
3660 c          if(itype(i-1).eq.ntyp1)cycle
3661 c        end if
3662 c        if(i.LT.nres-3)then
3663 c          if (itype(i+4).eq.ntyp1) cycle
3664 c        end if
3665         dxi=dc(1,i)
3666         dyi=dc(2,i)
3667         dzi=dc(3,i)
3668         dx_normi=dc_norm(1,i)
3669         dy_normi=dc_norm(2,i)
3670         dz_normi=dc_norm(3,i)
3671         xmedi=c(1,i)+0.5d0*dxi
3672         ymedi=c(2,i)+0.5d0*dyi
3673         zmedi=c(3,i)+0.5d0*dzi
3674           xmedi=mod(xmedi,boxxsize)
3675           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3676           ymedi=mod(ymedi,boxysize)
3677           if (ymedi.lt.0) ymedi=ymedi+boxysize
3678           zmedi=mod(zmedi,boxzsize)
3679           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3680         num_conti=0
3681         call eelecij(i,i+2,ees,evdw1,eel_loc)
3682         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3683         num_cont_hb(i)=num_conti
3684       enddo
3685       do i=iturn4_start,iturn4_end
3686         if (i.lt.1) cycle
3687         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3688 C changes suggested by Ana to avoid out of bounds
3689 c     & .or.((i+5).gt.nres)
3690 c     & .or.((i-1).le.0)
3691 C end of changes suggested by Ana
3692      &    .or. itype(i+3).eq.ntyp1
3693      &    .or. itype(i+4).eq.ntyp1
3694 c     &    .or. itype(i+5).eq.ntyp1
3695 c     &    .or. itype(i).eq.ntyp1
3696 c     &    .or. itype(i-1).eq.ntyp1
3697      &                             ) cycle
3698         dxi=dc(1,i)
3699         dyi=dc(2,i)
3700         dzi=dc(3,i)
3701         dx_normi=dc_norm(1,i)
3702         dy_normi=dc_norm(2,i)
3703         dz_normi=dc_norm(3,i)
3704         xmedi=c(1,i)+0.5d0*dxi
3705         ymedi=c(2,i)+0.5d0*dyi
3706         zmedi=c(3,i)+0.5d0*dzi
3707 C Return atom into box, boxxsize is size of box in x dimension
3708 c  194   continue
3709 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3710 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3711 C Condition for being inside the proper box
3712 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3713 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3714 c        go to 194
3715 c        endif
3716 c  195   continue
3717 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3718 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3719 C Condition for being inside the proper box
3720 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3721 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3722 c        go to 195
3723 c        endif
3724 c  196   continue
3725 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3726 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3727 C Condition for being inside the proper box
3728 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3729 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3730 c        go to 196
3731 c        endif
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
3739         num_conti=num_cont_hb(i)
3740 c        write(iout,*) "JESTEM W PETLI"
3741         call eelecij(i,i+3,ees,evdw1,eel_loc)
3742         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3743      &   call eturn4(i,eello_turn4)
3744         num_cont_hb(i)=num_conti
3745       enddo   ! i
3746 C Loop over all neighbouring boxes
3747 C      do xshift=-1,1
3748 C      do yshift=-1,1
3749 C      do zshift=-1,1
3750 c
3751 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3752 c
3753 CTU KURWA
3754       do i=iatel_s,iatel_e
3755 C        do i=75,75
3756 c        if (i.le.1) cycle
3757         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3758 C changes suggested by Ana to avoid out of bounds
3759 c     & .or.((i+2).gt.nres)
3760 c     & .or.((i-1).le.0)
3761 C end of changes by Ana
3762 c     &  .or. itype(i+2).eq.ntyp1
3763 c     &  .or. itype(i-1).eq.ntyp1
3764      &                ) cycle
3765         dxi=dc(1,i)
3766         dyi=dc(2,i)
3767         dzi=dc(3,i)
3768         dx_normi=dc_norm(1,i)
3769         dy_normi=dc_norm(2,i)
3770         dz_normi=dc_norm(3,i)
3771         xmedi=c(1,i)+0.5d0*dxi
3772         ymedi=c(2,i)+0.5d0*dyi
3773         zmedi=c(3,i)+0.5d0*dzi
3774           xmedi=mod(xmedi,boxxsize)
3775           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3776           ymedi=mod(ymedi,boxysize)
3777           if (ymedi.lt.0) ymedi=ymedi+boxysize
3778           zmedi=mod(zmedi,boxzsize)
3779           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3780 C          xmedi=xmedi+xshift*boxxsize
3781 C          ymedi=ymedi+yshift*boxysize
3782 C          zmedi=zmedi+zshift*boxzsize
3783
3784 C Return tom into box, boxxsize is size of box in x dimension
3785 c  164   continue
3786 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3787 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3788 C Condition for being inside the proper box
3789 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3790 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3791 c        go to 164
3792 c        endif
3793 c  165   continue
3794 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3795 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3796 C Condition for being inside the proper box
3797 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3798 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3799 c        go to 165
3800 c        endif
3801 c  166   continue
3802 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3803 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3804 cC Condition for being inside the proper box
3805 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3806 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3807 c        go to 166
3808 c        endif
3809
3810 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3811         num_conti=num_cont_hb(i)
3812 C I TU KURWA
3813         do j=ielstart(i),ielend(i)
3814 C          do j=16,17
3815 C          write (iout,*) i,j
3816 C         if (j.le.1) cycle
3817           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3818 C changes suggested by Ana to avoid out of bounds
3819 c     & .or.((j+2).gt.nres)
3820 c     & .or.((j-1).le.0)
3821 C end of changes by Ana
3822 c     & .or.itype(j+2).eq.ntyp1
3823 c     & .or.itype(j-1).eq.ntyp1
3824      &) cycle
3825           call eelecij(i,j,ees,evdw1,eel_loc)
3826         enddo ! j
3827         num_cont_hb(i)=num_conti
3828       enddo   ! i
3829 C     enddo   ! zshift
3830 C      enddo   ! yshift
3831 C      enddo   ! xshift
3832
3833 c      write (iout,*) "Number of loop steps in EELEC:",ind
3834 cd      do i=1,nres
3835 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3836 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3837 cd      enddo
3838 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3839 ccc      eel_loc=eel_loc+eello_turn3
3840 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3841       return
3842       end
3843 C-------------------------------------------------------------------------------
3844       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3845       implicit real*8 (a-h,o-z)
3846       include 'DIMENSIONS'
3847 #ifdef MPI
3848       include "mpif.h"
3849 #endif
3850       include 'COMMON.CONTROL'
3851       include 'COMMON.IOUNITS'
3852       include 'COMMON.GEO'
3853       include 'COMMON.VAR'
3854       include 'COMMON.LOCAL'
3855       include 'COMMON.CHAIN'
3856       include 'COMMON.DERIV'
3857       include 'COMMON.INTERACT'
3858       include 'COMMON.CONTACTS'
3859       include 'COMMON.TORSION'
3860       include 'COMMON.VECTORS'
3861       include 'COMMON.FFIELD'
3862       include 'COMMON.TIME1'
3863       include 'COMMON.SPLITELE'
3864       include 'COMMON.SHIELD'
3865       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3866      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3867       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3868      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3869      &    gmuij2(4),gmuji2(4)
3870       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3871      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3872      &    num_conti,j1,j2
3873 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3874 #ifdef MOMENT
3875       double precision scal_el /1.0d0/
3876 #else
3877       double precision scal_el /0.5d0/
3878 #endif
3879 C 12/13/98
3880 C 13-go grudnia roku pamietnego...
3881       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3882      &                   0.0d0,1.0d0,0.0d0,
3883      &                   0.0d0,0.0d0,1.0d0/
3884        integer xshift,yshift,zshift
3885 c          time00=MPI_Wtime()
3886 cd      write (iout,*) "eelecij",i,j
3887 c          ind=ind+1
3888           iteli=itel(i)
3889           itelj=itel(j)
3890           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3891           aaa=app(iteli,itelj)
3892           bbb=bpp(iteli,itelj)
3893           ael6i=ael6(iteli,itelj)
3894           ael3i=ael3(iteli,itelj)
3895           dxj=dc(1,j)
3896           dyj=dc(2,j)
3897           dzj=dc(3,j)
3898           dx_normj=dc_norm(1,j)
3899           dy_normj=dc_norm(2,j)
3900           dz_normj=dc_norm(3,j)
3901 C          xj=c(1,j)+0.5D0*dxj-xmedi
3902 C          yj=c(2,j)+0.5D0*dyj-ymedi
3903 C          zj=c(3,j)+0.5D0*dzj-zmedi
3904           xj=c(1,j)+0.5D0*dxj
3905           yj=c(2,j)+0.5D0*dyj
3906           zj=c(3,j)+0.5D0*dzj
3907           xj=mod(xj,boxxsize)
3908           if (xj.lt.0) xj=xj+boxxsize
3909           yj=mod(yj,boxysize)
3910           if (yj.lt.0) yj=yj+boxysize
3911           zj=mod(zj,boxzsize)
3912           if (zj.lt.0) zj=zj+boxzsize
3913           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3914       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3915       xj_safe=xj
3916       yj_safe=yj
3917       zj_safe=zj
3918       isubchap=0
3919       do xshift=-1,1
3920       do yshift=-1,1
3921       do zshift=-1,1
3922           xj=xj_safe+xshift*boxxsize
3923           yj=yj_safe+yshift*boxysize
3924           zj=zj_safe+zshift*boxzsize
3925           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3926           if(dist_temp.lt.dist_init) then
3927             dist_init=dist_temp
3928             xj_temp=xj
3929             yj_temp=yj
3930             zj_temp=zj
3931             isubchap=1
3932           endif
3933        enddo
3934        enddo
3935        enddo
3936        if (isubchap.eq.1) then
3937           xj=xj_temp-xmedi
3938           yj=yj_temp-ymedi
3939           zj=zj_temp-zmedi
3940        else
3941           xj=xj_safe-xmedi
3942           yj=yj_safe-ymedi
3943           zj=zj_safe-zmedi
3944        endif
3945 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3946 c  174   continue
3947 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3948 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3949 C Condition for being inside the proper box
3950 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3951 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3952 c        go to 174
3953 c        endif
3954 c  175   continue
3955 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3956 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3957 C Condition for being inside the proper box
3958 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3959 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3960 c        go to 175
3961 c        endif
3962 c  176   continue
3963 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3964 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3965 C Condition for being inside the proper box
3966 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3967 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3968 c        go to 176
3969 c        endif
3970 C        endif !endPBC condintion
3971 C        xj=xj-xmedi
3972 C        yj=yj-ymedi
3973 C        zj=zj-zmedi
3974           rij=xj*xj+yj*yj+zj*zj
3975
3976             sss=sscale(sqrt(rij))
3977             sssgrad=sscagrad(sqrt(rij))
3978 c            if (sss.gt.0.0d0) then
3979           rrmij=1.0D0/rij
3980           rij=dsqrt(rij)
3981           rmij=1.0D0/rij
3982           r3ij=rrmij*rmij
3983           r6ij=r3ij*r3ij
3984           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3985           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3986           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3987           fac=cosa-3.0D0*cosb*cosg
3988           ev1=aaa*r6ij*r6ij
3989 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3990           if (j.eq.i+2) ev1=scal_el*ev1
3991           ev2=bbb*r6ij
3992           fac3=ael6i*r6ij
3993           fac4=ael3i*r3ij
3994           evdwij=(ev1+ev2)
3995           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3996           el2=fac4*fac
3997 C MARYSIA
3998 C          eesij=(el1+el2)
3999 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4000           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4001           if (shield_mode.gt.0) then
4002 C          fac_shield(i)=0.4
4003 C          fac_shield(j)=0.6
4004           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4005           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4006           eesij=(el1+el2)
4007           ees=ees+eesij
4008           else
4009           fac_shield(i)=1.0
4010           fac_shield(j)=1.0
4011           eesij=(el1+el2)
4012           ees=ees+eesij
4013           endif
4014           evdw1=evdw1+evdwij*sss
4015 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4016 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4017 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4018 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4019
4020           if (energy_dec) then
4021               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4022      &'evdw1',i,j,evdwij
4023      &,iteli,itelj,aaa,evdw1,sss
4024               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4025      &fac_shield(i),fac_shield(j)
4026           endif
4027
4028 C
4029 C Calculate contributions to the Cartesian gradient.
4030 C
4031 #ifdef SPLITELE
4032           facvdw=-6*rrmij*(ev1+evdwij)*sss
4033           facel=-3*rrmij*(el1+eesij)
4034           fac1=fac
4035           erij(1)=xj*rmij
4036           erij(2)=yj*rmij
4037           erij(3)=zj*rmij
4038
4039 *
4040 * Radial derivatives. First process both termini of the fragment (i,j)
4041 *
4042           ggg(1)=facel*xj
4043           ggg(2)=facel*yj
4044           ggg(3)=facel*zj
4045           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4046      &  (shield_mode.gt.0)) then
4047 C          print *,i,j
4048           do ilist=1,ishield_list(i)
4049            iresshield=shield_list(ilist,i)
4050            do k=1,3
4051            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4052      &      *2.0
4053            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4054      &              rlocshield
4055      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4056             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4057 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4058 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4059 C             if (iresshield.gt.i) then
4060 C               do ishi=i+1,iresshield-1
4061 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4062 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4063 C
4064 C              enddo
4065 C             else
4066 C               do ishi=iresshield,i
4067 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4068 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4069 C
4070 C               enddo
4071 C              endif
4072            enddo
4073           enddo
4074           do ilist=1,ishield_list(j)
4075            iresshield=shield_list(ilist,j)
4076            do k=1,3
4077            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4078      &     *2.0
4079            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4080      &              rlocshield
4081      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4082            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4083
4084 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4085 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4086 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4087 C             if (iresshield.gt.j) then
4088 C               do ishi=j+1,iresshield-1
4089 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4090 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4091 C
4092 C               enddo
4093 C            else
4094 C               do ishi=iresshield,j
4095 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4096 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4097 C               enddo
4098 C              endif
4099            enddo
4100           enddo
4101
4102           do k=1,3
4103             gshieldc(k,i)=gshieldc(k,i)+
4104      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4105             gshieldc(k,j)=gshieldc(k,j)+
4106      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4107             gshieldc(k,i-1)=gshieldc(k,i-1)+
4108      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4109             gshieldc(k,j-1)=gshieldc(k,j-1)+
4110      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4111
4112            enddo
4113            endif
4114 c          do k=1,3
4115 c            ghalf=0.5D0*ggg(k)
4116 c            gelc(k,i)=gelc(k,i)+ghalf
4117 c            gelc(k,j)=gelc(k,j)+ghalf
4118 c          enddo
4119 c 9/28/08 AL Gradient compotents will be summed only at the end
4120 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4121           do k=1,3
4122             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4123 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4124             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4125 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4126 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4127 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4128 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4129 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4130           enddo
4131 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4132
4133 *
4134 * Loop over residues i+1 thru j-1.
4135 *
4136 cgrad          do k=i+1,j-1
4137 cgrad            do l=1,3
4138 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4139 cgrad            enddo
4140 cgrad          enddo
4141           if (sss.gt.0.0) then
4142           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4143           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4144           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4145           else
4146           ggg(1)=0.0
4147           ggg(2)=0.0
4148           ggg(3)=0.0
4149           endif
4150 c          do k=1,3
4151 c            ghalf=0.5D0*ggg(k)
4152 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4153 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4154 c          enddo
4155 c 9/28/08 AL Gradient compotents will be summed only at the end
4156           do k=1,3
4157             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4158             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4159           enddo
4160 *
4161 * Loop over residues i+1 thru j-1.
4162 *
4163 cgrad          do k=i+1,j-1
4164 cgrad            do l=1,3
4165 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4166 cgrad            enddo
4167 cgrad          enddo
4168 #else
4169 C MARYSIA
4170           facvdw=(ev1+evdwij)*sss
4171           facel=(el1+eesij)
4172           fac1=fac
4173           fac=-3*rrmij*(facvdw+facvdw+facel)
4174           erij(1)=xj*rmij
4175           erij(2)=yj*rmij
4176           erij(3)=zj*rmij
4177 *
4178 * Radial derivatives. First process both termini of the fragment (i,j)
4179 *
4180           ggg(1)=fac*xj
4181 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4182           ggg(2)=fac*yj
4183 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4184           ggg(3)=fac*zj
4185 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4186 c          do k=1,3
4187 c            ghalf=0.5D0*ggg(k)
4188 c            gelc(k,i)=gelc(k,i)+ghalf
4189 c            gelc(k,j)=gelc(k,j)+ghalf
4190 c          enddo
4191 c 9/28/08 AL Gradient compotents will be summed only at the end
4192           do k=1,3
4193             gelc_long(k,j)=gelc(k,j)+ggg(k)
4194             gelc_long(k,i)=gelc(k,i)-ggg(k)
4195           enddo
4196 *
4197 * Loop over residues i+1 thru j-1.
4198 *
4199 cgrad          do k=i+1,j-1
4200 cgrad            do l=1,3
4201 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4202 cgrad            enddo
4203 cgrad          enddo
4204 c 9/28/08 AL Gradient compotents will be summed only at the end
4205           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4206           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4207           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4208           do k=1,3
4209             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4210             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4211           enddo
4212 #endif
4213 *
4214 * Angular part
4215 *
4216           ecosa=2.0D0*fac3*fac1+fac4
4217           fac4=-3.0D0*fac4
4218           fac3=-6.0D0*fac3
4219           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4220           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4221           do k=1,3
4222             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4223             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4224           enddo
4225 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4226 cd   &          (dcosg(k),k=1,3)
4227           do k=1,3
4228             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4229      &      fac_shield(i)**2*fac_shield(j)**2
4230           enddo
4231 c          do k=1,3
4232 c            ghalf=0.5D0*ggg(k)
4233 c            gelc(k,i)=gelc(k,i)+ghalf
4234 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4235 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4236 c            gelc(k,j)=gelc(k,j)+ghalf
4237 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4238 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4239 c          enddo
4240 cgrad          do k=i+1,j-1
4241 cgrad            do l=1,3
4242 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4243 cgrad            enddo
4244 cgrad          enddo
4245 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4246           do k=1,3
4247             gelc(k,i)=gelc(k,i)
4248      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4249      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4250      &           *fac_shield(i)**2*fac_shield(j)**2
4251             gelc(k,j)=gelc(k,j)
4252      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4253      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4254      &           *fac_shield(i)**2*fac_shield(j)**2
4255             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4256             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4257           enddo
4258 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4259
4260 C MARYSIA
4261 c          endif !sscale
4262           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4263      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4264      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4265 C
4266 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4267 C   energy of a peptide unit is assumed in the form of a second-order
4268 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4269 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4270 C   are computed for EVERY pair of non-contiguous peptide groups.
4271 C
4272
4273           if (j.lt.nres-1) then
4274             j1=j+1
4275             j2=j-1
4276           else
4277             j1=j-1
4278             j2=j-2
4279           endif
4280           kkk=0
4281           lll=0
4282           do k=1,2
4283             do l=1,2
4284               kkk=kkk+1
4285               muij(kkk)=mu(k,i)*mu(l,j)
4286 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4287 #ifdef NEWCORR
4288              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4289 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4290              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4291              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4292 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4293              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4294 #endif
4295             enddo
4296           enddo
4297 #ifdef DEBUG
4298           write (iout,*) 'EELEC: i',i,' j',j
4299           write (iout,*) 'j',j,' j1',j1,' j2',j2
4300           write(iout,*) 'muij',muij
4301 #endif
4302           ury=scalar(uy(1,i),erij)
4303           urz=scalar(uz(1,i),erij)
4304           vry=scalar(uy(1,j),erij)
4305           vrz=scalar(uz(1,j),erij)
4306           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4307           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4308           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4309           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4310           fac=dsqrt(-ael6i)*r3ij
4311 #ifdef DEBUG
4312           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4313           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4314      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4315      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4316      &      "uzvz",scalar(uz(1,i),uz(1,j))
4317           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4318           write (iout,*) "fac",fac
4319 #endif
4320           a22=a22*fac
4321           a23=a23*fac
4322           a32=a32*fac
4323           a33=a33*fac
4324 #ifdef DEBUG
4325           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4326 #endif
4327 #undef DEBUG
4328 cd          write (iout,'(4i5,4f10.5)')
4329 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4330 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4331 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4332 cd     &      uy(:,j),uz(:,j)
4333 cd          write (iout,'(4f10.5)')
4334 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4335 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4336 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4337 cd           write (iout,'(9f10.5/)')
4338 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4339 C Derivatives of the elements of A in virtual-bond vectors
4340           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4341           do k=1,3
4342             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4343             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4344             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4345             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4346             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4347             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4348             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4349             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4350             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4351             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4352             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4353             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4354           enddo
4355 C Compute radial contributions to the gradient
4356           facr=-3.0d0*rrmij
4357           a22der=a22*facr
4358           a23der=a23*facr
4359           a32der=a32*facr
4360           a33der=a33*facr
4361           agg(1,1)=a22der*xj
4362           agg(2,1)=a22der*yj
4363           agg(3,1)=a22der*zj
4364           agg(1,2)=a23der*xj
4365           agg(2,2)=a23der*yj
4366           agg(3,2)=a23der*zj
4367           agg(1,3)=a32der*xj
4368           agg(2,3)=a32der*yj
4369           agg(3,3)=a32der*zj
4370           agg(1,4)=a33der*xj
4371           agg(2,4)=a33der*yj
4372           agg(3,4)=a33der*zj
4373 C Add the contributions coming from er
4374           fac3=-3.0d0*fac
4375           do k=1,3
4376             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4377             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4378             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4379             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4380           enddo
4381           do k=1,3
4382 C Derivatives in DC(i)
4383 cgrad            ghalf1=0.5d0*agg(k,1)
4384 cgrad            ghalf2=0.5d0*agg(k,2)
4385 cgrad            ghalf3=0.5d0*agg(k,3)
4386 cgrad            ghalf4=0.5d0*agg(k,4)
4387             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4388      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4389             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4390      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4391             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4392      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4393             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4394      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4395 C Derivatives in DC(i+1)
4396             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4397      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4398             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4399      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4400             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4401      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4402             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4403      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4404 C Derivatives in DC(j)
4405             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4406      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4407             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4408      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4409             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4410      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4411             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4412      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4413 C Derivatives in DC(j+1) or DC(nres-1)
4414             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4415      &      -3.0d0*vryg(k,3)*ury)
4416             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4417      &      -3.0d0*vrzg(k,3)*ury)
4418             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4419      &      -3.0d0*vryg(k,3)*urz)
4420             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4421      &      -3.0d0*vrzg(k,3)*urz)
4422 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4423 cgrad              do l=1,4
4424 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4425 cgrad              enddo
4426 cgrad            endif
4427           enddo
4428           acipa(1,1)=a22
4429           acipa(1,2)=a23
4430           acipa(2,1)=a32
4431           acipa(2,2)=a33
4432           a22=-a22
4433           a23=-a23
4434           do l=1,2
4435             do k=1,3
4436               agg(k,l)=-agg(k,l)
4437               aggi(k,l)=-aggi(k,l)
4438               aggi1(k,l)=-aggi1(k,l)
4439               aggj(k,l)=-aggj(k,l)
4440               aggj1(k,l)=-aggj1(k,l)
4441             enddo
4442           enddo
4443           if (j.lt.nres-1) then
4444             a22=-a22
4445             a32=-a32
4446             do l=1,3,2
4447               do k=1,3
4448                 agg(k,l)=-agg(k,l)
4449                 aggi(k,l)=-aggi(k,l)
4450                 aggi1(k,l)=-aggi1(k,l)
4451                 aggj(k,l)=-aggj(k,l)
4452                 aggj1(k,l)=-aggj1(k,l)
4453               enddo
4454             enddo
4455           else
4456             a22=-a22
4457             a23=-a23
4458             a32=-a32
4459             a33=-a33
4460             do l=1,4
4461               do k=1,3
4462                 agg(k,l)=-agg(k,l)
4463                 aggi(k,l)=-aggi(k,l)
4464                 aggi1(k,l)=-aggi1(k,l)
4465                 aggj(k,l)=-aggj(k,l)
4466                 aggj1(k,l)=-aggj1(k,l)
4467               enddo
4468             enddo
4469           endif
4470           ENDIF ! WCORR
4471           IF (wel_loc.gt.0.0d0) THEN
4472 C Contribution to the local-electrostatic energy coming from the i-j pair
4473           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4474      &     +a33*muij(4)
4475 #ifdef DEBUG
4476           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4477      &     " a33",a33
4478           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4479      &     " wel_loc",wel_loc
4480 #endif
4481           if (shield_mode.eq.0) then
4482            fac_shield(i)=1.0
4483            fac_shield(j)=1.0
4484 C          else
4485 C           fac_shield(i)=0.4
4486 C           fac_shield(j)=0.6
4487           endif
4488           eel_loc_ij=eel_loc_ij
4489      &    *fac_shield(i)*fac_shield(j)
4490 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4491 c     &            'eelloc',i,j,eel_loc_ij
4492 C Now derivative over eel_loc
4493           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4494      &  (shield_mode.gt.0)) then
4495 C          print *,i,j
4496
4497           do ilist=1,ishield_list(i)
4498            iresshield=shield_list(ilist,i)
4499            do k=1,3
4500            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4501      &                                          /fac_shield(i)
4502 C     &      *2.0
4503            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4504      &              rlocshield
4505      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4506             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4507      &      +rlocshield
4508            enddo
4509           enddo
4510           do ilist=1,ishield_list(j)
4511            iresshield=shield_list(ilist,j)
4512            do k=1,3
4513            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4514      &                                       /fac_shield(j)
4515 C     &     *2.0
4516            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4517      &              rlocshield
4518      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4519            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4520      &             +rlocshield
4521
4522            enddo
4523           enddo
4524
4525           do k=1,3
4526             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4527      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4528             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4529      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4530             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4531      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4532             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4533      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4534            enddo
4535            endif
4536
4537
4538 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4539 c     &                     ' eel_loc_ij',eel_loc_ij
4540 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4541 C Calculate patrial derivative for theta angle
4542 #ifdef NEWCORR
4543          geel_loc_ij=(a22*gmuij1(1)
4544      &     +a23*gmuij1(2)
4545      &     +a32*gmuij1(3)
4546      &     +a33*gmuij1(4))
4547      &    *fac_shield(i)*fac_shield(j)
4548 c         write(iout,*) "derivative over thatai"
4549 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4550 c     &   a33*gmuij1(4)
4551          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4552      &      geel_loc_ij*wel_loc
4553 c         write(iout,*) "derivative over thatai-1"
4554 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4555 c     &   a33*gmuij2(4)
4556          geel_loc_ij=
4557      &     a22*gmuij2(1)
4558      &     +a23*gmuij2(2)
4559      &     +a32*gmuij2(3)
4560      &     +a33*gmuij2(4)
4561          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4562      &      geel_loc_ij*wel_loc
4563      &    *fac_shield(i)*fac_shield(j)
4564
4565 c  Derivative over j residue
4566          geel_loc_ji=a22*gmuji1(1)
4567      &     +a23*gmuji1(2)
4568      &     +a32*gmuji1(3)
4569      &     +a33*gmuji1(4)
4570 c         write(iout,*) "derivative over thataj"
4571 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4572 c     &   a33*gmuji1(4)
4573
4574         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4575      &      geel_loc_ji*wel_loc
4576      &    *fac_shield(i)*fac_shield(j)
4577
4578          geel_loc_ji=
4579      &     +a22*gmuji2(1)
4580      &     +a23*gmuji2(2)
4581      &     +a32*gmuji2(3)
4582      &     +a33*gmuji2(4)
4583 c         write(iout,*) "derivative over thataj-1"
4584 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4585 c     &   a33*gmuji2(4)
4586          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4587      &      geel_loc_ji*wel_loc
4588      &    *fac_shield(i)*fac_shield(j)
4589 #endif
4590 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4591
4592           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4593      &            'eelloc',i,j,eel_loc_ij
4594 c           if (eel_loc_ij.ne.0)
4595 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4596 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4597
4598           eel_loc=eel_loc+eel_loc_ij
4599 C Partial derivatives in virtual-bond dihedral angles gamma
4600           if (i.gt.1)
4601      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4602      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4603      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4604      &    *fac_shield(i)*fac_shield(j)
4605
4606           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4607      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4608      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4609      &    *fac_shield(i)*fac_shield(j)
4610 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4611           do l=1,3
4612             ggg(l)=(agg(l,1)*muij(1)+
4613      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4614      &    *fac_shield(i)*fac_shield(j)
4615             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4616             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4617 cgrad            ghalf=0.5d0*ggg(l)
4618 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4619 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4620           enddo
4621 cgrad          do k=i+1,j2
4622 cgrad            do l=1,3
4623 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4624 cgrad            enddo
4625 cgrad          enddo
4626 C Remaining derivatives of eello
4627           do l=1,3
4628             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4629      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4630      &    *fac_shield(i)*fac_shield(j)
4631
4632             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4633      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4634      &    *fac_shield(i)*fac_shield(j)
4635
4636             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4637      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4638      &    *fac_shield(i)*fac_shield(j)
4639
4640             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4641      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4642      &    *fac_shield(i)*fac_shield(j)
4643
4644           enddo
4645           ENDIF
4646 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4647 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4648           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4649      &       .and. num_conti.le.maxconts) then
4650 c            write (iout,*) i,j," entered corr"
4651 C
4652 C Calculate the contact function. The ith column of the array JCONT will
4653 C contain the numbers of atoms that make contacts with the atom I (of numbers
4654 C greater than I). The arrays FACONT and GACONT will contain the values of
4655 C the contact function and its derivative.
4656 c           r0ij=1.02D0*rpp(iteli,itelj)
4657 c           r0ij=1.11D0*rpp(iteli,itelj)
4658             r0ij=2.20D0*rpp(iteli,itelj)
4659 c           r0ij=1.55D0*rpp(iteli,itelj)
4660             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4661             if (fcont.gt.0.0D0) then
4662               num_conti=num_conti+1
4663               if (num_conti.gt.maxconts) then
4664                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4665      &                         ' will skip next contacts for this conf.'
4666               else
4667                 jcont_hb(num_conti,i)=j
4668 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4669 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4670                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4671      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4672 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4673 C  terms.
4674                 d_cont(num_conti,i)=rij
4675 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4676 C     --- Electrostatic-interaction matrix ---
4677                 a_chuj(1,1,num_conti,i)=a22
4678                 a_chuj(1,2,num_conti,i)=a23
4679                 a_chuj(2,1,num_conti,i)=a32
4680                 a_chuj(2,2,num_conti,i)=a33
4681 C     --- Gradient of rij
4682                 do kkk=1,3
4683                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4684                 enddo
4685                 kkll=0
4686                 do k=1,2
4687                   do l=1,2
4688                     kkll=kkll+1
4689                     do m=1,3
4690                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4691                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4692                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4693                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4694                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4695                     enddo
4696                   enddo
4697                 enddo
4698                 ENDIF
4699                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4700 C Calculate contact energies
4701                 cosa4=4.0D0*cosa
4702                 wij=cosa-3.0D0*cosb*cosg
4703                 cosbg1=cosb+cosg
4704                 cosbg2=cosb-cosg
4705 c               fac3=dsqrt(-ael6i)/r0ij**3
4706                 fac3=dsqrt(-ael6i)*r3ij
4707 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4708                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4709                 if (ees0tmp.gt.0) then
4710                   ees0pij=dsqrt(ees0tmp)
4711                 else
4712                   ees0pij=0
4713                 endif
4714 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4715                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4716                 if (ees0tmp.gt.0) then
4717                   ees0mij=dsqrt(ees0tmp)
4718                 else
4719                   ees0mij=0
4720                 endif
4721 c               ees0mij=0.0D0
4722                 if (shield_mode.eq.0) then
4723                 fac_shield(i)=1.0d0
4724                 fac_shield(j)=1.0d0
4725                 else
4726                 ees0plist(num_conti,i)=j
4727 C                fac_shield(i)=0.4d0
4728 C                fac_shield(j)=0.6d0
4729                 endif
4730                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4731      &          *fac_shield(i)*fac_shield(j)
4732                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4733      &          *fac_shield(i)*fac_shield(j)
4734 C Diagnostics. Comment out or remove after debugging!
4735 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4736 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4737 c               ees0m(num_conti,i)=0.0D0
4738 C End diagnostics.
4739 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4740 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4741 C Angular derivatives of the contact function
4742                 ees0pij1=fac3/ees0pij
4743                 ees0mij1=fac3/ees0mij
4744                 fac3p=-3.0D0*fac3*rrmij
4745                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4746                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4747 c               ees0mij1=0.0D0
4748                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4749                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4750                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4751                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4752                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4753                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4754                 ecosap=ecosa1+ecosa2
4755                 ecosbp=ecosb1+ecosb2
4756                 ecosgp=ecosg1+ecosg2
4757                 ecosam=ecosa1-ecosa2
4758                 ecosbm=ecosb1-ecosb2
4759                 ecosgm=ecosg1-ecosg2
4760 C Diagnostics
4761 c               ecosap=ecosa1
4762 c               ecosbp=ecosb1
4763 c               ecosgp=ecosg1
4764 c               ecosam=0.0D0
4765 c               ecosbm=0.0D0
4766 c               ecosgm=0.0D0
4767 C End diagnostics
4768                 facont_hb(num_conti,i)=fcont
4769                 fprimcont=fprimcont/rij
4770 cd              facont_hb(num_conti,i)=1.0D0
4771 C Following line is for diagnostics.
4772 cd              fprimcont=0.0D0
4773                 do k=1,3
4774                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4775                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4776                 enddo
4777                 do k=1,3
4778                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4779                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4780                 enddo
4781                 gggp(1)=gggp(1)+ees0pijp*xj
4782                 gggp(2)=gggp(2)+ees0pijp*yj
4783                 gggp(3)=gggp(3)+ees0pijp*zj
4784                 gggm(1)=gggm(1)+ees0mijp*xj
4785                 gggm(2)=gggm(2)+ees0mijp*yj
4786                 gggm(3)=gggm(3)+ees0mijp*zj
4787 C Derivatives due to the contact function
4788                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4789                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4790                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4791                 do k=1,3
4792 c
4793 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4794 c          following the change of gradient-summation algorithm.
4795 c
4796 cgrad                  ghalfp=0.5D0*gggp(k)
4797 cgrad                  ghalfm=0.5D0*gggm(k)
4798                   gacontp_hb1(k,num_conti,i)=!ghalfp
4799      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4800      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4801      &          *fac_shield(i)*fac_shield(j)
4802
4803                   gacontp_hb2(k,num_conti,i)=!ghalfp
4804      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4805      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4806      &          *fac_shield(i)*fac_shield(j)
4807
4808                   gacontp_hb3(k,num_conti,i)=gggp(k)
4809      &          *fac_shield(i)*fac_shield(j)
4810
4811                   gacontm_hb1(k,num_conti,i)=!ghalfm
4812      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4813      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4814      &          *fac_shield(i)*fac_shield(j)
4815
4816                   gacontm_hb2(k,num_conti,i)=!ghalfm
4817      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4818      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4819      &          *fac_shield(i)*fac_shield(j)
4820
4821                   gacontm_hb3(k,num_conti,i)=gggm(k)
4822      &          *fac_shield(i)*fac_shield(j)
4823
4824                 enddo
4825 C Diagnostics. Comment out or remove after debugging!
4826 cdiag           do k=1,3
4827 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4828 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4829 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4830 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4831 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4832 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4833 cdiag           enddo
4834               ENDIF ! wcorr
4835               endif  ! num_conti.le.maxconts
4836             endif  ! fcont.gt.0
4837           endif    ! j.gt.i+1
4838           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4839             do k=1,4
4840               do l=1,3
4841                 ghalf=0.5d0*agg(l,k)
4842                 aggi(l,k)=aggi(l,k)+ghalf
4843                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4844                 aggj(l,k)=aggj(l,k)+ghalf
4845               enddo
4846             enddo
4847             if (j.eq.nres-1 .and. i.lt.j-2) then
4848               do k=1,4
4849                 do l=1,3
4850                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4851                 enddo
4852               enddo
4853             endif
4854           endif
4855 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4856       return
4857       end
4858 C-----------------------------------------------------------------------------
4859       subroutine eturn3(i,eello_turn3)
4860 C Third- and fourth-order contributions from turns
4861       implicit real*8 (a-h,o-z)
4862       include 'DIMENSIONS'
4863       include 'COMMON.IOUNITS'
4864       include 'COMMON.GEO'
4865       include 'COMMON.VAR'
4866       include 'COMMON.LOCAL'
4867       include 'COMMON.CHAIN'
4868       include 'COMMON.DERIV'
4869       include 'COMMON.INTERACT'
4870       include 'COMMON.CONTACTS'
4871       include 'COMMON.TORSION'
4872       include 'COMMON.VECTORS'
4873       include 'COMMON.FFIELD'
4874       include 'COMMON.CONTROL'
4875       include 'COMMON.SHIELD'
4876       dimension ggg(3)
4877       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4878      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4879      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4880      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4881      &  auxgmat2(2,2),auxgmatt2(2,2)
4882       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4883      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4884       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4885      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4886      &    num_conti,j1,j2
4887       j=i+2
4888 c      write (iout,*) "eturn3",i,j,j1,j2
4889       a_temp(1,1)=a22
4890       a_temp(1,2)=a23
4891       a_temp(2,1)=a32
4892       a_temp(2,2)=a33
4893 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4894 C
4895 C               Third-order contributions
4896 C
4897 C                 (i+2)o----(i+3)
4898 C                      | |
4899 C                      | |
4900 C                 (i+1)o----i
4901 C
4902 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4903 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4904         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4905 c auxalary matices for theta gradient
4906 c auxalary matrix for i+1 and constant i+2
4907         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4908 c auxalary matrix for i+2 and constant i+1
4909         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4910         call transpose2(auxmat(1,1),auxmat1(1,1))
4911         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4912         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4913         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4914         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4915         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4916         if (shield_mode.eq.0) then
4917         fac_shield(i)=1.0
4918         fac_shield(j)=1.0
4919 C        else
4920 C        fac_shield(i)=0.4
4921 C        fac_shield(j)=0.6
4922         endif
4923         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4924      &  *fac_shield(i)*fac_shield(j)
4925         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4926      &  *fac_shield(i)*fac_shield(j)
4927         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4928      &    eello_t3
4929 C#ifdef NEWCORR
4930 C Derivatives in theta
4931         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4932      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4933      &   *fac_shield(i)*fac_shield(j)
4934         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4935      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4936      &   *fac_shield(i)*fac_shield(j)
4937 C#endif
4938
4939 C Derivatives in shield mode
4940           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4941      &  (shield_mode.gt.0)) then
4942 C          print *,i,j
4943
4944           do ilist=1,ishield_list(i)
4945            iresshield=shield_list(ilist,i)
4946            do k=1,3
4947            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4948 C     &      *2.0
4949            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4950      &              rlocshield
4951      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4952             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4953      &      +rlocshield
4954            enddo
4955           enddo
4956           do ilist=1,ishield_list(j)
4957            iresshield=shield_list(ilist,j)
4958            do k=1,3
4959            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4960 C     &     *2.0
4961            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4962      &              rlocshield
4963      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4964            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4965      &             +rlocshield
4966
4967            enddo
4968           enddo
4969
4970           do k=1,3
4971             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4972      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4973             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4974      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4975             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4976      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4977             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4978      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4979            enddo
4980            endif
4981
4982 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4983 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4984 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4985 cd     &    ' eello_turn3_num',4*eello_turn3_num
4986 C Derivatives in gamma(i)
4987         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4988         call transpose2(auxmat2(1,1),auxmat3(1,1))
4989         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4990         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4991      &   *fac_shield(i)*fac_shield(j)
4992 C Derivatives in gamma(i+1)
4993         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4994         call transpose2(auxmat2(1,1),auxmat3(1,1))
4995         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4996         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4997      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4998      &   *fac_shield(i)*fac_shield(j)
4999 C Cartesian derivatives
5000         do l=1,3
5001 c            ghalf1=0.5d0*agg(l,1)
5002 c            ghalf2=0.5d0*agg(l,2)
5003 c            ghalf3=0.5d0*agg(l,3)
5004 c            ghalf4=0.5d0*agg(l,4)
5005           a_temp(1,1)=aggi(l,1)!+ghalf1
5006           a_temp(1,2)=aggi(l,2)!+ghalf2
5007           a_temp(2,1)=aggi(l,3)!+ghalf3
5008           a_temp(2,2)=aggi(l,4)!+ghalf4
5009           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5010           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5011      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5012      &   *fac_shield(i)*fac_shield(j)
5013
5014           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5015           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5016           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5017           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5018           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5019           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5020      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5021      &   *fac_shield(i)*fac_shield(j)
5022           a_temp(1,1)=aggj(l,1)!+ghalf1
5023           a_temp(1,2)=aggj(l,2)!+ghalf2
5024           a_temp(2,1)=aggj(l,3)!+ghalf3
5025           a_temp(2,2)=aggj(l,4)!+ghalf4
5026           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5027           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5028      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5029      &   *fac_shield(i)*fac_shield(j)
5030           a_temp(1,1)=aggj1(l,1)
5031           a_temp(1,2)=aggj1(l,2)
5032           a_temp(2,1)=aggj1(l,3)
5033           a_temp(2,2)=aggj1(l,4)
5034           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5035           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5036      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5037      &   *fac_shield(i)*fac_shield(j)
5038         enddo
5039       return
5040       end
5041 C-------------------------------------------------------------------------------
5042       subroutine eturn4(i,eello_turn4)
5043 C Third- and fourth-order contributions from turns
5044       implicit real*8 (a-h,o-z)
5045       include 'DIMENSIONS'
5046       include 'COMMON.IOUNITS'
5047       include 'COMMON.GEO'
5048       include 'COMMON.VAR'
5049       include 'COMMON.LOCAL'
5050       include 'COMMON.CHAIN'
5051       include 'COMMON.DERIV'
5052       include 'COMMON.INTERACT'
5053       include 'COMMON.CONTACTS'
5054       include 'COMMON.TORSION'
5055       include 'COMMON.VECTORS'
5056       include 'COMMON.FFIELD'
5057       include 'COMMON.CONTROL'
5058       include 'COMMON.SHIELD'
5059       dimension ggg(3)
5060       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5061      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5062      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5063      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5064      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5065      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5066      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5067       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5068      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5069       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5070      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5071      &    num_conti,j1,j2
5072       j=i+3
5073 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5074 C
5075 C               Fourth-order contributions
5076 C
5077 C                 (i+3)o----(i+4)
5078 C                     /  |
5079 C               (i+2)o   |
5080 C                     \  |
5081 C                 (i+1)o----i
5082 C
5083 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5084 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5085 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5086 c        write(iout,*)"WCHODZE W PROGRAM"
5087         a_temp(1,1)=a22
5088         a_temp(1,2)=a23
5089         a_temp(2,1)=a32
5090         a_temp(2,2)=a33
5091         iti1=itype2loc(itype(i+1))
5092         iti2=itype2loc(itype(i+2))
5093         iti3=itype2loc(itype(i+3))
5094 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5095         call transpose2(EUg(1,1,i+1),e1t(1,1))
5096         call transpose2(Eug(1,1,i+2),e2t(1,1))
5097         call transpose2(Eug(1,1,i+3),e3t(1,1))
5098 C Ematrix derivative in theta
5099         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5100         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5101         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5102         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5103 c       eta1 in derivative theta
5104         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5105         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5106 c       auxgvec is derivative of Ub2 so i+3 theta
5107         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5108 c       auxalary matrix of E i+1
5109         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5110 c        s1=0.0
5111 c        gs1=0.0
5112         s1=scalar2(b1(1,i+2),auxvec(1))
5113 c derivative of theta i+2 with constant i+3
5114         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5115 c derivative of theta i+2 with constant i+2
5116         gs32=scalar2(b1(1,i+2),auxgvec(1))
5117 c derivative of E matix in theta of i+1
5118         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5119
5120         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5121 c       ea31 in derivative theta
5122         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5123         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5124 c auxilary matrix auxgvec of Ub2 with constant E matirx
5125         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5126 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5127         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5128
5129 c        s2=0.0
5130 c        gs2=0.0
5131         s2=scalar2(b1(1,i+1),auxvec(1))
5132 c derivative of theta i+1 with constant i+3
5133         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5134 c derivative of theta i+2 with constant i+1
5135         gs21=scalar2(b1(1,i+1),auxgvec(1))
5136 c derivative of theta i+3 with constant i+1
5137         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5138 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5139 c     &  gtb1(1,i+1)
5140         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5141 c two derivatives over diffetent matrices
5142 c gtae3e2 is derivative over i+3
5143         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5144 c ae3gte2 is derivative over i+2
5145         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5146         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5147 c three possible derivative over theta E matices
5148 c i+1
5149         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5150 c i+2
5151         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5152 c i+3
5153         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5154         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5155
5156         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5157         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5158         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5159         if (shield_mode.eq.0) then
5160         fac_shield(i)=1.0
5161         fac_shield(j)=1.0
5162 C        else
5163 C        fac_shield(i)=0.6
5164 C        fac_shield(j)=0.4
5165         endif
5166         eello_turn4=eello_turn4-(s1+s2+s3)
5167      &  *fac_shield(i)*fac_shield(j)
5168         eello_t4=-(s1+s2+s3)
5169      &  *fac_shield(i)*fac_shield(j)
5170 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5171         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5172      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5173 C Now derivative over shield:
5174           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5175      &  (shield_mode.gt.0)) then
5176 C          print *,i,j
5177
5178           do ilist=1,ishield_list(i)
5179            iresshield=shield_list(ilist,i)
5180            do k=1,3
5181            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5182 C     &      *2.0
5183            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5184      &              rlocshield
5185      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5186             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5187      &      +rlocshield
5188            enddo
5189           enddo
5190           do ilist=1,ishield_list(j)
5191            iresshield=shield_list(ilist,j)
5192            do k=1,3
5193            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5194 C     &     *2.0
5195            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5196      &              rlocshield
5197      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5198            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5199      &             +rlocshield
5200
5201            enddo
5202           enddo
5203
5204           do k=1,3
5205             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5206      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5207             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5208      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5209             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5210      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5211             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5212      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5213            enddo
5214            endif
5215
5216
5217
5218
5219
5220
5221 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5222 cd     &    ' eello_turn4_num',8*eello_turn4_num
5223 #ifdef NEWCORR
5224         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5225      &                  -(gs13+gsE13+gsEE1)*wturn4
5226      &  *fac_shield(i)*fac_shield(j)
5227         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5228      &                    -(gs23+gs21+gsEE2)*wturn4
5229      &  *fac_shield(i)*fac_shield(j)
5230
5231         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5232      &                    -(gs32+gsE31+gsEE3)*wturn4
5233      &  *fac_shield(i)*fac_shield(j)
5234
5235 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5236 c     &   gs2
5237 #endif
5238         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5239      &      'eturn4',i,j,-(s1+s2+s3)
5240 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5241 c     &    ' eello_turn4_num',8*eello_turn4_num
5242 C Derivatives in gamma(i)
5243         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5244         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5245         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5246         s1=scalar2(b1(1,i+2),auxvec(1))
5247         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5248         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5249         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5250      &  *fac_shield(i)*fac_shield(j)
5251 C Derivatives in gamma(i+1)
5252         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5253         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5254         s2=scalar2(b1(1,i+1),auxvec(1))
5255         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5256         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5257         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5258         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5259      &  *fac_shield(i)*fac_shield(j)
5260 C Derivatives in gamma(i+2)
5261         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5262         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5263         s1=scalar2(b1(1,i+2),auxvec(1))
5264         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5265         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5266         s2=scalar2(b1(1,i+1),auxvec(1))
5267         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5268         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5269         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5270         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5271      &  *fac_shield(i)*fac_shield(j)
5272 C Cartesian derivatives
5273 C Derivatives of this turn contributions in DC(i+2)
5274         if (j.lt.nres-1) then
5275           do l=1,3
5276             a_temp(1,1)=agg(l,1)
5277             a_temp(1,2)=agg(l,2)
5278             a_temp(2,1)=agg(l,3)
5279             a_temp(2,2)=agg(l,4)
5280             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5281             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5282             s1=scalar2(b1(1,i+2),auxvec(1))
5283             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5284             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5285             s2=scalar2(b1(1,i+1),auxvec(1))
5286             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5287             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5288             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5289             ggg(l)=-(s1+s2+s3)
5290             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5291      &  *fac_shield(i)*fac_shield(j)
5292           enddo
5293         endif
5294 C Remaining derivatives of this turn contribution
5295         do l=1,3
5296           a_temp(1,1)=aggi(l,1)
5297           a_temp(1,2)=aggi(l,2)
5298           a_temp(2,1)=aggi(l,3)
5299           a_temp(2,2)=aggi(l,4)
5300           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5301           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5302           s1=scalar2(b1(1,i+2),auxvec(1))
5303           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5304           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5305           s2=scalar2(b1(1,i+1),auxvec(1))
5306           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5307           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5308           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5309           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5310      &  *fac_shield(i)*fac_shield(j)
5311           a_temp(1,1)=aggi1(l,1)
5312           a_temp(1,2)=aggi1(l,2)
5313           a_temp(2,1)=aggi1(l,3)
5314           a_temp(2,2)=aggi1(l,4)
5315           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5316           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5317           s1=scalar2(b1(1,i+2),auxvec(1))
5318           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5319           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5320           s2=scalar2(b1(1,i+1),auxvec(1))
5321           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5322           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5323           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5324           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5325      &  *fac_shield(i)*fac_shield(j)
5326           a_temp(1,1)=aggj(l,1)
5327           a_temp(1,2)=aggj(l,2)
5328           a_temp(2,1)=aggj(l,3)
5329           a_temp(2,2)=aggj(l,4)
5330           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5331           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5332           s1=scalar2(b1(1,i+2),auxvec(1))
5333           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5334           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5335           s2=scalar2(b1(1,i+1),auxvec(1))
5336           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5337           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5338           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5339           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5340      &  *fac_shield(i)*fac_shield(j)
5341           a_temp(1,1)=aggj1(l,1)
5342           a_temp(1,2)=aggj1(l,2)
5343           a_temp(2,1)=aggj1(l,3)
5344           a_temp(2,2)=aggj1(l,4)
5345           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5346           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5347           s1=scalar2(b1(1,i+2),auxvec(1))
5348           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5349           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5350           s2=scalar2(b1(1,i+1),auxvec(1))
5351           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5352           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5353           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5354 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5355           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5356      &  *fac_shield(i)*fac_shield(j)
5357         enddo
5358       return
5359       end
5360 C-----------------------------------------------------------------------------
5361       subroutine vecpr(u,v,w)
5362       implicit real*8(a-h,o-z)
5363       dimension u(3),v(3),w(3)
5364       w(1)=u(2)*v(3)-u(3)*v(2)
5365       w(2)=-u(1)*v(3)+u(3)*v(1)
5366       w(3)=u(1)*v(2)-u(2)*v(1)
5367       return
5368       end
5369 C-----------------------------------------------------------------------------
5370       subroutine unormderiv(u,ugrad,unorm,ungrad)
5371 C This subroutine computes the derivatives of a normalized vector u, given
5372 C the derivatives computed without normalization conditions, ugrad. Returns
5373 C ungrad.
5374       implicit none
5375       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5376       double precision vec(3)
5377       double precision scalar
5378       integer i,j
5379 c      write (2,*) 'ugrad',ugrad
5380 c      write (2,*) 'u',u
5381       do i=1,3
5382         vec(i)=scalar(ugrad(1,i),u(1))
5383       enddo
5384 c      write (2,*) 'vec',vec
5385       do i=1,3
5386         do j=1,3
5387           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5388         enddo
5389       enddo
5390 c      write (2,*) 'ungrad',ungrad
5391       return
5392       end
5393 C-----------------------------------------------------------------------------
5394       subroutine escp_soft_sphere(evdw2,evdw2_14)
5395 C
5396 C This subroutine calculates the excluded-volume interaction energy between
5397 C peptide-group centers and side chains and its gradient in virtual-bond and
5398 C side-chain vectors.
5399 C
5400       implicit real*8 (a-h,o-z)
5401       include 'DIMENSIONS'
5402       include 'COMMON.GEO'
5403       include 'COMMON.VAR'
5404       include 'COMMON.LOCAL'
5405       include 'COMMON.CHAIN'
5406       include 'COMMON.DERIV'
5407       include 'COMMON.INTERACT'
5408       include 'COMMON.FFIELD'
5409       include 'COMMON.IOUNITS'
5410       include 'COMMON.CONTROL'
5411       dimension ggg(3)
5412       integer xshift,yshift,zshift
5413       evdw2=0.0D0
5414       evdw2_14=0.0d0
5415       r0_scp=4.5d0
5416 cd    print '(a)','Enter ESCP'
5417 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5418 C      do xshift=-1,1
5419 C      do yshift=-1,1
5420 C      do zshift=-1,1
5421       do i=iatscp_s,iatscp_e
5422         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5423         iteli=itel(i)
5424         xi=0.5D0*(c(1,i)+c(1,i+1))
5425         yi=0.5D0*(c(2,i)+c(2,i+1))
5426         zi=0.5D0*(c(3,i)+c(3,i+1))
5427 C Return atom into box, boxxsize is size of box in x dimension
5428 c  134   continue
5429 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5430 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5431 C Condition for being inside the proper box
5432 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5433 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5434 c        go to 134
5435 c        endif
5436 c  135   continue
5437 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5438 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5439 C Condition for being inside the proper box
5440 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5441 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5442 c        go to 135
5443 c c       endif
5444 c  136   continue
5445 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5446 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5447 cC Condition for being inside the proper box
5448 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5449 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5450 c        go to 136
5451 c        endif
5452           xi=mod(xi,boxxsize)
5453           if (xi.lt.0) xi=xi+boxxsize
5454           yi=mod(yi,boxysize)
5455           if (yi.lt.0) yi=yi+boxysize
5456           zi=mod(zi,boxzsize)
5457           if (zi.lt.0) zi=zi+boxzsize
5458 C          xi=xi+xshift*boxxsize
5459 C          yi=yi+yshift*boxysize
5460 C          zi=zi+zshift*boxzsize
5461         do iint=1,nscp_gr(i)
5462
5463         do j=iscpstart(i,iint),iscpend(i,iint)
5464           if (itype(j).eq.ntyp1) cycle
5465           itypj=iabs(itype(j))
5466 C Uncomment following three lines for SC-p interactions
5467 c         xj=c(1,nres+j)-xi
5468 c         yj=c(2,nres+j)-yi
5469 c         zj=c(3,nres+j)-zi
5470 C Uncomment following three lines for Ca-p interactions
5471           xj=c(1,j)
5472           yj=c(2,j)
5473           zj=c(3,j)
5474 c  174   continue
5475 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5476 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5477 C Condition for being inside the proper box
5478 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5479 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5480 c        go to 174
5481 c        endif
5482 c  175   continue
5483 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5484 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5485 cC Condition for being inside the proper box
5486 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5487 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5488 c        go to 175
5489 c        endif
5490 c  176   continue
5491 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5492 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5493 C Condition for being inside the proper box
5494 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5495 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5496 c        go to 176
5497           xj=mod(xj,boxxsize)
5498           if (xj.lt.0) xj=xj+boxxsize
5499           yj=mod(yj,boxysize)
5500           if (yj.lt.0) yj=yj+boxysize
5501           zj=mod(zj,boxzsize)
5502           if (zj.lt.0) zj=zj+boxzsize
5503       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5504       xj_safe=xj
5505       yj_safe=yj
5506       zj_safe=zj
5507       subchap=0
5508       do xshift=-1,1
5509       do yshift=-1,1
5510       do zshift=-1,1
5511           xj=xj_safe+xshift*boxxsize
5512           yj=yj_safe+yshift*boxysize
5513           zj=zj_safe+zshift*boxzsize
5514           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5515           if(dist_temp.lt.dist_init) then
5516             dist_init=dist_temp
5517             xj_temp=xj
5518             yj_temp=yj
5519             zj_temp=zj
5520             subchap=1
5521           endif
5522        enddo
5523        enddo
5524        enddo
5525        if (subchap.eq.1) then
5526           xj=xj_temp-xi
5527           yj=yj_temp-yi
5528           zj=zj_temp-zi
5529        else
5530           xj=xj_safe-xi
5531           yj=yj_safe-yi
5532           zj=zj_safe-zi
5533        endif
5534 c c       endif
5535 C          xj=xj-xi
5536 C          yj=yj-yi
5537 C          zj=zj-zi
5538           rij=xj*xj+yj*yj+zj*zj
5539
5540           r0ij=r0_scp
5541           r0ijsq=r0ij*r0ij
5542           if (rij.lt.r0ijsq) then
5543             evdwij=0.25d0*(rij-r0ijsq)**2
5544             fac=rij-r0ijsq
5545           else
5546             evdwij=0.0d0
5547             fac=0.0d0
5548           endif
5549           evdw2=evdw2+evdwij
5550 C
5551 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5552 C
5553           ggg(1)=xj*fac
5554           ggg(2)=yj*fac
5555           ggg(3)=zj*fac
5556 cgrad          if (j.lt.i) then
5557 cd          write (iout,*) 'j<i'
5558 C Uncomment following three lines for SC-p interactions
5559 c           do k=1,3
5560 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5561 c           enddo
5562 cgrad          else
5563 cd          write (iout,*) 'j>i'
5564 cgrad            do k=1,3
5565 cgrad              ggg(k)=-ggg(k)
5566 C Uncomment following line for SC-p interactions
5567 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5568 cgrad            enddo
5569 cgrad          endif
5570 cgrad          do k=1,3
5571 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5572 cgrad          enddo
5573 cgrad          kstart=min0(i+1,j)
5574 cgrad          kend=max0(i-1,j-1)
5575 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5576 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5577 cgrad          do k=kstart,kend
5578 cgrad            do l=1,3
5579 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5580 cgrad            enddo
5581 cgrad          enddo
5582           do k=1,3
5583             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5584             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5585           enddo
5586         enddo
5587
5588         enddo ! iint
5589       enddo ! i
5590 C      enddo !zshift
5591 C      enddo !yshift
5592 C      enddo !xshift
5593       return
5594       end
5595 C-----------------------------------------------------------------------------
5596       subroutine escp(evdw2,evdw2_14)
5597 C
5598 C This subroutine calculates the excluded-volume interaction energy between
5599 C peptide-group centers and side chains and its gradient in virtual-bond and
5600 C side-chain vectors.
5601 C
5602       implicit real*8 (a-h,o-z)
5603       include 'DIMENSIONS'
5604       include 'COMMON.GEO'
5605       include 'COMMON.VAR'
5606       include 'COMMON.LOCAL'
5607       include 'COMMON.CHAIN'
5608       include 'COMMON.DERIV'
5609       include 'COMMON.INTERACT'
5610       include 'COMMON.FFIELD'
5611       include 'COMMON.IOUNITS'
5612       include 'COMMON.CONTROL'
5613       include 'COMMON.SPLITELE'
5614       integer xshift,yshift,zshift
5615       dimension ggg(3)
5616       evdw2=0.0D0
5617       evdw2_14=0.0d0
5618 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5619 cd    print '(a)','Enter ESCP'
5620 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5621 C      do xshift=-1,1
5622 C      do yshift=-1,1
5623 C      do zshift=-1,1
5624       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5625       do i=iatscp_s,iatscp_e
5626         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5627         iteli=itel(i)
5628         xi=0.5D0*(c(1,i)+c(1,i+1))
5629         yi=0.5D0*(c(2,i)+c(2,i+1))
5630         zi=0.5D0*(c(3,i)+c(3,i+1))
5631           xi=mod(xi,boxxsize)
5632           if (xi.lt.0) xi=xi+boxxsize
5633           yi=mod(yi,boxysize)
5634           if (yi.lt.0) yi=yi+boxysize
5635           zi=mod(zi,boxzsize)
5636           if (zi.lt.0) zi=zi+boxzsize
5637 c          xi=xi+xshift*boxxsize
5638 c          yi=yi+yshift*boxysize
5639 c          zi=zi+zshift*boxzsize
5640 c        print *,xi,yi,zi,'polozenie i'
5641 C Return atom into box, boxxsize is size of box in x dimension
5642 c  134   continue
5643 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5644 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5645 C Condition for being inside the proper box
5646 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5647 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5648 c        go to 134
5649 c        endif
5650 c  135   continue
5651 c          print *,xi,boxxsize,"pierwszy"
5652
5653 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5654 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5655 C Condition for being inside the proper box
5656 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5657 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5658 c        go to 135
5659 c        endif
5660 c  136   continue
5661 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5662 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5663 C Condition for being inside the proper box
5664 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5665 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5666 c        go to 136
5667 c        endif
5668         do iint=1,nscp_gr(i)
5669
5670         do j=iscpstart(i,iint),iscpend(i,iint)
5671           itypj=iabs(itype(j))
5672           if (itypj.eq.ntyp1) cycle
5673 C Uncomment following three lines for SC-p interactions
5674 c         xj=c(1,nres+j)-xi
5675 c         yj=c(2,nres+j)-yi
5676 c         zj=c(3,nres+j)-zi
5677 C Uncomment following three lines for Ca-p interactions
5678           xj=c(1,j)
5679           yj=c(2,j)
5680           zj=c(3,j)
5681           xj=mod(xj,boxxsize)
5682           if (xj.lt.0) xj=xj+boxxsize
5683           yj=mod(yj,boxysize)
5684           if (yj.lt.0) yj=yj+boxysize
5685           zj=mod(zj,boxzsize)
5686           if (zj.lt.0) zj=zj+boxzsize
5687 c  174   continue
5688 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5689 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5690 C Condition for being inside the proper box
5691 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5692 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5693 c        go to 174
5694 c        endif
5695 c  175   continue
5696 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5697 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5698 cC Condition for being inside the proper box
5699 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5700 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5701 c        go to 175
5702 c        endif
5703 c  176   continue
5704 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5705 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5706 C Condition for being inside the proper box
5707 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5708 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5709 c        go to 176
5710 c        endif
5711 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5712       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5713       xj_safe=xj
5714       yj_safe=yj
5715       zj_safe=zj
5716       subchap=0
5717       do xshift=-1,1
5718       do yshift=-1,1
5719       do zshift=-1,1
5720           xj=xj_safe+xshift*boxxsize
5721           yj=yj_safe+yshift*boxysize
5722           zj=zj_safe+zshift*boxzsize
5723           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5724           if(dist_temp.lt.dist_init) then
5725             dist_init=dist_temp
5726             xj_temp=xj
5727             yj_temp=yj
5728             zj_temp=zj
5729             subchap=1
5730           endif
5731        enddo
5732        enddo
5733        enddo
5734        if (subchap.eq.1) then
5735           xj=xj_temp-xi
5736           yj=yj_temp-yi
5737           zj=zj_temp-zi
5738        else
5739           xj=xj_safe-xi
5740           yj=yj_safe-yi
5741           zj=zj_safe-zi
5742        endif
5743 c          print *,xj,yj,zj,'polozenie j'
5744           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5745 c          print *,rrij
5746           sss=sscale(1.0d0/(dsqrt(rrij)))
5747 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5748 c          if (sss.eq.0) print *,'czasem jest OK'
5749           if (sss.le.0.0d0) cycle
5750           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5751           fac=rrij**expon2
5752           e1=fac*fac*aad(itypj,iteli)
5753           e2=fac*bad(itypj,iteli)
5754           if (iabs(j-i) .le. 2) then
5755             e1=scal14*e1
5756             e2=scal14*e2
5757             evdw2_14=evdw2_14+(e1+e2)*sss
5758           endif
5759           evdwij=e1+e2
5760           evdw2=evdw2+evdwij*sss
5761           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5762      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5763      &       bad(itypj,iteli)
5764 C
5765 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5766 C
5767           fac=-(evdwij+e1)*rrij*sss
5768           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5769           ggg(1)=xj*fac
5770           ggg(2)=yj*fac
5771           ggg(3)=zj*fac
5772 cgrad          if (j.lt.i) then
5773 cd          write (iout,*) 'j<i'
5774 C Uncomment following three lines for SC-p interactions
5775 c           do k=1,3
5776 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5777 c           enddo
5778 cgrad          else
5779 cd          write (iout,*) 'j>i'
5780 cgrad            do k=1,3
5781 cgrad              ggg(k)=-ggg(k)
5782 C Uncomment following line for SC-p interactions
5783 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5784 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5785 cgrad            enddo
5786 cgrad          endif
5787 cgrad          do k=1,3
5788 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5789 cgrad          enddo
5790 cgrad          kstart=min0(i+1,j)
5791 cgrad          kend=max0(i-1,j-1)
5792 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5793 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5794 cgrad          do k=kstart,kend
5795 cgrad            do l=1,3
5796 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5797 cgrad            enddo
5798 cgrad          enddo
5799           do k=1,3
5800             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5801             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5802           enddo
5803 c        endif !endif for sscale cutoff
5804         enddo ! j
5805
5806         enddo ! iint
5807       enddo ! i
5808 c      enddo !zshift
5809 c      enddo !yshift
5810 c      enddo !xshift
5811       do i=1,nct
5812         do j=1,3
5813           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5814           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5815           gradx_scp(j,i)=expon*gradx_scp(j,i)
5816         enddo
5817       enddo
5818 C******************************************************************************
5819 C
5820 C                              N O T E !!!
5821 C
5822 C To save time the factor EXPON has been extracted from ALL components
5823 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5824 C use!
5825 C
5826 C******************************************************************************
5827       return
5828       end
5829 C--------------------------------------------------------------------------
5830       subroutine edis(ehpb)
5831 C
5832 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5833 C
5834       implicit real*8 (a-h,o-z)
5835       include 'DIMENSIONS'
5836       include 'COMMON.SBRIDGE'
5837       include 'COMMON.CHAIN'
5838       include 'COMMON.DERIV'
5839       include 'COMMON.VAR'
5840       include 'COMMON.INTERACT'
5841       include 'COMMON.IOUNITS'
5842       include 'COMMON.CONTROL'
5843       dimension ggg(3),ggg_peak(3,1000)
5844       ehpb=0.0D0
5845       do i=1,3
5846        ggg(i)=0.0d0
5847       enddo
5848 c 8/21/18 AL: added explicit restraints on reference coords
5849 c      write (iout,*) "restr_on_coord",restr_on_coord
5850       if (restr_on_coord) then
5851
5852       do i=nnt,nct
5853         ecoor=0.0d0
5854         if (itype(i).eq.ntyp1) cycle
5855         do j=1,3
5856           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5857           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5858         enddo
5859         if (itype(i).ne.10) then
5860           do j=1,3
5861             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5862             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5863           enddo
5864         endif
5865         if (energy_dec) write (iout,*)
5866      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5867         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5868       enddo
5869
5870       endif
5871 C      write (iout,*) ,"link_end",link_end,constr_dist
5872 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5873 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5874 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5875 c     &  " link_end_peak",link_end_peak
5876       if (link_end.eq.0.and.link_end_peak.eq.0) return
5877       do i=link_start_peak,link_end_peak
5878         ehpb_peak=0.0d0
5879 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5880 c     &   ipeak(1,i),ipeak(2,i)
5881         do ip=ipeak(1,i),ipeak(2,i)
5882           ii=ihpb_peak(ip)
5883           jj=jhpb_peak(ip)
5884           dd=dist(ii,jj)
5885           iip=ip-ipeak(1,i)+1
5886 C iii and jjj point to the residues for which the distance is assigned.
5887 c          if (ii.gt.nres) then
5888 c            iii=ii-nres
5889 c            jjj=jj-nres
5890 c          else
5891 c            iii=ii
5892 c            jjj=jj
5893 c          endif
5894           if (ii.gt.nres) then
5895             iii=ii-nres
5896           else
5897             iii=ii
5898           endif
5899           if (jj.gt.nres) then
5900             jjj=jj-nres
5901           else
5902             jjj=jj
5903           endif
5904           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5905           aux=dexp(-scal_peak*aux)
5906           ehpb_peak=ehpb_peak+aux
5907           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5908      &      forcon_peak(ip))*aux/dd
5909           do j=1,3
5910             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5911           enddo
5912           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5913      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5914      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5915         enddo
5916 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5917         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5918         do ip=ipeak(1,i),ipeak(2,i)
5919           iip=ip-ipeak(1,i)+1
5920           do j=1,3
5921             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5922           enddo
5923           ii=ihpb_peak(ip)
5924           jj=jhpb_peak(ip)
5925 C iii and jjj point to the residues for which the distance is assigned.
5926 c          if (ii.gt.nres) then
5927 c            iii=ii-nres
5928 c            jjj=jj-nres
5929 c          else
5930 c            iii=ii
5931 c            jjj=jj
5932 c          endif
5933           if (ii.gt.nres) then
5934             iii=ii-nres
5935           else
5936             iii=ii
5937           endif
5938           if (jj.gt.nres) then
5939             jjj=jj-nres
5940           else
5941             jjj=jj
5942           endif
5943           if (iii.lt.ii) then
5944             do j=1,3
5945               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5946             enddo
5947           endif
5948           if (jjj.lt.jj) then
5949             do j=1,3
5950               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5951             enddo
5952           endif
5953           do k=1,3
5954             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5955             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5956           enddo
5957         enddo
5958       enddo
5959       do i=link_start,link_end
5960 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5961 C CA-CA distance used in regularization of structure.
5962         ii=ihpb(i)
5963         jj=jhpb(i)
5964 C iii and jjj point to the residues for which the distance is assigned.
5965         if (ii.gt.nres) then
5966           iii=ii-nres
5967         else
5968           iii=ii
5969         endif
5970         if (jj.gt.nres) then
5971           jjj=jj-nres
5972         else
5973           jjj=jj
5974         endif
5975 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5976 c     &    dhpb(i),dhpb1(i),forcon(i)
5977 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5978 C    distance and angle dependent SS bond potential.
5979 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5980 C     & iabs(itype(jjj)).eq.1) then
5981 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5982 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5983         if (.not.dyn_ss .and. i.le.nss) then
5984 C 15/02/13 CC dynamic SSbond - additional check
5985           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5986      &        iabs(itype(jjj)).eq.1) then
5987            call ssbond_ene(iii,jjj,eij)
5988            ehpb=ehpb+2*eij
5989          endif
5990 cd          write (iout,*) "eij",eij
5991 cd   &   ' waga=',waga,' fac=',fac
5992 !        else if (ii.gt.nres .and. jj.gt.nres) then
5993         else
5994 C Calculate the distance between the two points and its difference from the
5995 C target distance.
5996           dd=dist(ii,jj)
5997           if (irestr_type(i).eq.11) then
5998             ehpb=ehpb+fordepth(i)!**4.0d0
5999      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6000             fac=fordepth(i)!**4.0d0
6001      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6002             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6003      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6004      &        ehpb,irestr_type(i)
6005           else if (irestr_type(i).eq.10) then
6006 c AL 6//19/2018 cross-link restraints
6007             xdis = 0.5d0*(dd/forcon(i))**2
6008             expdis = dexp(-xdis)
6009 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6010             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6011 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6012 c     &          " wboltzd",wboltzd
6013             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6014 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6015             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6016      &           *expdis/(aux*forcon(i)**2)
6017             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6018      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6019      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6020           else if (irestr_type(i).eq.2) then
6021 c Quartic restraints
6022             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6023             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6024      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6025      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6026             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6027           else
6028 c Quadratic restraints
6029             rdis=dd-dhpb(i)
6030 C Get the force constant corresponding to this distance.
6031             waga=forcon(i)
6032 C Calculate the contribution to energy.
6033             ehpb=ehpb+0.5d0*waga*rdis*rdis
6034             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6035      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6036      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6037 C
6038 C Evaluate gradient.
6039 C
6040             fac=waga*rdis/dd
6041           endif
6042 c Calculate Cartesian gradient
6043           do j=1,3
6044             ggg(j)=fac*(c(j,jj)-c(j,ii))
6045           enddo
6046 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6047 C If this is a SC-SC distance, we need to calculate the contributions to the
6048 C Cartesian gradient in the SC vectors (ghpbx).
6049           if (iii.lt.ii) then
6050             do j=1,3
6051               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6052             enddo
6053           endif
6054           if (jjj.lt.jj) then
6055             do j=1,3
6056               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6057             enddo
6058           endif
6059           do k=1,3
6060             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6061             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6062           enddo
6063         endif
6064       enddo
6065       return
6066       end
6067 C--------------------------------------------------------------------------
6068       subroutine ssbond_ene(i,j,eij)
6069 C
6070 C Calculate the distance and angle dependent SS-bond potential energy
6071 C using a free-energy function derived based on RHF/6-31G** ab initio
6072 C calculations of diethyl disulfide.
6073 C
6074 C A. Liwo and U. Kozlowska, 11/24/03
6075 C
6076       implicit real*8 (a-h,o-z)
6077       include 'DIMENSIONS'
6078       include 'COMMON.SBRIDGE'
6079       include 'COMMON.CHAIN'
6080       include 'COMMON.DERIV'
6081       include 'COMMON.LOCAL'
6082       include 'COMMON.INTERACT'
6083       include 'COMMON.VAR'
6084       include 'COMMON.IOUNITS'
6085       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6086       itypi=iabs(itype(i))
6087       xi=c(1,nres+i)
6088       yi=c(2,nres+i)
6089       zi=c(3,nres+i)
6090       dxi=dc_norm(1,nres+i)
6091       dyi=dc_norm(2,nres+i)
6092       dzi=dc_norm(3,nres+i)
6093 c      dsci_inv=dsc_inv(itypi)
6094       dsci_inv=vbld_inv(nres+i)
6095       itypj=iabs(itype(j))
6096 c      dscj_inv=dsc_inv(itypj)
6097       dscj_inv=vbld_inv(nres+j)
6098       xj=c(1,nres+j)-xi
6099       yj=c(2,nres+j)-yi
6100       zj=c(3,nres+j)-zi
6101       dxj=dc_norm(1,nres+j)
6102       dyj=dc_norm(2,nres+j)
6103       dzj=dc_norm(3,nres+j)
6104       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6105       rij=dsqrt(rrij)
6106       erij(1)=xj*rij
6107       erij(2)=yj*rij
6108       erij(3)=zj*rij
6109       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6110       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6111       om12=dxi*dxj+dyi*dyj+dzi*dzj
6112       do k=1,3
6113         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6114         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6115       enddo
6116       rij=1.0d0/rij
6117       deltad=rij-d0cm
6118       deltat1=1.0d0-om1
6119       deltat2=1.0d0+om2
6120       deltat12=om2-om1+2.0d0
6121       cosphi=om12-om1*om2
6122       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6123      &  +akct*deltad*deltat12
6124      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6125 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6126 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6127 c     &  " deltat12",deltat12," eij",eij
6128       ed=2*akcm*deltad+akct*deltat12
6129       pom1=akct*deltad
6130       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6131       eom1=-2*akth*deltat1-pom1-om2*pom2
6132       eom2= 2*akth*deltat2+pom1-om1*pom2
6133       eom12=pom2
6134       do k=1,3
6135         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6136         ghpbx(k,i)=ghpbx(k,i)-ggk
6137      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6138      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6139         ghpbx(k,j)=ghpbx(k,j)+ggk
6140      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6141      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6142         ghpbc(k,i)=ghpbc(k,i)-ggk
6143         ghpbc(k,j)=ghpbc(k,j)+ggk
6144       enddo
6145 C
6146 C Calculate the components of the gradient in DC and X
6147 C
6148 cgrad      do k=i,j-1
6149 cgrad        do l=1,3
6150 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6151 cgrad        enddo
6152 cgrad      enddo
6153       return
6154       end
6155 C--------------------------------------------------------------------------
6156       subroutine ebond(estr)
6157 c
6158 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6159 c
6160       implicit real*8 (a-h,o-z)
6161       include 'DIMENSIONS'
6162       include 'COMMON.LOCAL'
6163       include 'COMMON.GEO'
6164       include 'COMMON.INTERACT'
6165       include 'COMMON.DERIV'
6166       include 'COMMON.VAR'
6167       include 'COMMON.CHAIN'
6168       include 'COMMON.IOUNITS'
6169       include 'COMMON.NAMES'
6170       include 'COMMON.FFIELD'
6171       include 'COMMON.CONTROL'
6172       include 'COMMON.SETUP'
6173       double precision u(3),ud(3)
6174       estr=0.0d0
6175       estr1=0.0d0
6176       do i=ibondp_start,ibondp_end
6177         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6178 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6179 c          do j=1,3
6180 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6181 c     &      *dc(j,i-1)/vbld(i)
6182 c          enddo
6183 c          if (energy_dec) write(iout,*)
6184 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6185 c        else
6186 C       Checking if it involves dummy (NH3+ or COO-) group
6187          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6188 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6189         diff = vbld(i)-vbldpDUM
6190         if (energy_dec) write(iout,*) "dum_bond",i,diff
6191          else
6192 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6193         diff = vbld(i)-vbldp0
6194          endif
6195         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6196      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6197         estr=estr+diff*diff
6198         do j=1,3
6199           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6200         enddo
6201 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6202 c        endif
6203       enddo
6204
6205       estr=0.5d0*AKP*estr+estr1
6206 c
6207 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6208 c
6209       do i=ibond_start,ibond_end
6210         iti=iabs(itype(i))
6211         if (iti.ne.10 .and. iti.ne.ntyp1) then
6212           nbi=nbondterm(iti)
6213           if (nbi.eq.1) then
6214             diff=vbld(i+nres)-vbldsc0(1,iti)
6215             if (energy_dec)  write (iout,*)
6216      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6217      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6218             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6219             do j=1,3
6220               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6221             enddo
6222           else
6223             do j=1,nbi
6224               diff=vbld(i+nres)-vbldsc0(j,iti)
6225               ud(j)=aksc(j,iti)*diff
6226               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6227             enddo
6228             uprod=u(1)
6229             do j=2,nbi
6230               uprod=uprod*u(j)
6231             enddo
6232             usum=0.0d0
6233             usumsqder=0.0d0
6234             do j=1,nbi
6235               uprod1=1.0d0
6236               uprod2=1.0d0
6237               do k=1,nbi
6238                 if (k.ne.j) then
6239                   uprod1=uprod1*u(k)
6240                   uprod2=uprod2*u(k)*u(k)
6241                 endif
6242               enddo
6243               usum=usum+uprod1
6244               usumsqder=usumsqder+ud(j)*uprod2
6245             enddo
6246             estr=estr+uprod/usum
6247             do j=1,3
6248              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6249             enddo
6250           endif
6251         endif
6252       enddo
6253       return
6254       end
6255 #ifdef CRYST_THETA
6256 C--------------------------------------------------------------------------
6257       subroutine ebend(etheta)
6258 C
6259 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6260 C angles gamma and its derivatives in consecutive thetas and gammas.
6261 C
6262       implicit real*8 (a-h,o-z)
6263       include 'DIMENSIONS'
6264       include 'COMMON.LOCAL'
6265       include 'COMMON.GEO'
6266       include 'COMMON.INTERACT'
6267       include 'COMMON.DERIV'
6268       include 'COMMON.VAR'
6269       include 'COMMON.CHAIN'
6270       include 'COMMON.IOUNITS'
6271       include 'COMMON.NAMES'
6272       include 'COMMON.FFIELD'
6273       include 'COMMON.CONTROL'
6274       include 'COMMON.TORCNSTR'
6275       common /calcthet/ term1,term2,termm,diffak,ratak,
6276      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6277      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6278       double precision y(2),z(2)
6279       delta=0.02d0*pi
6280 c      time11=dexp(-2*time)
6281 c      time12=1.0d0
6282       etheta=0.0D0
6283 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6284       do i=ithet_start,ithet_end
6285         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6286      &  .or.itype(i).eq.ntyp1) cycle
6287 C Zero the energy function and its derivative at 0 or pi.
6288         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6289         it=itype(i-1)
6290         ichir1=isign(1,itype(i-2))
6291         ichir2=isign(1,itype(i))
6292          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6293          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6294          if (itype(i-1).eq.10) then
6295           itype1=isign(10,itype(i-2))
6296           ichir11=isign(1,itype(i-2))
6297           ichir12=isign(1,itype(i-2))
6298           itype2=isign(10,itype(i))
6299           ichir21=isign(1,itype(i))
6300           ichir22=isign(1,itype(i))
6301          endif
6302
6303         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6304 #ifdef OSF
6305           phii=phi(i)
6306           if (phii.ne.phii) phii=150.0
6307 #else
6308           phii=phi(i)
6309 #endif
6310           y(1)=dcos(phii)
6311           y(2)=dsin(phii)
6312         else
6313           y(1)=0.0D0
6314           y(2)=0.0D0
6315         endif
6316         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6317 #ifdef OSF
6318           phii1=phi(i+1)
6319           if (phii1.ne.phii1) phii1=150.0
6320           phii1=pinorm(phii1)
6321           z(1)=cos(phii1)
6322 #else
6323           phii1=phi(i+1)
6324 #endif
6325           z(1)=dcos(phii1)
6326           z(2)=dsin(phii1)
6327         else
6328           z(1)=0.0D0
6329           z(2)=0.0D0
6330         endif
6331 C Calculate the "mean" value of theta from the part of the distribution
6332 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6333 C In following comments this theta will be referred to as t_c.
6334         thet_pred_mean=0.0d0
6335         do k=1,2
6336             athetk=athet(k,it,ichir1,ichir2)
6337             bthetk=bthet(k,it,ichir1,ichir2)
6338           if (it.eq.10) then
6339              athetk=athet(k,itype1,ichir11,ichir12)
6340              bthetk=bthet(k,itype2,ichir21,ichir22)
6341           endif
6342          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6343 c         write(iout,*) 'chuj tu', y(k),z(k)
6344         enddo
6345         dthett=thet_pred_mean*ssd
6346         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6347 C Derivatives of the "mean" values in gamma1 and gamma2.
6348         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6349      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6350          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6351      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6352          if (it.eq.10) then
6353       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6354      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6355         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6356      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6357          endif
6358         if (theta(i).gt.pi-delta) then
6359           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6360      &         E_tc0)
6361           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6362           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6363           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6364      &        E_theta)
6365           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6366      &        E_tc)
6367         else if (theta(i).lt.delta) then
6368           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6369           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6370           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6371      &        E_theta)
6372           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6373           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6374      &        E_tc)
6375         else
6376           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6377      &        E_theta,E_tc)
6378         endif
6379         etheta=etheta+ethetai
6380         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6381      &      'ebend',i,ethetai,theta(i),itype(i)
6382         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6383         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6384         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6385       enddo
6386
6387 C Ufff.... We've done all this!!!
6388       return
6389       end
6390 C---------------------------------------------------------------------------
6391       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6392      &     E_tc)
6393       implicit real*8 (a-h,o-z)
6394       include 'DIMENSIONS'
6395       include 'COMMON.LOCAL'
6396       include 'COMMON.IOUNITS'
6397       common /calcthet/ term1,term2,termm,diffak,ratak,
6398      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6399      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6400 C Calculate the contributions to both Gaussian lobes.
6401 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6402 C The "polynomial part" of the "standard deviation" of this part of
6403 C the distributioni.
6404 ccc        write (iout,*) thetai,thet_pred_mean
6405         sig=polthet(3,it)
6406         do j=2,0,-1
6407           sig=sig*thet_pred_mean+polthet(j,it)
6408         enddo
6409 C Derivative of the "interior part" of the "standard deviation of the"
6410 C gamma-dependent Gaussian lobe in t_c.
6411         sigtc=3*polthet(3,it)
6412         do j=2,1,-1
6413           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6414         enddo
6415         sigtc=sig*sigtc
6416 C Set the parameters of both Gaussian lobes of the distribution.
6417 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6418         fac=sig*sig+sigc0(it)
6419         sigcsq=fac+fac
6420         sigc=1.0D0/sigcsq
6421 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6422         sigsqtc=-4.0D0*sigcsq*sigtc
6423 c       print *,i,sig,sigtc,sigsqtc
6424 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6425         sigtc=-sigtc/(fac*fac)
6426 C Following variable is sigma(t_c)**(-2)
6427         sigcsq=sigcsq*sigcsq
6428         sig0i=sig0(it)
6429         sig0inv=1.0D0/sig0i**2
6430         delthec=thetai-thet_pred_mean
6431         delthe0=thetai-theta0i
6432         term1=-0.5D0*sigcsq*delthec*delthec
6433         term2=-0.5D0*sig0inv*delthe0*delthe0
6434 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6435 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6436 C NaNs in taking the logarithm. We extract the largest exponent which is added
6437 C to the energy (this being the log of the distribution) at the end of energy
6438 C term evaluation for this virtual-bond angle.
6439         if (term1.gt.term2) then
6440           termm=term1
6441           term2=dexp(term2-termm)
6442           term1=1.0d0
6443         else
6444           termm=term2
6445           term1=dexp(term1-termm)
6446           term2=1.0d0
6447         endif
6448 C The ratio between the gamma-independent and gamma-dependent lobes of
6449 C the distribution is a Gaussian function of thet_pred_mean too.
6450         diffak=gthet(2,it)-thet_pred_mean
6451         ratak=diffak/gthet(3,it)**2
6452         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6453 C Let's differentiate it in thet_pred_mean NOW.
6454         aktc=ak*ratak
6455 C Now put together the distribution terms to make complete distribution.
6456         termexp=term1+ak*term2
6457         termpre=sigc+ak*sig0i
6458 C Contribution of the bending energy from this theta is just the -log of
6459 C the sum of the contributions from the two lobes and the pre-exponential
6460 C factor. Simple enough, isn't it?
6461         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6462 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6463 C NOW the derivatives!!!
6464 C 6/6/97 Take into account the deformation.
6465         E_theta=(delthec*sigcsq*term1
6466      &       +ak*delthe0*sig0inv*term2)/termexp
6467         E_tc=((sigtc+aktc*sig0i)/termpre
6468      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6469      &       aktc*term2)/termexp)
6470       return
6471       end
6472 c-----------------------------------------------------------------------------
6473       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6474       implicit real*8 (a-h,o-z)
6475       include 'DIMENSIONS'
6476       include 'COMMON.LOCAL'
6477       include 'COMMON.IOUNITS'
6478       common /calcthet/ term1,term2,termm,diffak,ratak,
6479      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6480      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6481       delthec=thetai-thet_pred_mean
6482       delthe0=thetai-theta0i
6483 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6484       t3 = thetai-thet_pred_mean
6485       t6 = t3**2
6486       t9 = term1
6487       t12 = t3*sigcsq
6488       t14 = t12+t6*sigsqtc
6489       t16 = 1.0d0
6490       t21 = thetai-theta0i
6491       t23 = t21**2
6492       t26 = term2
6493       t27 = t21*t26
6494       t32 = termexp
6495       t40 = t32**2
6496       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6497      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6498      & *(-t12*t9-ak*sig0inv*t27)
6499       return
6500       end
6501 #else
6502 C--------------------------------------------------------------------------
6503       subroutine ebend(etheta)
6504 C
6505 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6506 C angles gamma and its derivatives in consecutive thetas and gammas.
6507 C ab initio-derived potentials from
6508 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6509 C
6510       implicit real*8 (a-h,o-z)
6511       include 'DIMENSIONS'
6512       include 'COMMON.LOCAL'
6513       include 'COMMON.GEO'
6514       include 'COMMON.INTERACT'
6515       include 'COMMON.DERIV'
6516       include 'COMMON.VAR'
6517       include 'COMMON.CHAIN'
6518       include 'COMMON.IOUNITS'
6519       include 'COMMON.NAMES'
6520       include 'COMMON.FFIELD'
6521       include 'COMMON.CONTROL'
6522       include 'COMMON.TORCNSTR'
6523       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6524      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6525      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6526      & sinph1ph2(maxdouble,maxdouble)
6527       logical lprn /.false./, lprn1 /.false./
6528       etheta=0.0D0
6529       do i=ithet_start,ithet_end
6530 c        print *,i,itype(i-1),itype(i),itype(i-2)
6531         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6532      &  .or.itype(i).eq.ntyp1) cycle
6533 C        print *,i,theta(i)
6534         if (iabs(itype(i+1)).eq.20) iblock=2
6535         if (iabs(itype(i+1)).ne.20) iblock=1
6536         dethetai=0.0d0
6537         dephii=0.0d0
6538         dephii1=0.0d0
6539         theti2=0.5d0*theta(i)
6540         ityp2=ithetyp((itype(i-1)))
6541         do k=1,nntheterm
6542           coskt(k)=dcos(k*theti2)
6543           sinkt(k)=dsin(k*theti2)
6544         enddo
6545 C        print *,ethetai
6546         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6547 #ifdef OSF
6548           phii=phi(i)
6549           if (phii.ne.phii) phii=150.0
6550 #else
6551           phii=phi(i)
6552 #endif
6553           ityp1=ithetyp((itype(i-2)))
6554 C propagation of chirality for glycine type
6555           do k=1,nsingle
6556             cosph1(k)=dcos(k*phii)
6557             sinph1(k)=dsin(k*phii)
6558           enddo
6559         else
6560           phii=0.0d0
6561           do k=1,nsingle
6562           ityp1=ithetyp((itype(i-2)))
6563             cosph1(k)=0.0d0
6564             sinph1(k)=0.0d0
6565           enddo
6566         endif
6567         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6568 #ifdef OSF
6569           phii1=phi(i+1)
6570           if (phii1.ne.phii1) phii1=150.0
6571           phii1=pinorm(phii1)
6572 #else
6573           phii1=phi(i+1)
6574 #endif
6575           ityp3=ithetyp((itype(i)))
6576           do k=1,nsingle
6577             cosph2(k)=dcos(k*phii1)
6578             sinph2(k)=dsin(k*phii1)
6579           enddo
6580         else
6581           phii1=0.0d0
6582           ityp3=ithetyp((itype(i)))
6583           do k=1,nsingle
6584             cosph2(k)=0.0d0
6585             sinph2(k)=0.0d0
6586           enddo
6587         endif
6588         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6589         do k=1,ndouble
6590           do l=1,k-1
6591             ccl=cosph1(l)*cosph2(k-l)
6592             ssl=sinph1(l)*sinph2(k-l)
6593             scl=sinph1(l)*cosph2(k-l)
6594             csl=cosph1(l)*sinph2(k-l)
6595             cosph1ph2(l,k)=ccl-ssl
6596             cosph1ph2(k,l)=ccl+ssl
6597             sinph1ph2(l,k)=scl+csl
6598             sinph1ph2(k,l)=scl-csl
6599           enddo
6600         enddo
6601         if (lprn) then
6602         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6603      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6604         write (iout,*) "coskt and sinkt"
6605         do k=1,nntheterm
6606           write (iout,*) k,coskt(k),sinkt(k)
6607         enddo
6608         endif
6609         do k=1,ntheterm
6610           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6611           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6612      &      *coskt(k)
6613           if (lprn)
6614      &    write (iout,*) "k",k,"
6615      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6616      &     " ethetai",ethetai
6617         enddo
6618         if (lprn) then
6619         write (iout,*) "cosph and sinph"
6620         do k=1,nsingle
6621           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6622         enddo
6623         write (iout,*) "cosph1ph2 and sinph2ph2"
6624         do k=2,ndouble
6625           do l=1,k-1
6626             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6627      &         sinph1ph2(l,k),sinph1ph2(k,l)
6628           enddo
6629         enddo
6630         write(iout,*) "ethetai",ethetai
6631         endif
6632 C       print *,ethetai
6633         do m=1,ntheterm2
6634           do k=1,nsingle
6635             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6636      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6637      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6638      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6639             ethetai=ethetai+sinkt(m)*aux
6640             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6641             dephii=dephii+k*sinkt(m)*(
6642      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6643      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6644             dephii1=dephii1+k*sinkt(m)*(
6645      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6646      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6647             if (lprn)
6648      &      write (iout,*) "m",m," k",k," bbthet",
6649      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6650      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6651      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6652      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6653 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6654           enddo
6655         enddo
6656 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6657 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6658 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6659 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6660         if (lprn)
6661      &  write(iout,*) "ethetai",ethetai
6662 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6663         do m=1,ntheterm3
6664           do k=2,ndouble
6665             do l=1,k-1
6666               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6667      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6668      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6669      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6670               ethetai=ethetai+sinkt(m)*aux
6671               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6672               dephii=dephii+l*sinkt(m)*(
6673      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6674      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6675      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6676      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6677               dephii1=dephii1+(k-l)*sinkt(m)*(
6678      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6679      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6680      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6681      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6682               if (lprn) then
6683               write (iout,*) "m",m," k",k," l",l," ffthet",
6684      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6685      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6686      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6687      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6688      &            " ethetai",ethetai
6689               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6690      &            cosph1ph2(k,l)*sinkt(m),
6691      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6692               endif
6693             enddo
6694           enddo
6695         enddo
6696 10      continue
6697 c        lprn1=.true.
6698 C        print *,ethetai
6699         if (lprn1)
6700      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6701      &   i,theta(i)*rad2deg,phii*rad2deg,
6702      &   phii1*rad2deg,ethetai
6703 c        lprn1=.false.
6704         etheta=etheta+ethetai
6705         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6706         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6707         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6708       enddo
6709
6710       return
6711       end
6712 #endif
6713 #ifdef CRYST_SC
6714 c-----------------------------------------------------------------------------
6715       subroutine esc(escloc)
6716 C Calculate the local energy of a side chain and its derivatives in the
6717 C corresponding virtual-bond valence angles THETA and the spherical angles
6718 C ALPHA and OMEGA.
6719       implicit real*8 (a-h,o-z)
6720       include 'DIMENSIONS'
6721       include 'COMMON.GEO'
6722       include 'COMMON.LOCAL'
6723       include 'COMMON.VAR'
6724       include 'COMMON.INTERACT'
6725       include 'COMMON.DERIV'
6726       include 'COMMON.CHAIN'
6727       include 'COMMON.IOUNITS'
6728       include 'COMMON.NAMES'
6729       include 'COMMON.FFIELD'
6730       include 'COMMON.CONTROL'
6731       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6732      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6733       common /sccalc/ time11,time12,time112,theti,it,nlobit
6734       delta=0.02d0*pi
6735       escloc=0.0D0
6736 c     write (iout,'(a)') 'ESC'
6737       do i=loc_start,loc_end
6738         it=itype(i)
6739         if (it.eq.ntyp1) cycle
6740         if (it.eq.10) goto 1
6741         nlobit=nlob(iabs(it))
6742 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6743 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6744         theti=theta(i+1)-pipol
6745         x(1)=dtan(theti)
6746         x(2)=alph(i)
6747         x(3)=omeg(i)
6748
6749         if (x(2).gt.pi-delta) then
6750           xtemp(1)=x(1)
6751           xtemp(2)=pi-delta
6752           xtemp(3)=x(3)
6753           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6754           xtemp(2)=pi
6755           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6756           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6757      &        escloci,dersc(2))
6758           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6759      &        ddersc0(1),dersc(1))
6760           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6761      &        ddersc0(3),dersc(3))
6762           xtemp(2)=pi-delta
6763           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6764           xtemp(2)=pi
6765           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6766           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6767      &            dersc0(2),esclocbi,dersc02)
6768           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6769      &            dersc12,dersc01)
6770           call splinthet(x(2),0.5d0*delta,ss,ssd)
6771           dersc0(1)=dersc01
6772           dersc0(2)=dersc02
6773           dersc0(3)=0.0d0
6774           do k=1,3
6775             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6776           enddo
6777           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6778 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6779 c    &             esclocbi,ss,ssd
6780           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6781 c         escloci=esclocbi
6782 c         write (iout,*) escloci
6783         else if (x(2).lt.delta) then
6784           xtemp(1)=x(1)
6785           xtemp(2)=delta
6786           xtemp(3)=x(3)
6787           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6788           xtemp(2)=0.0d0
6789           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6790           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6791      &        escloci,dersc(2))
6792           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6793      &        ddersc0(1),dersc(1))
6794           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6795      &        ddersc0(3),dersc(3))
6796           xtemp(2)=delta
6797           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6798           xtemp(2)=0.0d0
6799           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6800           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6801      &            dersc0(2),esclocbi,dersc02)
6802           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6803      &            dersc12,dersc01)
6804           dersc0(1)=dersc01
6805           dersc0(2)=dersc02
6806           dersc0(3)=0.0d0
6807           call splinthet(x(2),0.5d0*delta,ss,ssd)
6808           do k=1,3
6809             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6810           enddo
6811           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6812 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6813 c    &             esclocbi,ss,ssd
6814           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6815 c         write (iout,*) escloci
6816         else
6817           call enesc(x,escloci,dersc,ddummy,.false.)
6818         endif
6819
6820         escloc=escloc+escloci
6821         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6822      &     'escloc',i,escloci
6823 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6824
6825         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6826      &   wscloc*dersc(1)
6827         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6828         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6829     1   continue
6830       enddo
6831       return
6832       end
6833 C---------------------------------------------------------------------------
6834       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6835       implicit real*8 (a-h,o-z)
6836       include 'DIMENSIONS'
6837       include 'COMMON.GEO'
6838       include 'COMMON.LOCAL'
6839       include 'COMMON.IOUNITS'
6840       common /sccalc/ time11,time12,time112,theti,it,nlobit
6841       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6842       double precision contr(maxlob,-1:1)
6843       logical mixed
6844 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6845         escloc_i=0.0D0
6846         do j=1,3
6847           dersc(j)=0.0D0
6848           if (mixed) ddersc(j)=0.0d0
6849         enddo
6850         x3=x(3)
6851
6852 C Because of periodicity of the dependence of the SC energy in omega we have
6853 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6854 C To avoid underflows, first compute & store the exponents.
6855
6856         do iii=-1,1
6857
6858           x(3)=x3+iii*dwapi
6859
6860           do j=1,nlobit
6861             do k=1,3
6862               z(k)=x(k)-censc(k,j,it)
6863             enddo
6864             do k=1,3
6865               Axk=0.0D0
6866               do l=1,3
6867                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6868               enddo
6869               Ax(k,j,iii)=Axk
6870             enddo
6871             expfac=0.0D0
6872             do k=1,3
6873               expfac=expfac+Ax(k,j,iii)*z(k)
6874             enddo
6875             contr(j,iii)=expfac
6876           enddo ! j
6877
6878         enddo ! iii
6879
6880         x(3)=x3
6881 C As in the case of ebend, we want to avoid underflows in exponentiation and
6882 C subsequent NaNs and INFs in energy calculation.
6883 C Find the largest exponent
6884         emin=contr(1,-1)
6885         do iii=-1,1
6886           do j=1,nlobit
6887             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6888           enddo
6889         enddo
6890         emin=0.5D0*emin
6891 cd      print *,'it=',it,' emin=',emin
6892
6893 C Compute the contribution to SC energy and derivatives
6894         do iii=-1,1
6895
6896           do j=1,nlobit
6897 #ifdef OSF
6898             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6899             if(adexp.ne.adexp) adexp=1.0
6900             expfac=dexp(adexp)
6901 #else
6902             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6903 #endif
6904 cd          print *,'j=',j,' expfac=',expfac
6905             escloc_i=escloc_i+expfac
6906             do k=1,3
6907               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6908             enddo
6909             if (mixed) then
6910               do k=1,3,2
6911                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6912      &            +gaussc(k,2,j,it))*expfac
6913               enddo
6914             endif
6915           enddo
6916
6917         enddo ! iii
6918
6919         dersc(1)=dersc(1)/cos(theti)**2
6920         ddersc(1)=ddersc(1)/cos(theti)**2
6921         ddersc(3)=ddersc(3)
6922
6923         escloci=-(dlog(escloc_i)-emin)
6924         do j=1,3
6925           dersc(j)=dersc(j)/escloc_i
6926         enddo
6927         if (mixed) then
6928           do j=1,3,2
6929             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6930           enddo
6931         endif
6932       return
6933       end
6934 C------------------------------------------------------------------------------
6935       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6936       implicit real*8 (a-h,o-z)
6937       include 'DIMENSIONS'
6938       include 'COMMON.GEO'
6939       include 'COMMON.LOCAL'
6940       include 'COMMON.IOUNITS'
6941       common /sccalc/ time11,time12,time112,theti,it,nlobit
6942       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6943       double precision contr(maxlob)
6944       logical mixed
6945
6946       escloc_i=0.0D0
6947
6948       do j=1,3
6949         dersc(j)=0.0D0
6950       enddo
6951
6952       do j=1,nlobit
6953         do k=1,2
6954           z(k)=x(k)-censc(k,j,it)
6955         enddo
6956         z(3)=dwapi
6957         do k=1,3
6958           Axk=0.0D0
6959           do l=1,3
6960             Axk=Axk+gaussc(l,k,j,it)*z(l)
6961           enddo
6962           Ax(k,j)=Axk
6963         enddo
6964         expfac=0.0D0
6965         do k=1,3
6966           expfac=expfac+Ax(k,j)*z(k)
6967         enddo
6968         contr(j)=expfac
6969       enddo ! j
6970
6971 C As in the case of ebend, we want to avoid underflows in exponentiation and
6972 C subsequent NaNs and INFs in energy calculation.
6973 C Find the largest exponent
6974       emin=contr(1)
6975       do j=1,nlobit
6976         if (emin.gt.contr(j)) emin=contr(j)
6977       enddo
6978       emin=0.5D0*emin
6979
6980 C Compute the contribution to SC energy and derivatives
6981
6982       dersc12=0.0d0
6983       do j=1,nlobit
6984         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6985         escloc_i=escloc_i+expfac
6986         do k=1,2
6987           dersc(k)=dersc(k)+Ax(k,j)*expfac
6988         enddo
6989         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6990      &            +gaussc(1,2,j,it))*expfac
6991         dersc(3)=0.0d0
6992       enddo
6993
6994       dersc(1)=dersc(1)/cos(theti)**2
6995       dersc12=dersc12/cos(theti)**2
6996       escloci=-(dlog(escloc_i)-emin)
6997       do j=1,2
6998         dersc(j)=dersc(j)/escloc_i
6999       enddo
7000       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7001       return
7002       end
7003 #else
7004 c----------------------------------------------------------------------------------
7005       subroutine esc(escloc)
7006 C Calculate the local energy of a side chain and its derivatives in the
7007 C corresponding virtual-bond valence angles THETA and the spherical angles
7008 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7009 C added by Urszula Kozlowska. 07/11/2007
7010 C
7011       implicit real*8 (a-h,o-z)
7012       include 'DIMENSIONS'
7013       include 'COMMON.GEO'
7014       include 'COMMON.LOCAL'
7015       include 'COMMON.VAR'
7016       include 'COMMON.SCROT'
7017       include 'COMMON.INTERACT'
7018       include 'COMMON.DERIV'
7019       include 'COMMON.CHAIN'
7020       include 'COMMON.IOUNITS'
7021       include 'COMMON.NAMES'
7022       include 'COMMON.FFIELD'
7023       include 'COMMON.CONTROL'
7024       include 'COMMON.VECTORS'
7025       double precision x_prime(3),y_prime(3),z_prime(3)
7026      &    , sumene,dsc_i,dp2_i,x(65),
7027      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7028      &    de_dxx,de_dyy,de_dzz,de_dt
7029       double precision s1_t,s1_6_t,s2_t,s2_6_t
7030       double precision
7031      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7032      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7033      & dt_dCi(3),dt_dCi1(3)
7034       common /sccalc/ time11,time12,time112,theti,it,nlobit
7035       delta=0.02d0*pi
7036       escloc=0.0D0
7037       do i=loc_start,loc_end
7038         if (itype(i).eq.ntyp1) cycle
7039         costtab(i+1) =dcos(theta(i+1))
7040         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7041         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7042         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7043         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7044         cosfac=dsqrt(cosfac2)
7045         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7046         sinfac=dsqrt(sinfac2)
7047         it=iabs(itype(i))
7048         if (it.eq.10) goto 1
7049 c
7050 C  Compute the axes of tghe local cartesian coordinates system; store in
7051 c   x_prime, y_prime and z_prime
7052 c
7053         do j=1,3
7054           x_prime(j) = 0.00
7055           y_prime(j) = 0.00
7056           z_prime(j) = 0.00
7057         enddo
7058 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7059 C     &   dc_norm(3,i+nres)
7060         do j = 1,3
7061           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7062           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7063         enddo
7064         do j = 1,3
7065           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7066         enddo
7067 c       write (2,*) "i",i
7068 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7069 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7070 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7071 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7072 c      & " xy",scalar(x_prime(1),y_prime(1)),
7073 c      & " xz",scalar(x_prime(1),z_prime(1)),
7074 c      & " yy",scalar(y_prime(1),y_prime(1)),
7075 c      & " yz",scalar(y_prime(1),z_prime(1)),
7076 c      & " zz",scalar(z_prime(1),z_prime(1))
7077 c
7078 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7079 C to local coordinate system. Store in xx, yy, zz.
7080 c
7081         xx=0.0d0
7082         yy=0.0d0
7083         zz=0.0d0
7084         do j = 1,3
7085           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7086           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7087           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7088         enddo
7089
7090         xxtab(i)=xx
7091         yytab(i)=yy
7092         zztab(i)=zz
7093 C
7094 C Compute the energy of the ith side cbain
7095 C
7096 c        write (2,*) "xx",xx," yy",yy," zz",zz
7097         it=iabs(itype(i))
7098         do j = 1,65
7099           x(j) = sc_parmin(j,it)
7100         enddo
7101 #ifdef CHECK_COORD
7102 Cc diagnostics - remove later
7103         xx1 = dcos(alph(2))
7104         yy1 = dsin(alph(2))*dcos(omeg(2))
7105         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7106         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7107      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7108      &    xx1,yy1,zz1
7109 C,"  --- ", xx_w,yy_w,zz_w
7110 c end diagnostics
7111 #endif
7112         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7113      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7114      &   + x(10)*yy*zz
7115         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7116      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7117      & + x(20)*yy*zz
7118         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7119      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7120      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7121      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7122      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7123      &  +x(40)*xx*yy*zz
7124         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7125      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7126      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7127      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7128      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7129      &  +x(60)*xx*yy*zz
7130         dsc_i   = 0.743d0+x(61)
7131         dp2_i   = 1.9d0+x(62)
7132         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7133      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7134         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7135      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7136         s1=(1+x(63))/(0.1d0 + dscp1)
7137         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7138         s2=(1+x(65))/(0.1d0 + dscp2)
7139         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7140         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7141      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7142 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7143 c     &   sumene4,
7144 c     &   dscp1,dscp2,sumene
7145 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7146         escloc = escloc + sumene
7147 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7148 c     & ,zz,xx,yy
7149 c#define DEBUG
7150 #ifdef DEBUG
7151 C
7152 C This section to check the numerical derivatives of the energy of ith side
7153 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7154 C #define DEBUG in the code to turn it on.
7155 C
7156         write (2,*) "sumene               =",sumene
7157         aincr=1.0d-7
7158         xxsave=xx
7159         xx=xx+aincr
7160         write (2,*) xx,yy,zz
7161         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7162         de_dxx_num=(sumenep-sumene)/aincr
7163         xx=xxsave
7164         write (2,*) "xx+ sumene from enesc=",sumenep
7165         yysave=yy
7166         yy=yy+aincr
7167         write (2,*) xx,yy,zz
7168         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7169         de_dyy_num=(sumenep-sumene)/aincr
7170         yy=yysave
7171         write (2,*) "yy+ sumene from enesc=",sumenep
7172         zzsave=zz
7173         zz=zz+aincr
7174         write (2,*) xx,yy,zz
7175         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7176         de_dzz_num=(sumenep-sumene)/aincr
7177         zz=zzsave
7178         write (2,*) "zz+ sumene from enesc=",sumenep
7179         costsave=cost2tab(i+1)
7180         sintsave=sint2tab(i+1)
7181         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7182         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7183         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7184         de_dt_num=(sumenep-sumene)/aincr
7185         write (2,*) " t+ sumene from enesc=",sumenep
7186         cost2tab(i+1)=costsave
7187         sint2tab(i+1)=sintsave
7188 C End of diagnostics section.
7189 #endif
7190 C
7191 C Compute the gradient of esc
7192 C
7193 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7194         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7195         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7196         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7197         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7198         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7199         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7200         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7201         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7202         pom1=(sumene3*sint2tab(i+1)+sumene1)
7203      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7204         pom2=(sumene4*cost2tab(i+1)+sumene2)
7205      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7206         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7207         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7208      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7209      &  +x(40)*yy*zz
7210         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7211         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7212      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7213      &  +x(60)*yy*zz
7214         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7215      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7216      &        +(pom1+pom2)*pom_dx
7217 #ifdef DEBUG
7218         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7219 #endif
7220 C
7221         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7222         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7223      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7224      &  +x(40)*xx*zz
7225         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7226         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7227      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7228      &  +x(59)*zz**2 +x(60)*xx*zz
7229         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7230      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7231      &        +(pom1-pom2)*pom_dy
7232 #ifdef DEBUG
7233         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7234 #endif
7235 C
7236         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7237      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7238      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7239      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7240      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7241      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7242      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7243      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7244 #ifdef DEBUG
7245         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7246 #endif
7247 C
7248         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7249      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7250      &  +pom1*pom_dt1+pom2*pom_dt2
7251 #ifdef DEBUG
7252         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7253 #endif
7254 c#undef DEBUG
7255 c
7256 C
7257        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7258        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7259        cosfac2xx=cosfac2*xx
7260        sinfac2yy=sinfac2*yy
7261        do k = 1,3
7262          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7263      &      vbld_inv(i+1)
7264          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7265      &      vbld_inv(i)
7266          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7267          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7268 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7269 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7270 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7271 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7272          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7273          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7274          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7275          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7276          dZZ_Ci1(k)=0.0d0
7277          dZZ_Ci(k)=0.0d0
7278          do j=1,3
7279            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7280      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7281            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7282      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7283          enddo
7284
7285          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7286          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7287          dZZ_XYZ(k)=vbld_inv(i+nres)*
7288      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7289 c
7290          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7291          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7292        enddo
7293
7294        do k=1,3
7295          dXX_Ctab(k,i)=dXX_Ci(k)
7296          dXX_C1tab(k,i)=dXX_Ci1(k)
7297          dYY_Ctab(k,i)=dYY_Ci(k)
7298          dYY_C1tab(k,i)=dYY_Ci1(k)
7299          dZZ_Ctab(k,i)=dZZ_Ci(k)
7300          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7301          dXX_XYZtab(k,i)=dXX_XYZ(k)
7302          dYY_XYZtab(k,i)=dYY_XYZ(k)
7303          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7304        enddo
7305
7306        do k = 1,3
7307 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7308 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7309 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7310 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7311 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7312 c     &    dt_dci(k)
7313 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7314 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7315          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7316      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7317          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7318      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7319          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7320      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7321        enddo
7322 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7323 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7324
7325 C to check gradient call subroutine check_grad
7326
7327     1 continue
7328       enddo
7329       return
7330       end
7331 c------------------------------------------------------------------------------
7332       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7333       implicit none
7334       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7335      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7336       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7337      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7338      &   + x(10)*yy*zz
7339       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7340      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7341      & + x(20)*yy*zz
7342       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7343      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7344      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7345      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7346      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7347      &  +x(40)*xx*yy*zz
7348       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7349      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7350      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7351      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7352      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7353      &  +x(60)*xx*yy*zz
7354       dsc_i   = 0.743d0+x(61)
7355       dp2_i   = 1.9d0+x(62)
7356       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7357      &          *(xx*cost2+yy*sint2))
7358       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7359      &          *(xx*cost2-yy*sint2))
7360       s1=(1+x(63))/(0.1d0 + dscp1)
7361       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7362       s2=(1+x(65))/(0.1d0 + dscp2)
7363       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7364       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7365      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7366       enesc=sumene
7367       return
7368       end
7369 #endif
7370 c------------------------------------------------------------------------------
7371       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7372 C
7373 C This procedure calculates two-body contact function g(rij) and its derivative:
7374 C
7375 C           eps0ij                                     !       x < -1
7376 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7377 C            0                                         !       x > 1
7378 C
7379 C where x=(rij-r0ij)/delta
7380 C
7381 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7382 C
7383       implicit none
7384       double precision rij,r0ij,eps0ij,fcont,fprimcont
7385       double precision x,x2,x4,delta
7386 c     delta=0.02D0*r0ij
7387 c      delta=0.2D0*r0ij
7388       x=(rij-r0ij)/delta
7389       if (x.lt.-1.0D0) then
7390         fcont=eps0ij
7391         fprimcont=0.0D0
7392       else if (x.le.1.0D0) then
7393         x2=x*x
7394         x4=x2*x2
7395         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7396         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7397       else
7398         fcont=0.0D0
7399         fprimcont=0.0D0
7400       endif
7401       return
7402       end
7403 c------------------------------------------------------------------------------
7404       subroutine splinthet(theti,delta,ss,ssder)
7405       implicit real*8 (a-h,o-z)
7406       include 'DIMENSIONS'
7407       include 'COMMON.VAR'
7408       include 'COMMON.GEO'
7409       thetup=pi-delta
7410       thetlow=delta
7411       if (theti.gt.pipol) then
7412         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7413       else
7414         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7415         ssder=-ssder
7416       endif
7417       return
7418       end
7419 c------------------------------------------------------------------------------
7420       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7421       implicit none
7422       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7423       double precision ksi,ksi2,ksi3,a1,a2,a3
7424       a1=fprim0*delta/(f1-f0)
7425       a2=3.0d0-2.0d0*a1
7426       a3=a1-2.0d0
7427       ksi=(x-x0)/delta
7428       ksi2=ksi*ksi
7429       ksi3=ksi2*ksi
7430       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7431       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7432       return
7433       end
7434 c------------------------------------------------------------------------------
7435       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7436       implicit none
7437       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7438       double precision ksi,ksi2,ksi3,a1,a2,a3
7439       ksi=(x-x0)/delta
7440       ksi2=ksi*ksi
7441       ksi3=ksi2*ksi
7442       a1=fprim0x*delta
7443       a2=3*(f1x-f0x)-2*fprim0x*delta
7444       a3=fprim0x*delta-2*(f1x-f0x)
7445       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7446       return
7447       end
7448 C-----------------------------------------------------------------------------
7449 #ifdef CRYST_TOR
7450 C-----------------------------------------------------------------------------
7451       subroutine etor(etors)
7452       implicit real*8 (a-h,o-z)
7453       include 'DIMENSIONS'
7454       include 'COMMON.VAR'
7455       include 'COMMON.GEO'
7456       include 'COMMON.LOCAL'
7457       include 'COMMON.TORSION'
7458       include 'COMMON.INTERACT'
7459       include 'COMMON.DERIV'
7460       include 'COMMON.CHAIN'
7461       include 'COMMON.NAMES'
7462       include 'COMMON.IOUNITS'
7463       include 'COMMON.FFIELD'
7464       include 'COMMON.TORCNSTR'
7465       include 'COMMON.CONTROL'
7466       logical lprn
7467 C Set lprn=.true. for debugging
7468       lprn=.false.
7469 c      lprn=.true.
7470       etors=0.0D0
7471       do i=iphi_start,iphi_end
7472       etors_ii=0.0D0
7473         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7474      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7475         itori=itortyp(itype(i-2))
7476         itori1=itortyp(itype(i-1))
7477         phii=phi(i)
7478         gloci=0.0D0
7479 C Proline-Proline pair is a special case...
7480         if (itori.eq.3 .and. itori1.eq.3) then
7481           if (phii.gt.-dwapi3) then
7482             cosphi=dcos(3*phii)
7483             fac=1.0D0/(1.0D0-cosphi)
7484             etorsi=v1(1,3,3)*fac
7485             etorsi=etorsi+etorsi
7486             etors=etors+etorsi-v1(1,3,3)
7487             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7488             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7489           endif
7490           do j=1,3
7491             v1ij=v1(j+1,itori,itori1)
7492             v2ij=v2(j+1,itori,itori1)
7493             cosphi=dcos(j*phii)
7494             sinphi=dsin(j*phii)
7495             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7496             if (energy_dec) etors_ii=etors_ii+
7497      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7498             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7499           enddo
7500         else
7501           do j=1,nterm_old
7502             v1ij=v1(j,itori,itori1)
7503             v2ij=v2(j,itori,itori1)
7504             cosphi=dcos(j*phii)
7505             sinphi=dsin(j*phii)
7506             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7507             if (energy_dec) etors_ii=etors_ii+
7508      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7509             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7510           enddo
7511         endif
7512         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7513              'etor',i,etors_ii
7514         if (lprn)
7515      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7516      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7517      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7518         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7519 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7520       enddo
7521       return
7522       end
7523 c------------------------------------------------------------------------------
7524       subroutine etor_d(etors_d)
7525       etors_d=0.0d0
7526       return
7527       end
7528 c----------------------------------------------------------------------------
7529 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7530       subroutine e_modeller(ehomology_constr)
7531       ehomology_constr=0.0d0
7532       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7533       return
7534       end
7535 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7536
7537 c------------------------------------------------------------------------------
7538       subroutine etor_d(etors_d)
7539       etors_d=0.0d0
7540       return
7541       end
7542 c----------------------------------------------------------------------------
7543 #else
7544       subroutine etor(etors)
7545       implicit real*8 (a-h,o-z)
7546       include 'DIMENSIONS'
7547       include 'COMMON.VAR'
7548       include 'COMMON.GEO'
7549       include 'COMMON.LOCAL'
7550       include 'COMMON.TORSION'
7551       include 'COMMON.INTERACT'
7552       include 'COMMON.DERIV'
7553       include 'COMMON.CHAIN'
7554       include 'COMMON.NAMES'
7555       include 'COMMON.IOUNITS'
7556       include 'COMMON.FFIELD'
7557       include 'COMMON.TORCNSTR'
7558       include 'COMMON.CONTROL'
7559       logical lprn
7560 C Set lprn=.true. for debugging
7561       lprn=.false.
7562 c     lprn=.true.
7563       etors=0.0D0
7564       do i=iphi_start,iphi_end
7565 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7566 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7567 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7568 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7569         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7570      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7571 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7572 C For introducing the NH3+ and COO- group please check the etor_d for reference
7573 C and guidance
7574         etors_ii=0.0D0
7575          if (iabs(itype(i)).eq.20) then
7576          iblock=2
7577          else
7578          iblock=1
7579          endif
7580         itori=itortyp(itype(i-2))
7581         itori1=itortyp(itype(i-1))
7582         phii=phi(i)
7583         gloci=0.0D0
7584 C Regular cosine and sine terms
7585         do j=1,nterm(itori,itori1,iblock)
7586           v1ij=v1(j,itori,itori1,iblock)
7587           v2ij=v2(j,itori,itori1,iblock)
7588           cosphi=dcos(j*phii)
7589           sinphi=dsin(j*phii)
7590           etors=etors+v1ij*cosphi+v2ij*sinphi
7591           if (energy_dec) etors_ii=etors_ii+
7592      &                v1ij*cosphi+v2ij*sinphi
7593           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7594         enddo
7595 C Lorentz terms
7596 C                         v1
7597 C  E = SUM ----------------------------------- - v1
7598 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7599 C
7600         cosphi=dcos(0.5d0*phii)
7601         sinphi=dsin(0.5d0*phii)
7602         do j=1,nlor(itori,itori1,iblock)
7603           vl1ij=vlor1(j,itori,itori1)
7604           vl2ij=vlor2(j,itori,itori1)
7605           vl3ij=vlor3(j,itori,itori1)
7606           pom=vl2ij*cosphi+vl3ij*sinphi
7607           pom1=1.0d0/(pom*pom+1.0d0)
7608           etors=etors+vl1ij*pom1
7609           if (energy_dec) etors_ii=etors_ii+
7610      &                vl1ij*pom1
7611           pom=-pom*pom1*pom1
7612           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7613         enddo
7614 C Subtract the constant term
7615         etors=etors-v0(itori,itori1,iblock)
7616           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7617      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7618         if (lprn)
7619      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7620      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7621      &  (v1(j,itori,itori1,iblock),j=1,6),
7622      &  (v2(j,itori,itori1,iblock),j=1,6)
7623         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7624 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7625       enddo
7626       return
7627       end
7628 c----------------------------------------------------------------------------
7629       subroutine etor_d(etors_d)
7630 C 6/23/01 Compute double torsional energy
7631       implicit real*8 (a-h,o-z)
7632       include 'DIMENSIONS'
7633       include 'COMMON.VAR'
7634       include 'COMMON.GEO'
7635       include 'COMMON.LOCAL'
7636       include 'COMMON.TORSION'
7637       include 'COMMON.INTERACT'
7638       include 'COMMON.DERIV'
7639       include 'COMMON.CHAIN'
7640       include 'COMMON.NAMES'
7641       include 'COMMON.IOUNITS'
7642       include 'COMMON.FFIELD'
7643       include 'COMMON.TORCNSTR'
7644       logical lprn
7645 C Set lprn=.true. for debugging
7646       lprn=.false.
7647 c     lprn=.true.
7648       etors_d=0.0D0
7649 c      write(iout,*) "a tu??"
7650       do i=iphid_start,iphid_end
7651 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7652 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7653 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7654 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7655 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7656          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7657      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7658      &  (itype(i+1).eq.ntyp1)) cycle
7659 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7660         itori=itortyp(itype(i-2))
7661         itori1=itortyp(itype(i-1))
7662         itori2=itortyp(itype(i))
7663         phii=phi(i)
7664         phii1=phi(i+1)
7665         gloci1=0.0D0
7666         gloci2=0.0D0
7667         iblock=1
7668         if (iabs(itype(i+1)).eq.20) iblock=2
7669 C Iblock=2 Proline type
7670 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7671 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7672 C        if (itype(i+1).eq.ntyp1) iblock=3
7673 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7674 C IS or IS NOT need for this
7675 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7676 C        is (itype(i-3).eq.ntyp1) ntblock=2
7677 C        ntblock is N-terminal blocking group
7678
7679 C Regular cosine and sine terms
7680         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7681 C Example of changes for NH3+ blocking group
7682 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7683 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7684           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7685           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7686           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7687           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7688           cosphi1=dcos(j*phii)
7689           sinphi1=dsin(j*phii)
7690           cosphi2=dcos(j*phii1)
7691           sinphi2=dsin(j*phii1)
7692           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7693      &     v2cij*cosphi2+v2sij*sinphi2
7694           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7695           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7696         enddo
7697         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7698           do l=1,k-1
7699             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7700             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7701             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7702             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7703             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7704             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7705             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7706             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7707             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7708      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7709             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7710      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7711             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7712      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7713           enddo
7714         enddo
7715         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7716         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7717       enddo
7718       return
7719       end
7720 #endif
7721 C----------------------------------------------------------------------------------
7722 C The rigorous attempt to derive energy function
7723       subroutine etor_kcc(etors)
7724       implicit real*8 (a-h,o-z)
7725       include 'DIMENSIONS'
7726       include 'COMMON.VAR'
7727       include 'COMMON.GEO'
7728       include 'COMMON.LOCAL'
7729       include 'COMMON.TORSION'
7730       include 'COMMON.INTERACT'
7731       include 'COMMON.DERIV'
7732       include 'COMMON.CHAIN'
7733       include 'COMMON.NAMES'
7734       include 'COMMON.IOUNITS'
7735       include 'COMMON.FFIELD'
7736       include 'COMMON.TORCNSTR'
7737       include 'COMMON.CONTROL'
7738       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7739       logical lprn
7740 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7741 C Set lprn=.true. for debugging
7742       lprn=energy_dec
7743 c     lprn=.true.
7744 C      print *,"wchodze kcc"
7745       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7746       etors=0.0D0
7747       do i=iphi_start,iphi_end
7748 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7749 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7750 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7751 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7752         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7753      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7754         itori=itortyp(itype(i-2))
7755         itori1=itortyp(itype(i-1))
7756         phii=phi(i)
7757         glocig=0.0D0
7758         glocit1=0.0d0
7759         glocit2=0.0d0
7760 C to avoid multiple devision by 2
7761 c        theti22=0.5d0*theta(i)
7762 C theta 12 is the theta_1 /2
7763 C theta 22 is theta_2 /2
7764 c        theti12=0.5d0*theta(i-1)
7765 C and appropriate sinus function
7766         sinthet1=dsin(theta(i-1))
7767         sinthet2=dsin(theta(i))
7768         costhet1=dcos(theta(i-1))
7769         costhet2=dcos(theta(i))
7770 C to speed up lets store its mutliplication
7771         sint1t2=sinthet2*sinthet1
7772         sint1t2n=1.0d0
7773 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7774 C +d_n*sin(n*gamma)) *
7775 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7776 C we have two sum 1) Non-Chebyshev which is with n and gamma
7777         nval=nterm_kcc_Tb(itori,itori1)
7778         c1(0)=0.0d0
7779         c2(0)=0.0d0
7780         c1(1)=1.0d0
7781         c2(1)=1.0d0
7782         do j=2,nval
7783           c1(j)=c1(j-1)*costhet1
7784           c2(j)=c2(j-1)*costhet2
7785         enddo
7786         etori=0.0d0
7787         do j=1,nterm_kcc(itori,itori1)
7788           cosphi=dcos(j*phii)
7789           sinphi=dsin(j*phii)
7790           sint1t2n1=sint1t2n
7791           sint1t2n=sint1t2n*sint1t2
7792           sumvalc=0.0d0
7793           gradvalct1=0.0d0
7794           gradvalct2=0.0d0
7795           do k=1,nval
7796             do l=1,nval
7797               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7798               gradvalct1=gradvalct1+
7799      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7800               gradvalct2=gradvalct2+
7801      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7802             enddo
7803           enddo
7804           gradvalct1=-gradvalct1*sinthet1
7805           gradvalct2=-gradvalct2*sinthet2
7806           sumvals=0.0d0
7807           gradvalst1=0.0d0
7808           gradvalst2=0.0d0
7809           do k=1,nval
7810             do l=1,nval
7811               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7812               gradvalst1=gradvalst1+
7813      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7814               gradvalst2=gradvalst2+
7815      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7816             enddo
7817           enddo
7818           gradvalst1=-gradvalst1*sinthet1
7819           gradvalst2=-gradvalst2*sinthet2
7820           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7821           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7822 C glocig is the gradient local i site in gamma
7823           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7824 C now gradient over theta_1
7825           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7826      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7827           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7828      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7829         enddo ! j
7830         etors=etors+etori
7831 C derivative over gamma
7832         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7833 C derivative over theta1
7834         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7835 C now derivative over theta2
7836         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7837         if (lprn) then
7838           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7839      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7840           write (iout,*) "c1",(c1(k),k=0,nval),
7841      &    " c2",(c2(k),k=0,nval)
7842         endif
7843       enddo
7844       return
7845       end
7846 c---------------------------------------------------------------------------------------------
7847       subroutine etor_constr(edihcnstr)
7848       implicit real*8 (a-h,o-z)
7849       include 'DIMENSIONS'
7850       include 'COMMON.VAR'
7851       include 'COMMON.GEO'
7852       include 'COMMON.LOCAL'
7853       include 'COMMON.TORSION'
7854       include 'COMMON.INTERACT'
7855       include 'COMMON.DERIV'
7856       include 'COMMON.CHAIN'
7857       include 'COMMON.NAMES'
7858       include 'COMMON.IOUNITS'
7859       include 'COMMON.FFIELD'
7860       include 'COMMON.TORCNSTR'
7861       include 'COMMON.BOUNDS'
7862       include 'COMMON.CONTROL'
7863 ! 6/20/98 - dihedral angle constraints
7864       edihcnstr=0.0d0
7865 c      do i=1,ndih_constr
7866       if (raw_psipred) then
7867         do i=idihconstr_start,idihconstr_end
7868           itori=idih_constr(i)
7869           phii=phi(itori)
7870           gaudih_i=vpsipred(1,i)
7871           gauder_i=0.0d0
7872           do j=1,2
7873             s = sdihed(j,i)
7874             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7875             dexpcos_i=dexp(-cos_i*cos_i)
7876             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7877             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7878      &            *cos_i*dexpcos_i/s**2
7879           enddo
7880           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7881           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7882           if (energy_dec)
7883      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7884      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7885      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7886      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7887      &     -wdihc*dlog(gaudih_i)
7888         enddo
7889       else
7890
7891       do i=idihconstr_start,idihconstr_end
7892         itori=idih_constr(i)
7893         phii=phi(itori)
7894         difi=pinorm(phii-phi0(i))
7895         if (difi.gt.drange(i)) then
7896           difi=difi-drange(i)
7897           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7898           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7899         else if (difi.lt.-drange(i)) then
7900           difi=difi+drange(i)
7901           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7902           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7903         else
7904           difi=0.0
7905         endif
7906       enddo
7907
7908       endif
7909
7910       return
7911       end
7912 c----------------------------------------------------------------------------
7913 c MODELLER restraint function
7914       subroutine e_modeller(ehomology_constr)
7915       implicit none
7916       include 'DIMENSIONS'
7917
7918       double precision ehomology_constr
7919       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7920       integer katy, odleglosci, test7
7921       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7922       real*8 Eval,Erot
7923       real*8 distance(max_template),distancek(max_template),
7924      &    min_odl,godl(max_template),dih_diff(max_template)
7925
7926 c
7927 c     FP - 30/10/2014 Temporary specifications for homology restraints
7928 c
7929       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7930      &                 sgtheta
7931       double precision, dimension (maxres) :: guscdiff,usc_diff
7932       double precision, dimension (max_template) ::
7933      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7934      &           theta_diff
7935       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7936      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7937      & betai,sum_sgodl,dij
7938       double precision dist,pinorm
7939 c
7940       include 'COMMON.SBRIDGE'
7941       include 'COMMON.CHAIN'
7942       include 'COMMON.GEO'
7943       include 'COMMON.DERIV'
7944       include 'COMMON.LOCAL'
7945       include 'COMMON.INTERACT'
7946       include 'COMMON.VAR'
7947       include 'COMMON.IOUNITS'
7948 c      include 'COMMON.MD'
7949       include 'COMMON.CONTROL'
7950       include 'COMMON.HOMOLOGY'
7951       include 'COMMON.QRESTR'
7952 c
7953 c     From subroutine Econstr_back
7954 c
7955       include 'COMMON.NAMES'
7956       include 'COMMON.TIME1'
7957 c
7958
7959
7960       do i=1,max_template
7961         distancek(i)=9999999.9
7962       enddo
7963
7964
7965       odleg=0.0d0
7966
7967 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7968 c function)
7969 C AL 5/2/14 - Introduce list of restraints
7970 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7971 #ifdef DEBUG
7972       write(iout,*) "------- dist restrs start -------"
7973 #endif
7974       do ii = link_start_homo,link_end_homo
7975          i = ires_homo(ii)
7976          j = jres_homo(ii)
7977          dij=dist(i,j)
7978 c        write (iout,*) "dij(",i,j,") =",dij
7979          nexl=0
7980          do k=1,constr_homology
7981 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7982            if(.not.l_homo(k,ii)) then
7983              nexl=nexl+1
7984              cycle
7985            endif
7986            distance(k)=odl(k,ii)-dij
7987 c          write (iout,*) "distance(",k,") =",distance(k)
7988 c
7989 c          For Gaussian-type Urestr
7990 c
7991            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7992 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7993 c          write (iout,*) "distancek(",k,") =",distancek(k)
7994 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7995 c
7996 c          For Lorentzian-type Urestr
7997 c
7998            if (waga_dist.lt.0.0d0) then
7999               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8000               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8001      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8002            endif
8003          enddo
8004
8005 c         min_odl=minval(distancek)
8006          do kk=1,constr_homology
8007           if(l_homo(kk,ii)) then
8008             min_odl=distancek(kk)
8009             exit
8010           endif
8011          enddo
8012          do kk=1,constr_homology
8013           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8014      &              min_odl=distancek(kk)
8015          enddo
8016
8017 c        write (iout,* )"min_odl",min_odl
8018 #ifdef DEBUG
8019          write (iout,*) "ij dij",i,j,dij
8020          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8021          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8022          write (iout,* )"min_odl",min_odl
8023 #endif
8024 #ifdef OLDRESTR
8025          odleg2=0.0d0
8026 #else
8027          if (waga_dist.ge.0.0d0) then
8028            odleg2=nexl
8029          else
8030            odleg2=0.0d0
8031          endif
8032 #endif
8033          do k=1,constr_homology
8034 c Nie wiem po co to liczycie jeszcze raz!
8035 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8036 c     &              (2*(sigma_odl(i,j,k))**2))
8037            if(.not.l_homo(k,ii)) cycle
8038            if (waga_dist.ge.0.0d0) then
8039 c
8040 c          For Gaussian-type Urestr
8041 c
8042             godl(k)=dexp(-distancek(k)+min_odl)
8043             odleg2=odleg2+godl(k)
8044 c
8045 c          For Lorentzian-type Urestr
8046 c
8047            else
8048             odleg2=odleg2+distancek(k)
8049            endif
8050
8051 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8052 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8053 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8054 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8055
8056          enddo
8057 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8058 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8059 #ifdef DEBUG
8060          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8061          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8062 #endif
8063            if (waga_dist.ge.0.0d0) then
8064 c
8065 c          For Gaussian-type Urestr
8066 c
8067               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8068 c
8069 c          For Lorentzian-type Urestr
8070 c
8071            else
8072               odleg=odleg+odleg2/constr_homology
8073            endif
8074 c
8075 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8076 c Gradient
8077 c
8078 c          For Gaussian-type Urestr
8079 c
8080          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8081          sum_sgodl=0.0d0
8082          do k=1,constr_homology
8083 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8084 c     &           *waga_dist)+min_odl
8085 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8086 c
8087          if(.not.l_homo(k,ii)) cycle
8088          if (waga_dist.ge.0.0d0) then
8089 c          For Gaussian-type Urestr
8090 c
8091            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8092 c
8093 c          For Lorentzian-type Urestr
8094 c
8095          else
8096            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8097      &           sigma_odlir(k,ii)**2)**2)
8098          endif
8099            sum_sgodl=sum_sgodl+sgodl
8100
8101 c            sgodl2=sgodl2+sgodl
8102 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8103 c      write(iout,*) "constr_homology=",constr_homology
8104 c      write(iout,*) i, j, k, "TEST K"
8105          enddo
8106          if (waga_dist.ge.0.0d0) then
8107 c
8108 c          For Gaussian-type Urestr
8109 c
8110             grad_odl3=waga_homology(iset)*waga_dist
8111      &                *sum_sgodl/(sum_godl*dij)
8112 c
8113 c          For Lorentzian-type Urestr
8114 c
8115          else
8116 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8117 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8118             grad_odl3=-waga_homology(iset)*waga_dist*
8119      &                sum_sgodl/(constr_homology*dij)
8120          endif
8121 c
8122 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8123
8124
8125 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8126 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8127 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8128
8129 ccc      write(iout,*) godl, sgodl, grad_odl3
8130
8131 c          grad_odl=grad_odl+grad_odl3
8132
8133          do jik=1,3
8134             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8135 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8136 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8137 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8138             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8139             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8140 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8141 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8142 c         if (i.eq.25.and.j.eq.27) then
8143 c         write(iout,*) "jik",jik,"i",i,"j",j
8144 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8145 c         write(iout,*) "grad_odl3",grad_odl3
8146 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8147 c         write(iout,*) "ggodl",ggodl
8148 c         write(iout,*) "ghpbc(",jik,i,")",
8149 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8150 c     &                 ghpbc(jik,j)
8151 c         endif
8152          enddo
8153 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8154 ccc     & dLOG(odleg2),"-odleg=", -odleg
8155
8156       enddo ! ii-loop for dist
8157 #ifdef DEBUG
8158       write(iout,*) "------- dist restrs end -------"
8159 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8160 c    &     waga_d.eq.1.0d0) call sum_gradient
8161 #endif
8162 c Pseudo-energy and gradient from dihedral-angle restraints from
8163 c homology templates
8164 c      write (iout,*) "End of distance loop"
8165 c      call flush(iout)
8166       kat=0.0d0
8167 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8168 #ifdef DEBUG
8169       write(iout,*) "------- dih restrs start -------"
8170       do i=idihconstr_start_homo,idihconstr_end_homo
8171         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8172       enddo
8173 #endif
8174       do i=idihconstr_start_homo,idihconstr_end_homo
8175         kat2=0.0d0
8176 c        betai=beta(i,i+1,i+2,i+3)
8177         betai = phi(i)
8178 c       write (iout,*) "betai =",betai
8179         do k=1,constr_homology
8180           dih_diff(k)=pinorm(dih(k,i)-betai)
8181 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8182 cd     &                  ,sigma_dih(k,i)
8183 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8184 c     &                                   -(6.28318-dih_diff(i,k))
8185 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8186 c     &                                   6.28318+dih_diff(i,k)
8187 #ifdef OLD_DIHED
8188           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8189 #else
8190           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8191 #endif
8192 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8193           gdih(k)=dexp(kat3)
8194           kat2=kat2+gdih(k)
8195 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8196 c          write(*,*)""
8197         enddo
8198 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8199 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8200 #ifdef DEBUG
8201         write (iout,*) "i",i," betai",betai," kat2",kat2
8202         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8203 #endif
8204         if (kat2.le.1.0d-14) cycle
8205         kat=kat-dLOG(kat2/constr_homology)
8206 c       write (iout,*) "kat",kat ! sum of -ln-s
8207
8208 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8209 ccc     & dLOG(kat2), "-kat=", -kat
8210
8211 c ----------------------------------------------------------------------
8212 c Gradient
8213 c ----------------------------------------------------------------------
8214
8215         sum_gdih=kat2
8216         sum_sgdih=0.0d0
8217         do k=1,constr_homology
8218 #ifdef OLD_DIHED
8219           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8220 #else
8221           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8222 #endif
8223 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8224           sum_sgdih=sum_sgdih+sgdih
8225         enddo
8226 c       grad_dih3=sum_sgdih/sum_gdih
8227         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8228
8229 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8230 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8231 ccc     & gloc(nphi+i-3,icg)
8232         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8233 c        if (i.eq.25) then
8234 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8235 c        endif
8236 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8237 ccc     & gloc(nphi+i-3,icg)
8238
8239       enddo ! i-loop for dih
8240 #ifdef DEBUG
8241       write(iout,*) "------- dih restrs end -------"
8242 #endif
8243
8244 c Pseudo-energy and gradient for theta angle restraints from
8245 c homology templates
8246 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8247 c adapted
8248
8249 c
8250 c     For constr_homology reference structures (FP)
8251 c
8252 c     Uconst_back_tot=0.0d0
8253       Eval=0.0d0
8254       Erot=0.0d0
8255 c     Econstr_back legacy
8256       do i=1,nres
8257 c     do i=ithet_start,ithet_end
8258        dutheta(i)=0.0d0
8259 c     enddo
8260 c     do i=loc_start,loc_end
8261         do j=1,3
8262           duscdiff(j,i)=0.0d0
8263           duscdiffx(j,i)=0.0d0
8264         enddo
8265       enddo
8266 c
8267 c     do iref=1,nref
8268 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8269 c     write (iout,*) "waga_theta",waga_theta
8270       if (waga_theta.gt.0.0d0) then
8271 #ifdef DEBUG
8272       write (iout,*) "usampl",usampl
8273       write(iout,*) "------- theta restrs start -------"
8274 c     do i=ithet_start,ithet_end
8275 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8276 c     enddo
8277 #endif
8278 c     write (iout,*) "maxres",maxres,"nres",nres
8279
8280       do i=ithet_start,ithet_end
8281 c
8282 c     do i=1,nfrag_back
8283 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8284 c
8285 c Deviation of theta angles wrt constr_homology ref structures
8286 c
8287         utheta_i=0.0d0 ! argument of Gaussian for single k
8288         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8289 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8290 c       over residues in a fragment
8291 c       write (iout,*) "theta(",i,")=",theta(i)
8292         do k=1,constr_homology
8293 c
8294 c         dtheta_i=theta(j)-thetaref(j,iref)
8295 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8296           theta_diff(k)=thetatpl(k,i)-theta(i)
8297 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8298 cd     &                  ,sigma_theta(k,i)
8299
8300 c
8301           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8302 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8303           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8304           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8305 c         Gradient for single Gaussian restraint in subr Econstr_back
8306 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8307 c
8308         enddo
8309 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8310 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8311
8312 c
8313 c         Gradient for multiple Gaussian restraint
8314         sum_gtheta=gutheta_i
8315         sum_sgtheta=0.0d0
8316         do k=1,constr_homology
8317 c        New generalized expr for multiple Gaussian from Econstr_back
8318          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8319 c
8320 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8321           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8322         enddo
8323 c       Final value of gradient using same var as in Econstr_back
8324         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8325      &      +sum_sgtheta/sum_gtheta*waga_theta
8326      &               *waga_homology(iset)
8327 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8328 c     &               *waga_homology(iset)
8329 c       dutheta(i)=sum_sgtheta/sum_gtheta
8330 c
8331 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8332         Eval=Eval-dLOG(gutheta_i/constr_homology)
8333 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8334 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8335 c       Uconst_back=Uconst_back+utheta(i)
8336       enddo ! (i-loop for theta)
8337 #ifdef DEBUG
8338       write(iout,*) "------- theta restrs end -------"
8339 #endif
8340       endif
8341 c
8342 c Deviation of local SC geometry
8343 c
8344 c Separation of two i-loops (instructed by AL - 11/3/2014)
8345 c
8346 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8347 c     write (iout,*) "waga_d",waga_d
8348
8349 #ifdef DEBUG
8350       write(iout,*) "------- SC restrs start -------"
8351       write (iout,*) "Initial duscdiff,duscdiffx"
8352       do i=loc_start,loc_end
8353         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8354      &                 (duscdiffx(jik,i),jik=1,3)
8355       enddo
8356 #endif
8357       do i=loc_start,loc_end
8358         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8359         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8360 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8361 c       write(iout,*) "xxtab, yytab, zztab"
8362 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8363         do k=1,constr_homology
8364 c
8365           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8366 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8367           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8368           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8369 c         write(iout,*) "dxx, dyy, dzz"
8370 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8371 c
8372           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8373 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8374 c         uscdiffk(k)=usc_diff(i)
8375           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8376 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8377 c     &       " guscdiff2",guscdiff2(k)
8378           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8379 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8380 c     &      xxref(j),yyref(j),zzref(j)
8381         enddo
8382 c
8383 c       Gradient
8384 c
8385 c       Generalized expression for multiple Gaussian acc to that for a single
8386 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8387 c
8388 c       Original implementation
8389 c       sum_guscdiff=guscdiff(i)
8390 c
8391 c       sum_sguscdiff=0.0d0
8392 c       do k=1,constr_homology
8393 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8394 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8395 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8396 c       enddo
8397 c
8398 c       Implementation of new expressions for gradient (Jan. 2015)
8399 c
8400 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8401         do k=1,constr_homology
8402 c
8403 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8404 c       before. Now the drivatives should be correct
8405 c
8406           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8407 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8408           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8409           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8410 c
8411 c         New implementation
8412 c
8413           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8414      &                 sigma_d(k,i) ! for the grad wrt r'
8415 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8416 c
8417 c
8418 c        New implementation
8419          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8420          do jik=1,3
8421             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8422      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8423      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8424             duscdiff(jik,i)=duscdiff(jik,i)+
8425      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8426      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8427             duscdiffx(jik,i)=duscdiffx(jik,i)+
8428      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8429      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8430 c
8431 #ifdef DEBUG
8432              write(iout,*) "jik",jik,"i",i
8433              write(iout,*) "dxx, dyy, dzz"
8434              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8435              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8436 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8437 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8438 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8439 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8440 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8441 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8442 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8443 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8444 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8445 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8446 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8447 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8448 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8449 c            endif
8450 #endif
8451          enddo
8452         enddo
8453 c
8454 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8455 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8456 c
8457 c        write (iout,*) i," uscdiff",uscdiff(i)
8458 c
8459 c Put together deviations from local geometry
8460
8461 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8462 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8463         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8464 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8465 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8466 c       Uconst_back=Uconst_back+usc_diff(i)
8467 c
8468 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8469 c
8470 c     New implment: multiplied by sum_sguscdiff
8471 c
8472
8473       enddo ! (i-loop for dscdiff)
8474
8475 c      endif
8476
8477 #ifdef DEBUG
8478       write(iout,*) "------- SC restrs end -------"
8479         write (iout,*) "------ After SC loop in e_modeller ------"
8480         do i=loc_start,loc_end
8481          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8482          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8483         enddo
8484       if (waga_theta.eq.1.0d0) then
8485       write (iout,*) "in e_modeller after SC restr end: dutheta"
8486       do i=ithet_start,ithet_end
8487         write (iout,*) i,dutheta(i)
8488       enddo
8489       endif
8490       if (waga_d.eq.1.0d0) then
8491       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8492       do i=1,nres
8493         write (iout,*) i,(duscdiff(j,i),j=1,3)
8494         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8495       enddo
8496       endif
8497 #endif
8498
8499 c Total energy from homology restraints
8500 #ifdef DEBUG
8501       write (iout,*) "odleg",odleg," kat",kat
8502 #endif
8503 c
8504 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8505 c
8506 c     ehomology_constr=odleg+kat
8507 c
8508 c     For Lorentzian-type Urestr
8509 c
8510
8511       if (waga_dist.ge.0.0d0) then
8512 c
8513 c          For Gaussian-type Urestr
8514 c
8515         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8516      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8517 c     write (iout,*) "ehomology_constr=",ehomology_constr
8518       else
8519 c
8520 c          For Lorentzian-type Urestr
8521 c
8522         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8523      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8524 c     write (iout,*) "ehomology_constr=",ehomology_constr
8525       endif
8526 #ifdef DEBUG
8527       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8528      & "Eval",waga_theta,eval,
8529      &   "Erot",waga_d,Erot
8530       write (iout,*) "ehomology_constr",ehomology_constr
8531 #endif
8532       return
8533 c
8534 c FP 01/15 end
8535 c
8536   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8537   747 format(a12,i4,i4,i4,f8.3,f8.3)
8538   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8539   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8540   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8541      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8542       end
8543 c----------------------------------------------------------------------------
8544 C The rigorous attempt to derive energy function
8545       subroutine ebend_kcc(etheta)
8546
8547       implicit real*8 (a-h,o-z)
8548       include 'DIMENSIONS'
8549       include 'COMMON.VAR'
8550       include 'COMMON.GEO'
8551       include 'COMMON.LOCAL'
8552       include 'COMMON.TORSION'
8553       include 'COMMON.INTERACT'
8554       include 'COMMON.DERIV'
8555       include 'COMMON.CHAIN'
8556       include 'COMMON.NAMES'
8557       include 'COMMON.IOUNITS'
8558       include 'COMMON.FFIELD'
8559       include 'COMMON.TORCNSTR'
8560       include 'COMMON.CONTROL'
8561       logical lprn
8562       double precision thybt1(maxang_kcc)
8563 C Set lprn=.true. for debugging
8564       lprn=energy_dec
8565 c     lprn=.true.
8566 C      print *,"wchodze kcc"
8567       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8568       etheta=0.0D0
8569       do i=ithet_start,ithet_end
8570 c        print *,i,itype(i-1),itype(i),itype(i-2)
8571         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8572      &  .or.itype(i).eq.ntyp1) cycle
8573         iti=iabs(itortyp(itype(i-1)))
8574         sinthet=dsin(theta(i))
8575         costhet=dcos(theta(i))
8576         do j=1,nbend_kcc_Tb(iti)
8577           thybt1(j)=v1bend_chyb(j,iti)
8578         enddo
8579         sumth1thyb=v1bend_chyb(0,iti)+
8580      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8581         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8582      &    sumth1thyb
8583         ihelp=nbend_kcc_Tb(iti)-1
8584         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8585         etheta=etheta+sumth1thyb
8586 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8587         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8588       enddo
8589       return
8590       end
8591 c-------------------------------------------------------------------------------------
8592       subroutine etheta_constr(ethetacnstr)
8593
8594       implicit real*8 (a-h,o-z)
8595       include 'DIMENSIONS'
8596       include 'COMMON.VAR'
8597       include 'COMMON.GEO'
8598       include 'COMMON.LOCAL'
8599       include 'COMMON.TORSION'
8600       include 'COMMON.INTERACT'
8601       include 'COMMON.DERIV'
8602       include 'COMMON.CHAIN'
8603       include 'COMMON.NAMES'
8604       include 'COMMON.IOUNITS'
8605       include 'COMMON.FFIELD'
8606       include 'COMMON.TORCNSTR'
8607       include 'COMMON.CONTROL'
8608       ethetacnstr=0.0d0
8609 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8610       do i=ithetaconstr_start,ithetaconstr_end
8611         itheta=itheta_constr(i)
8612         thetiii=theta(itheta)
8613         difi=pinorm(thetiii-theta_constr0(i))
8614         if (difi.gt.theta_drange(i)) then
8615           difi=difi-theta_drange(i)
8616           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8617           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8618      &    +for_thet_constr(i)*difi**3
8619         else if (difi.lt.-drange(i)) then
8620           difi=difi+drange(i)
8621           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8622           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8623      &    +for_thet_constr(i)*difi**3
8624         else
8625           difi=0.0
8626         endif
8627        if (energy_dec) then
8628         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8629      &    i,itheta,rad2deg*thetiii,
8630      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8631      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8632      &    gloc(itheta+nphi-2,icg)
8633         endif
8634       enddo
8635       return
8636       end
8637 c------------------------------------------------------------------------------
8638       subroutine eback_sc_corr(esccor)
8639 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8640 c        conformational states; temporarily implemented as differences
8641 c        between UNRES torsional potentials (dependent on three types of
8642 c        residues) and the torsional potentials dependent on all 20 types
8643 c        of residues computed from AM1  energy surfaces of terminally-blocked
8644 c        amino-acid residues.
8645       implicit real*8 (a-h,o-z)
8646       include 'DIMENSIONS'
8647       include 'COMMON.VAR'
8648       include 'COMMON.GEO'
8649       include 'COMMON.LOCAL'
8650       include 'COMMON.TORSION'
8651       include 'COMMON.SCCOR'
8652       include 'COMMON.INTERACT'
8653       include 'COMMON.DERIV'
8654       include 'COMMON.CHAIN'
8655       include 'COMMON.NAMES'
8656       include 'COMMON.IOUNITS'
8657       include 'COMMON.FFIELD'
8658       include 'COMMON.CONTROL'
8659       logical lprn
8660 C Set lprn=.true. for debugging
8661       lprn=.false.
8662 c      lprn=.true.
8663 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8664       esccor=0.0D0
8665       do i=itau_start,itau_end
8666         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8667         esccor_ii=0.0D0
8668         isccori=isccortyp(itype(i-2))
8669         isccori1=isccortyp(itype(i-1))
8670 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8671         phii=phi(i)
8672         do intertyp=1,3 !intertyp
8673 cc Added 09 May 2012 (Adasko)
8674 cc  Intertyp means interaction type of backbone mainchain correlation:
8675 c   1 = SC...Ca...Ca...Ca
8676 c   2 = Ca...Ca...Ca...SC
8677 c   3 = SC...Ca...Ca...SCi
8678         gloci=0.0D0
8679         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8680      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8681      &      (itype(i-1).eq.ntyp1)))
8682      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8683      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8684      &     .or.(itype(i).eq.ntyp1)))
8685      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8686      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8687      &      (itype(i-3).eq.ntyp1)))) cycle
8688         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8689         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8690      & cycle
8691        do j=1,nterm_sccor(isccori,isccori1)
8692           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8693           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8694           cosphi=dcos(j*tauangle(intertyp,i))
8695           sinphi=dsin(j*tauangle(intertyp,i))
8696           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8697           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8698         enddo
8699 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8700         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8701         if (lprn)
8702      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8703      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8704      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8705      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8706         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8707        enddo !intertyp
8708       enddo
8709
8710       return
8711       end
8712 c----------------------------------------------------------------------------
8713       subroutine multibody(ecorr)
8714 C This subroutine calculates multi-body contributions to energy following
8715 C the idea of Skolnick et al. If side chains I and J make a contact and
8716 C at the same time side chains I+1 and J+1 make a contact, an extra
8717 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8718       implicit real*8 (a-h,o-z)
8719       include 'DIMENSIONS'
8720       include 'COMMON.IOUNITS'
8721       include 'COMMON.DERIV'
8722       include 'COMMON.INTERACT'
8723       include 'COMMON.CONTACTS'
8724       double precision gx(3),gx1(3)
8725       logical lprn
8726
8727 C Set lprn=.true. for debugging
8728       lprn=.false.
8729
8730       if (lprn) then
8731         write (iout,'(a)') 'Contact function values:'
8732         do i=nnt,nct-2
8733           write (iout,'(i2,20(1x,i2,f10.5))')
8734      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8735         enddo
8736       endif
8737       ecorr=0.0D0
8738       do i=nnt,nct
8739         do j=1,3
8740           gradcorr(j,i)=0.0D0
8741           gradxorr(j,i)=0.0D0
8742         enddo
8743       enddo
8744       do i=nnt,nct-2
8745
8746         DO ISHIFT = 3,4
8747
8748         i1=i+ishift
8749         num_conti=num_cont(i)
8750         num_conti1=num_cont(i1)
8751         do jj=1,num_conti
8752           j=jcont(jj,i)
8753           do kk=1,num_conti1
8754             j1=jcont(kk,i1)
8755             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8756 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8757 cd   &                   ' ishift=',ishift
8758 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8759 C The system gains extra energy.
8760               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8761             endif   ! j1==j+-ishift
8762           enddo     ! kk
8763         enddo       ! jj
8764
8765         ENDDO ! ISHIFT
8766
8767       enddo         ! i
8768       return
8769       end
8770 c------------------------------------------------------------------------------
8771       double precision function esccorr(i,j,k,l,jj,kk)
8772       implicit real*8 (a-h,o-z)
8773       include 'DIMENSIONS'
8774       include 'COMMON.IOUNITS'
8775       include 'COMMON.DERIV'
8776       include 'COMMON.INTERACT'
8777       include 'COMMON.CONTACTS'
8778       include 'COMMON.SHIELD'
8779       double precision gx(3),gx1(3)
8780       logical lprn
8781       lprn=.false.
8782       eij=facont(jj,i)
8783       ekl=facont(kk,k)
8784 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8785 C Calculate the multi-body contribution to energy.
8786 C Calculate multi-body contributions to the gradient.
8787 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8788 cd   & k,l,(gacont(m,kk,k),m=1,3)
8789       do m=1,3
8790         gx(m) =ekl*gacont(m,jj,i)
8791         gx1(m)=eij*gacont(m,kk,k)
8792         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8793         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8794         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8795         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8796       enddo
8797       do m=i,j-1
8798         do ll=1,3
8799           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8800         enddo
8801       enddo
8802       do m=k,l-1
8803         do ll=1,3
8804           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8805         enddo
8806       enddo
8807       esccorr=-eij*ekl
8808       return
8809       end
8810 c------------------------------------------------------------------------------
8811       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8812 C This subroutine calculates multi-body contributions to hydrogen-bonding
8813       implicit real*8 (a-h,o-z)
8814       include 'DIMENSIONS'
8815       include 'COMMON.IOUNITS'
8816 #ifdef MPI
8817       include "mpif.h"
8818       parameter (max_cont=maxconts)
8819       parameter (max_dim=26)
8820       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8821       double precision zapas(max_dim,maxconts,max_fg_procs),
8822      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8823       common /przechowalnia/ zapas
8824       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8825      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8826 #endif
8827       include 'COMMON.SETUP'
8828       include 'COMMON.FFIELD'
8829       include 'COMMON.DERIV'
8830       include 'COMMON.INTERACT'
8831       include 'COMMON.CONTACTS'
8832       include 'COMMON.CONTROL'
8833       include 'COMMON.LOCAL'
8834       double precision gx(3),gx1(3),time00
8835       logical lprn,ldone
8836
8837 C Set lprn=.true. for debugging
8838       lprn=.false.
8839 #ifdef MPI
8840       n_corr=0
8841       n_corr1=0
8842       if (nfgtasks.le.1) goto 30
8843       if (lprn) then
8844         write (iout,'(a)') 'Contact function values before RECEIVE:'
8845         do i=nnt,nct-2
8846           write (iout,'(2i3,50(1x,i2,f5.2))')
8847      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8848      &    j=1,num_cont_hb(i))
8849         enddo
8850         call flush(iout)
8851       endif
8852       do i=1,ntask_cont_from
8853         ncont_recv(i)=0
8854       enddo
8855       do i=1,ntask_cont_to
8856         ncont_sent(i)=0
8857       enddo
8858 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8859 c     & ntask_cont_to
8860 C Make the list of contacts to send to send to other procesors
8861 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8862 c      call flush(iout)
8863       do i=iturn3_start,iturn3_end
8864 c        write (iout,*) "make contact list turn3",i," num_cont",
8865 c     &    num_cont_hb(i)
8866         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8867       enddo
8868       do i=iturn4_start,iturn4_end
8869 c        write (iout,*) "make contact list turn4",i," num_cont",
8870 c     &   num_cont_hb(i)
8871         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8872       enddo
8873       do ii=1,nat_sent
8874         i=iat_sent(ii)
8875 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8876 c     &    num_cont_hb(i)
8877         do j=1,num_cont_hb(i)
8878         do k=1,4
8879           jjc=jcont_hb(j,i)
8880           iproc=iint_sent_local(k,jjc,ii)
8881 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8882           if (iproc.gt.0) then
8883             ncont_sent(iproc)=ncont_sent(iproc)+1
8884             nn=ncont_sent(iproc)
8885             zapas(1,nn,iproc)=i
8886             zapas(2,nn,iproc)=jjc
8887             zapas(3,nn,iproc)=facont_hb(j,i)
8888             zapas(4,nn,iproc)=ees0p(j,i)
8889             zapas(5,nn,iproc)=ees0m(j,i)
8890             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8891             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8892             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8893             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8894             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8895             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8896             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8897             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8898             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8899             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8900             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8901             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8902             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8903             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8904             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8905             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8906             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8907             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8908             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8909             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8910             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8911           endif
8912         enddo
8913         enddo
8914       enddo
8915       if (lprn) then
8916       write (iout,*)
8917      &  "Numbers of contacts to be sent to other processors",
8918      &  (ncont_sent(i),i=1,ntask_cont_to)
8919       write (iout,*) "Contacts sent"
8920       do ii=1,ntask_cont_to
8921         nn=ncont_sent(ii)
8922         iproc=itask_cont_to(ii)
8923         write (iout,*) nn," contacts to processor",iproc,
8924      &   " of CONT_TO_COMM group"
8925         do i=1,nn
8926           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8927         enddo
8928       enddo
8929       call flush(iout)
8930       endif
8931       CorrelType=477
8932       CorrelID=fg_rank+1
8933       CorrelType1=478
8934       CorrelID1=nfgtasks+fg_rank+1
8935       ireq=0
8936 C Receive the numbers of needed contacts from other processors
8937       do ii=1,ntask_cont_from
8938         iproc=itask_cont_from(ii)
8939         ireq=ireq+1
8940         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8941      &    FG_COMM,req(ireq),IERR)
8942       enddo
8943 c      write (iout,*) "IRECV ended"
8944 c      call flush(iout)
8945 C Send the number of contacts needed by other processors
8946       do ii=1,ntask_cont_to
8947         iproc=itask_cont_to(ii)
8948         ireq=ireq+1
8949         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8950      &    FG_COMM,req(ireq),IERR)
8951       enddo
8952 c      write (iout,*) "ISEND ended"
8953 c      write (iout,*) "number of requests (nn)",ireq
8954 c      call flush(iout)
8955       if (ireq.gt.0)
8956      &  call MPI_Waitall(ireq,req,status_array,ierr)
8957 c      write (iout,*)
8958 c     &  "Numbers of contacts to be received from other processors",
8959 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8960 c      call flush(iout)
8961 C Receive contacts
8962       ireq=0
8963       do ii=1,ntask_cont_from
8964         iproc=itask_cont_from(ii)
8965         nn=ncont_recv(ii)
8966 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8967 c     &   " of CONT_TO_COMM group"
8968 c        call flush(iout)
8969         if (nn.gt.0) then
8970           ireq=ireq+1
8971           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8972      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8973 c          write (iout,*) "ireq,req",ireq,req(ireq)
8974         endif
8975       enddo
8976 C Send the contacts to processors that need them
8977       do ii=1,ntask_cont_to
8978         iproc=itask_cont_to(ii)
8979         nn=ncont_sent(ii)
8980 c        write (iout,*) nn," contacts to processor",iproc,
8981 c     &   " of CONT_TO_COMM group"
8982         if (nn.gt.0) then
8983           ireq=ireq+1
8984           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8985      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8986 c          write (iout,*) "ireq,req",ireq,req(ireq)
8987 c          do i=1,nn
8988 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8989 c          enddo
8990         endif
8991       enddo
8992 c      write (iout,*) "number of requests (contacts)",ireq
8993 c      write (iout,*) "req",(req(i),i=1,4)
8994 c      call flush(iout)
8995       if (ireq.gt.0)
8996      & call MPI_Waitall(ireq,req,status_array,ierr)
8997       do iii=1,ntask_cont_from
8998         iproc=itask_cont_from(iii)
8999         nn=ncont_recv(iii)
9000         if (lprn) then
9001         write (iout,*) "Received",nn," contacts from processor",iproc,
9002      &   " of CONT_FROM_COMM group"
9003         call flush(iout)
9004         do i=1,nn
9005           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9006         enddo
9007         call flush(iout)
9008         endif
9009         do i=1,nn
9010           ii=zapas_recv(1,i,iii)
9011 c Flag the received contacts to prevent double-counting
9012           jj=-zapas_recv(2,i,iii)
9013 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9014 c          call flush(iout)
9015           nnn=num_cont_hb(ii)+1
9016           num_cont_hb(ii)=nnn
9017           jcont_hb(nnn,ii)=jj
9018           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9019           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9020           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9021           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9022           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9023           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9024           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9025           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9026           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9027           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9028           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9029           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9030           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9031           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9032           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9033           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9034           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9035           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9036           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9037           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9038           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9039           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9040           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9041           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9042         enddo
9043       enddo
9044       if (lprn) then
9045         write (iout,'(a)') 'Contact function values after receive:'
9046         do i=nnt,nct-2
9047           write (iout,'(2i3,50(1x,i3,f5.2))')
9048      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9049      &    j=1,num_cont_hb(i))
9050         enddo
9051         call flush(iout)
9052       endif
9053    30 continue
9054 #endif
9055       if (lprn) then
9056         write (iout,'(a)') 'Contact function values:'
9057         do i=nnt,nct-2
9058           write (iout,'(2i3,50(1x,i3,f5.2))')
9059      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9060      &    j=1,num_cont_hb(i))
9061         enddo
9062         call flush(iout)
9063       endif
9064       ecorr=0.0D0
9065 C Remove the loop below after debugging !!!
9066       do i=nnt,nct
9067         do j=1,3
9068           gradcorr(j,i)=0.0D0
9069           gradxorr(j,i)=0.0D0
9070         enddo
9071       enddo
9072 C Calculate the local-electrostatic correlation terms
9073       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9074         i1=i+1
9075         num_conti=num_cont_hb(i)
9076         num_conti1=num_cont_hb(i+1)
9077         do jj=1,num_conti
9078           j=jcont_hb(jj,i)
9079           jp=iabs(j)
9080           do kk=1,num_conti1
9081             j1=jcont_hb(kk,i1)
9082             jp1=iabs(j1)
9083 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9084 c     &         ' jj=',jj,' kk=',kk
9085 c            call flush(iout)
9086             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9087      &          .or. j.lt.0 .and. j1.gt.0) .and.
9088      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9089 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9090 C The system gains extra energy.
9091               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9092               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9093      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9094               n_corr=n_corr+1
9095             else if (j1.eq.j) then
9096 C Contacts I-J and I-(J+1) occur simultaneously.
9097 C The system loses extra energy.
9098 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9099             endif
9100           enddo ! kk
9101           do kk=1,num_conti
9102             j1=jcont_hb(kk,i)
9103 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9104 c    &         ' jj=',jj,' kk=',kk
9105             if (j1.eq.j+1) then
9106 C Contacts I-J and (I+1)-J occur simultaneously.
9107 C The system loses extra energy.
9108 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9109             endif ! j1==j+1
9110           enddo ! kk
9111         enddo ! jj
9112       enddo ! i
9113       return
9114       end
9115 c------------------------------------------------------------------------------
9116       subroutine add_hb_contact(ii,jj,itask)
9117       implicit real*8 (a-h,o-z)
9118       include "DIMENSIONS"
9119       include "COMMON.IOUNITS"
9120       integer max_cont
9121       integer max_dim
9122       parameter (max_cont=maxconts)
9123       parameter (max_dim=26)
9124       include "COMMON.CONTACTS"
9125       double precision zapas(max_dim,maxconts,max_fg_procs),
9126      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9127       common /przechowalnia/ zapas
9128       integer i,j,ii,jj,iproc,itask(4),nn
9129 c      write (iout,*) "itask",itask
9130       do i=1,2
9131         iproc=itask(i)
9132         if (iproc.gt.0) then
9133           do j=1,num_cont_hb(ii)
9134             jjc=jcont_hb(j,ii)
9135 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9136             if (jjc.eq.jj) then
9137               ncont_sent(iproc)=ncont_sent(iproc)+1
9138               nn=ncont_sent(iproc)
9139               zapas(1,nn,iproc)=ii
9140               zapas(2,nn,iproc)=jjc
9141               zapas(3,nn,iproc)=facont_hb(j,ii)
9142               zapas(4,nn,iproc)=ees0p(j,ii)
9143               zapas(5,nn,iproc)=ees0m(j,ii)
9144               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9145               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9146               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9147               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9148               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9149               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9150               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9151               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9152               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9153               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9154               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9155               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9156               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9157               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9158               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9159               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9160               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9161               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9162               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9163               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9164               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9165               exit
9166             endif
9167           enddo
9168         endif
9169       enddo
9170       return
9171       end
9172 c------------------------------------------------------------------------------
9173       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9174      &  n_corr1)
9175 C This subroutine calculates multi-body contributions to hydrogen-bonding
9176       implicit real*8 (a-h,o-z)
9177       include 'DIMENSIONS'
9178       include 'COMMON.IOUNITS'
9179 #ifdef MPI
9180       include "mpif.h"
9181       parameter (max_cont=maxconts)
9182       parameter (max_dim=70)
9183       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9184       double precision zapas(max_dim,maxconts,max_fg_procs),
9185      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9186       common /przechowalnia/ zapas
9187       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9188      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9189 #endif
9190       include 'COMMON.SETUP'
9191       include 'COMMON.FFIELD'
9192       include 'COMMON.DERIV'
9193       include 'COMMON.LOCAL'
9194       include 'COMMON.INTERACT'
9195       include 'COMMON.CONTACTS'
9196       include 'COMMON.CHAIN'
9197       include 'COMMON.CONTROL'
9198       include 'COMMON.SHIELD'
9199       double precision gx(3),gx1(3)
9200       integer num_cont_hb_old(maxres)
9201       logical lprn,ldone
9202       double precision eello4,eello5,eelo6,eello_turn6
9203       external eello4,eello5,eello6,eello_turn6
9204 C Set lprn=.true. for debugging
9205       lprn=.false.
9206       eturn6=0.0d0
9207 #ifdef MPI
9208       do i=1,nres
9209         num_cont_hb_old(i)=num_cont_hb(i)
9210       enddo
9211       n_corr=0
9212       n_corr1=0
9213       if (nfgtasks.le.1) goto 30
9214       if (lprn) then
9215         write (iout,'(a)') 'Contact function values before RECEIVE:'
9216         do i=nnt,nct-2
9217           write (iout,'(2i3,50(1x,i2,f5.2))')
9218      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9219      &    j=1,num_cont_hb(i))
9220         enddo
9221       endif
9222       do i=1,ntask_cont_from
9223         ncont_recv(i)=0
9224       enddo
9225       do i=1,ntask_cont_to
9226         ncont_sent(i)=0
9227       enddo
9228 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9229 c     & ntask_cont_to
9230 C Make the list of contacts to send to send to other procesors
9231       do i=iturn3_start,iturn3_end
9232 c        write (iout,*) "make contact list turn3",i," num_cont",
9233 c     &    num_cont_hb(i)
9234         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9235       enddo
9236       do i=iturn4_start,iturn4_end
9237 c        write (iout,*) "make contact list turn4",i," num_cont",
9238 c     &   num_cont_hb(i)
9239         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9240       enddo
9241       do ii=1,nat_sent
9242         i=iat_sent(ii)
9243 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9244 c     &    num_cont_hb(i)
9245         do j=1,num_cont_hb(i)
9246         do k=1,4
9247           jjc=jcont_hb(j,i)
9248           iproc=iint_sent_local(k,jjc,ii)
9249 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9250           if (iproc.ne.0) then
9251             ncont_sent(iproc)=ncont_sent(iproc)+1
9252             nn=ncont_sent(iproc)
9253             zapas(1,nn,iproc)=i
9254             zapas(2,nn,iproc)=jjc
9255             zapas(3,nn,iproc)=d_cont(j,i)
9256             ind=3
9257             do kk=1,3
9258               ind=ind+1
9259               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9260             enddo
9261             do kk=1,2
9262               do ll=1,2
9263                 ind=ind+1
9264                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9265               enddo
9266             enddo
9267             do jj=1,5
9268               do kk=1,3
9269                 do ll=1,2
9270                   do mm=1,2
9271                     ind=ind+1
9272                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9273                   enddo
9274                 enddo
9275               enddo
9276             enddo
9277           endif
9278         enddo
9279         enddo
9280       enddo
9281       if (lprn) then
9282       write (iout,*)
9283      &  "Numbers of contacts to be sent to other processors",
9284      &  (ncont_sent(i),i=1,ntask_cont_to)
9285       write (iout,*) "Contacts sent"
9286       do ii=1,ntask_cont_to
9287         nn=ncont_sent(ii)
9288         iproc=itask_cont_to(ii)
9289         write (iout,*) nn," contacts to processor",iproc,
9290      &   " of CONT_TO_COMM group"
9291         do i=1,nn
9292           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9293         enddo
9294       enddo
9295       call flush(iout)
9296       endif
9297       CorrelType=477
9298       CorrelID=fg_rank+1
9299       CorrelType1=478
9300       CorrelID1=nfgtasks+fg_rank+1
9301       ireq=0
9302 C Receive the numbers of needed contacts from other processors
9303       do ii=1,ntask_cont_from
9304         iproc=itask_cont_from(ii)
9305         ireq=ireq+1
9306         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9307      &    FG_COMM,req(ireq),IERR)
9308       enddo
9309 c      write (iout,*) "IRECV ended"
9310 c      call flush(iout)
9311 C Send the number of contacts needed by other processors
9312       do ii=1,ntask_cont_to
9313         iproc=itask_cont_to(ii)
9314         ireq=ireq+1
9315         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9316      &    FG_COMM,req(ireq),IERR)
9317       enddo
9318 c      write (iout,*) "ISEND ended"
9319 c      write (iout,*) "number of requests (nn)",ireq
9320 c      call flush(iout)
9321       if (ireq.gt.0)
9322      &  call MPI_Waitall(ireq,req,status_array,ierr)
9323 c      write (iout,*)
9324 c     &  "Numbers of contacts to be received from other processors",
9325 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9326 c      call flush(iout)
9327 C Receive contacts
9328       ireq=0
9329       do ii=1,ntask_cont_from
9330         iproc=itask_cont_from(ii)
9331         nn=ncont_recv(ii)
9332 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9333 c     &   " of CONT_TO_COMM group"
9334 c        call flush(iout)
9335         if (nn.gt.0) then
9336           ireq=ireq+1
9337           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9338      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9339 c          write (iout,*) "ireq,req",ireq,req(ireq)
9340         endif
9341       enddo
9342 C Send the contacts to processors that need them
9343       do ii=1,ntask_cont_to
9344         iproc=itask_cont_to(ii)
9345         nn=ncont_sent(ii)
9346 c        write (iout,*) nn," contacts to processor",iproc,
9347 c     &   " of CONT_TO_COMM group"
9348         if (nn.gt.0) then
9349           ireq=ireq+1
9350           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9351      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9352 c          write (iout,*) "ireq,req",ireq,req(ireq)
9353 c          do i=1,nn
9354 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9355 c          enddo
9356         endif
9357       enddo
9358 c      write (iout,*) "number of requests (contacts)",ireq
9359 c      write (iout,*) "req",(req(i),i=1,4)
9360 c      call flush(iout)
9361       if (ireq.gt.0)
9362      & call MPI_Waitall(ireq,req,status_array,ierr)
9363       do iii=1,ntask_cont_from
9364         iproc=itask_cont_from(iii)
9365         nn=ncont_recv(iii)
9366         if (lprn) then
9367         write (iout,*) "Received",nn," contacts from processor",iproc,
9368      &   " of CONT_FROM_COMM group"
9369         call flush(iout)
9370         do i=1,nn
9371           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9372         enddo
9373         call flush(iout)
9374         endif
9375         do i=1,nn
9376           ii=zapas_recv(1,i,iii)
9377 c Flag the received contacts to prevent double-counting
9378           jj=-zapas_recv(2,i,iii)
9379 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9380 c          call flush(iout)
9381           nnn=num_cont_hb(ii)+1
9382           num_cont_hb(ii)=nnn
9383           jcont_hb(nnn,ii)=jj
9384           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9385           ind=3
9386           do kk=1,3
9387             ind=ind+1
9388             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9389           enddo
9390           do kk=1,2
9391             do ll=1,2
9392               ind=ind+1
9393               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9394             enddo
9395           enddo
9396           do jj=1,5
9397             do kk=1,3
9398               do ll=1,2
9399                 do mm=1,2
9400                   ind=ind+1
9401                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9402                 enddo
9403               enddo
9404             enddo
9405           enddo
9406         enddo
9407       enddo
9408       if (lprn) then
9409         write (iout,'(a)') 'Contact function values after receive:'
9410         do i=nnt,nct-2
9411           write (iout,'(2i3,50(1x,i3,5f6.3))')
9412      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9413      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9414         enddo
9415         call flush(iout)
9416       endif
9417    30 continue
9418 #endif
9419       if (lprn) then
9420         write (iout,'(a)') 'Contact function values:'
9421         do i=nnt,nct-2
9422           write (iout,'(2i3,50(1x,i2,5f6.3))')
9423      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9424      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9425         enddo
9426       endif
9427       ecorr=0.0D0
9428       ecorr5=0.0d0
9429       ecorr6=0.0d0
9430 C Remove the loop below after debugging !!!
9431       do i=nnt,nct
9432         do j=1,3
9433           gradcorr(j,i)=0.0D0
9434           gradxorr(j,i)=0.0D0
9435         enddo
9436       enddo
9437 C Calculate the dipole-dipole interaction energies
9438       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9439       do i=iatel_s,iatel_e+1
9440         num_conti=num_cont_hb(i)
9441         do jj=1,num_conti
9442           j=jcont_hb(jj,i)
9443 #ifdef MOMENT
9444           call dipole(i,j,jj)
9445 #endif
9446         enddo
9447       enddo
9448       endif
9449 C Calculate the local-electrostatic correlation terms
9450 c                write (iout,*) "gradcorr5 in eello5 before loop"
9451 c                do iii=1,nres
9452 c                  write (iout,'(i5,3f10.5)')
9453 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9454 c                enddo
9455       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9456 c        write (iout,*) "corr loop i",i
9457         i1=i+1
9458         num_conti=num_cont_hb(i)
9459         num_conti1=num_cont_hb(i+1)
9460         do jj=1,num_conti
9461           j=jcont_hb(jj,i)
9462           jp=iabs(j)
9463           do kk=1,num_conti1
9464             j1=jcont_hb(kk,i1)
9465             jp1=iabs(j1)
9466 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9467 c     &         ' jj=',jj,' kk=',kk
9468 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9469             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9470      &          .or. j.lt.0 .and. j1.gt.0) .and.
9471      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9472 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9473 C The system gains extra energy.
9474               n_corr=n_corr+1
9475               sqd1=dsqrt(d_cont(jj,i))
9476               sqd2=dsqrt(d_cont(kk,i1))
9477               sred_geom = sqd1*sqd2
9478               IF (sred_geom.lt.cutoff_corr) THEN
9479                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9480      &            ekont,fprimcont)
9481 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9482 cd     &         ' jj=',jj,' kk=',kk
9483                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9484                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9485                 do l=1,3
9486                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9487                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9488                 enddo
9489                 n_corr1=n_corr1+1
9490 cd               write (iout,*) 'sred_geom=',sred_geom,
9491 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9492 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9493 cd               write (iout,*) "g_contij",g_contij
9494 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9495 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9496                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9497                 if (wcorr4.gt.0.0d0)
9498      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9499 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9500                   if (energy_dec.and.wcorr4.gt.0.0d0)
9501      1                 write (iout,'(a6,4i5,0pf7.3)')
9502      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9503 c                write (iout,*) "gradcorr5 before eello5"
9504 c                do iii=1,nres
9505 c                  write (iout,'(i5,3f10.5)')
9506 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9507 c                enddo
9508                 if (wcorr5.gt.0.0d0)
9509      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9510 c                write (iout,*) "gradcorr5 after eello5"
9511 c                do iii=1,nres
9512 c                  write (iout,'(i5,3f10.5)')
9513 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9514 c                enddo
9515                   if (energy_dec.and.wcorr5.gt.0.0d0)
9516      1                 write (iout,'(a6,4i5,0pf7.3)')
9517      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9518 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9519 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9520                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9521      &               .or. wturn6.eq.0.0d0))then
9522 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9523                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9524                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9525      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9526 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9527 cd     &            'ecorr6=',ecorr6
9528 cd                write (iout,'(4e15.5)') sred_geom,
9529 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9530 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9531 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9532                 else if (wturn6.gt.0.0d0
9533      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9534 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9535                   eturn6=eturn6+eello_turn6(i,jj,kk)
9536                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9537      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9538 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9539                 endif
9540               ENDIF
9541 1111          continue
9542             endif
9543           enddo ! kk
9544         enddo ! jj
9545       enddo ! i
9546       do i=1,nres
9547         num_cont_hb(i)=num_cont_hb_old(i)
9548       enddo
9549 c                write (iout,*) "gradcorr5 in eello5"
9550 c                do iii=1,nres
9551 c                  write (iout,'(i5,3f10.5)')
9552 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9553 c                enddo
9554       return
9555       end
9556 c------------------------------------------------------------------------------
9557       subroutine add_hb_contact_eello(ii,jj,itask)
9558       implicit real*8 (a-h,o-z)
9559       include "DIMENSIONS"
9560       include "COMMON.IOUNITS"
9561       integer max_cont
9562       integer max_dim
9563       parameter (max_cont=maxconts)
9564       parameter (max_dim=70)
9565       include "COMMON.CONTACTS"
9566       double precision zapas(max_dim,maxconts,max_fg_procs),
9567      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9568       common /przechowalnia/ zapas
9569       integer i,j,ii,jj,iproc,itask(4),nn
9570 c      write (iout,*) "itask",itask
9571       do i=1,2
9572         iproc=itask(i)
9573         if (iproc.gt.0) then
9574           do j=1,num_cont_hb(ii)
9575             jjc=jcont_hb(j,ii)
9576 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9577             if (jjc.eq.jj) then
9578               ncont_sent(iproc)=ncont_sent(iproc)+1
9579               nn=ncont_sent(iproc)
9580               zapas(1,nn,iproc)=ii
9581               zapas(2,nn,iproc)=jjc
9582               zapas(3,nn,iproc)=d_cont(j,ii)
9583               ind=3
9584               do kk=1,3
9585                 ind=ind+1
9586                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9587               enddo
9588               do kk=1,2
9589                 do ll=1,2
9590                   ind=ind+1
9591                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9592                 enddo
9593               enddo
9594               do jj=1,5
9595                 do kk=1,3
9596                   do ll=1,2
9597                     do mm=1,2
9598                       ind=ind+1
9599                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9600                     enddo
9601                   enddo
9602                 enddo
9603               enddo
9604               exit
9605             endif
9606           enddo
9607         endif
9608       enddo
9609       return
9610       end
9611 c------------------------------------------------------------------------------
9612       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9613       implicit real*8 (a-h,o-z)
9614       include 'DIMENSIONS'
9615       include 'COMMON.IOUNITS'
9616       include 'COMMON.DERIV'
9617       include 'COMMON.INTERACT'
9618       include 'COMMON.CONTACTS'
9619       include 'COMMON.SHIELD'
9620       include 'COMMON.CONTROL'
9621       double precision gx(3),gx1(3)
9622       logical lprn
9623       lprn=.false.
9624 C      print *,"wchodze",fac_shield(i),shield_mode
9625       eij=facont_hb(jj,i)
9626       ekl=facont_hb(kk,k)
9627       ees0pij=ees0p(jj,i)
9628       ees0pkl=ees0p(kk,k)
9629       ees0mij=ees0m(jj,i)
9630       ees0mkl=ees0m(kk,k)
9631       ekont=eij*ekl
9632       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9633 C*
9634 C     & fac_shield(i)**2*fac_shield(j)**2
9635 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9636 C Following 4 lines for diagnostics.
9637 cd    ees0pkl=0.0D0
9638 cd    ees0pij=1.0D0
9639 cd    ees0mkl=0.0D0
9640 cd    ees0mij=1.0D0
9641 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9642 c     & 'Contacts ',i,j,
9643 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9644 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9645 c     & 'gradcorr_long'
9646 C Calculate the multi-body contribution to energy.
9647 C      ecorr=ecorr+ekont*ees
9648 C Calculate multi-body contributions to the gradient.
9649       coeffpees0pij=coeffp*ees0pij
9650       coeffmees0mij=coeffm*ees0mij
9651       coeffpees0pkl=coeffp*ees0pkl
9652       coeffmees0mkl=coeffm*ees0mkl
9653       do ll=1,3
9654 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9655         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9656      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9657      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9658         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9659      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9660      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9661 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9662         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9663      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9664      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9665         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9666      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9667      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9668         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9669      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9670      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9671         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9672         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9673         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9674      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9675      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9676         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9677         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9678 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9679       enddo
9680 c      write (iout,*)
9681 cgrad      do m=i+1,j-1
9682 cgrad        do ll=1,3
9683 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9684 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9685 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9686 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9687 cgrad        enddo
9688 cgrad      enddo
9689 cgrad      do m=k+1,l-1
9690 cgrad        do ll=1,3
9691 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9692 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9693 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9694 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9695 cgrad        enddo
9696 cgrad      enddo
9697 c      write (iout,*) "ehbcorr",ekont*ees
9698 C      print *,ekont,ees,i,k
9699       ehbcorr=ekont*ees
9700 C now gradient over shielding
9701 C      return
9702       if (shield_mode.gt.0) then
9703        j=ees0plist(jj,i)
9704        l=ees0plist(kk,k)
9705 C        print *,i,j,fac_shield(i),fac_shield(j),
9706 C     &fac_shield(k),fac_shield(l)
9707         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9708      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9709           do ilist=1,ishield_list(i)
9710            iresshield=shield_list(ilist,i)
9711            do m=1,3
9712            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9713 C     &      *2.0
9714            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9715      &              rlocshield
9716      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9717             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9718      &+rlocshield
9719            enddo
9720           enddo
9721           do ilist=1,ishield_list(j)
9722            iresshield=shield_list(ilist,j)
9723            do m=1,3
9724            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9725 C     &     *2.0
9726            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9727      &              rlocshield
9728      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9729            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9730      &     +rlocshield
9731            enddo
9732           enddo
9733
9734           do ilist=1,ishield_list(k)
9735            iresshield=shield_list(ilist,k)
9736            do m=1,3
9737            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9738 C     &     *2.0
9739            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9740      &              rlocshield
9741      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9742            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9743      &     +rlocshield
9744            enddo
9745           enddo
9746           do ilist=1,ishield_list(l)
9747            iresshield=shield_list(ilist,l)
9748            do m=1,3
9749            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9750 C     &     *2.0
9751            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9752      &              rlocshield
9753      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9754            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9755      &     +rlocshield
9756            enddo
9757           enddo
9758 C          print *,gshieldx(m,iresshield)
9759           do m=1,3
9760             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9761      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9762             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9763      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9764             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9765      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9766             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9767      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9768
9769             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9770      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9771             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9772      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9773             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9774      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9775             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9776      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9777
9778            enddo
9779       endif
9780       endif
9781       return
9782       end
9783 #ifdef MOMENT
9784 C---------------------------------------------------------------------------
9785       subroutine dipole(i,j,jj)
9786       implicit real*8 (a-h,o-z)
9787       include 'DIMENSIONS'
9788       include 'COMMON.IOUNITS'
9789       include 'COMMON.CHAIN'
9790       include 'COMMON.FFIELD'
9791       include 'COMMON.DERIV'
9792       include 'COMMON.INTERACT'
9793       include 'COMMON.CONTACTS'
9794       include 'COMMON.TORSION'
9795       include 'COMMON.VAR'
9796       include 'COMMON.GEO'
9797       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9798      &  auxmat(2,2)
9799       iti1 = itortyp(itype(i+1))
9800       if (j.lt.nres-1) then
9801         itj1 = itype2loc(itype(j+1))
9802       else
9803         itj1=nloctyp
9804       endif
9805       do iii=1,2
9806         dipi(iii,1)=Ub2(iii,i)
9807         dipderi(iii)=Ub2der(iii,i)
9808         dipi(iii,2)=b1(iii,i+1)
9809         dipj(iii,1)=Ub2(iii,j)
9810         dipderj(iii)=Ub2der(iii,j)
9811         dipj(iii,2)=b1(iii,j+1)
9812       enddo
9813       kkk=0
9814       do iii=1,2
9815         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9816         do jjj=1,2
9817           kkk=kkk+1
9818           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9819         enddo
9820       enddo
9821       do kkk=1,5
9822         do lll=1,3
9823           mmm=0
9824           do iii=1,2
9825             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9826      &        auxvec(1))
9827             do jjj=1,2
9828               mmm=mmm+1
9829               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9830             enddo
9831           enddo
9832         enddo
9833       enddo
9834       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9835       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9836       do iii=1,2
9837         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9838       enddo
9839       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9840       do iii=1,2
9841         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9842       enddo
9843       return
9844       end
9845 #endif
9846 C---------------------------------------------------------------------------
9847       subroutine calc_eello(i,j,k,l,jj,kk)
9848 C
9849 C This subroutine computes matrices and vectors needed to calculate
9850 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9851 C
9852       implicit real*8 (a-h,o-z)
9853       include 'DIMENSIONS'
9854       include 'COMMON.IOUNITS'
9855       include 'COMMON.CHAIN'
9856       include 'COMMON.DERIV'
9857       include 'COMMON.INTERACT'
9858       include 'COMMON.CONTACTS'
9859       include 'COMMON.TORSION'
9860       include 'COMMON.VAR'
9861       include 'COMMON.GEO'
9862       include 'COMMON.FFIELD'
9863       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9864      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9865       logical lprn
9866       common /kutas/ lprn
9867 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9868 cd     & ' jj=',jj,' kk=',kk
9869 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9870 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9871 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9872       do iii=1,2
9873         do jjj=1,2
9874           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9875           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9876         enddo
9877       enddo
9878       call transpose2(aa1(1,1),aa1t(1,1))
9879       call transpose2(aa2(1,1),aa2t(1,1))
9880       do kkk=1,5
9881         do lll=1,3
9882           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9883      &      aa1tder(1,1,lll,kkk))
9884           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9885      &      aa2tder(1,1,lll,kkk))
9886         enddo
9887       enddo
9888       if (l.eq.j+1) then
9889 C parallel orientation of the two CA-CA-CA frames.
9890         if (i.gt.1) then
9891           iti=itype2loc(itype(i))
9892         else
9893           iti=nloctyp
9894         endif
9895         itk1=itype2loc(itype(k+1))
9896         itj=itype2loc(itype(j))
9897         if (l.lt.nres-1) then
9898           itl1=itype2loc(itype(l+1))
9899         else
9900           itl1=nloctyp
9901         endif
9902 C A1 kernel(j+1) A2T
9903 cd        do iii=1,2
9904 cd          write (iout,'(3f10.5,5x,3f10.5)')
9905 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9906 cd        enddo
9907         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9908      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9909      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9910 C Following matrices are needed only for 6-th order cumulants
9911         IF (wcorr6.gt.0.0d0) THEN
9912         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9913      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9914      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9915         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9916      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9917      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9918      &   ADtEAderx(1,1,1,1,1,1))
9919         lprn=.false.
9920         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9921      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9922      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9923      &   ADtEA1derx(1,1,1,1,1,1))
9924         ENDIF
9925 C End 6-th order cumulants
9926 cd        lprn=.false.
9927 cd        if (lprn) then
9928 cd        write (2,*) 'In calc_eello6'
9929 cd        do iii=1,2
9930 cd          write (2,*) 'iii=',iii
9931 cd          do kkk=1,5
9932 cd            write (2,*) 'kkk=',kkk
9933 cd            do jjj=1,2
9934 cd              write (2,'(3(2f10.5),5x)')
9935 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9936 cd            enddo
9937 cd          enddo
9938 cd        enddo
9939 cd        endif
9940         call transpose2(EUgder(1,1,k),auxmat(1,1))
9941         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9942         call transpose2(EUg(1,1,k),auxmat(1,1))
9943         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9944         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9945 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9946 c    in theta; to be sriten later.
9947 c#ifdef NEWCORR
9948 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9949 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9950 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9951 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9952 c#endif
9953         do iii=1,2
9954           do kkk=1,5
9955             do lll=1,3
9956               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9957      &          EAEAderx(1,1,lll,kkk,iii,1))
9958             enddo
9959           enddo
9960         enddo
9961 C A1T kernel(i+1) A2
9962         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9963      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9964      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9965 C Following matrices are needed only for 6-th order cumulants
9966         IF (wcorr6.gt.0.0d0) THEN
9967         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9968      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9969      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9970         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9971      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9972      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9973      &   ADtEAderx(1,1,1,1,1,2))
9974         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9975      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9976      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9977      &   ADtEA1derx(1,1,1,1,1,2))
9978         ENDIF
9979 C End 6-th order cumulants
9980         call transpose2(EUgder(1,1,l),auxmat(1,1))
9981         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9982         call transpose2(EUg(1,1,l),auxmat(1,1))
9983         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9984         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9985         do iii=1,2
9986           do kkk=1,5
9987             do lll=1,3
9988               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9989      &          EAEAderx(1,1,lll,kkk,iii,2))
9990             enddo
9991           enddo
9992         enddo
9993 C AEAb1 and AEAb2
9994 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9995 C They are needed only when the fifth- or the sixth-order cumulants are
9996 C indluded.
9997         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9998         call transpose2(AEA(1,1,1),auxmat(1,1))
9999         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10000         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10001         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10002         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10003         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10004         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10005         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10006         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10007         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10008         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10009         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10010         call transpose2(AEA(1,1,2),auxmat(1,1))
10011         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10012         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10013         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10014         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10015         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10016         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10017         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10018         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10019         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10020         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10021         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10022 C Calculate the Cartesian derivatives of the vectors.
10023         do iii=1,2
10024           do kkk=1,5
10025             do lll=1,3
10026               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10027               call matvec2(auxmat(1,1),b1(1,i),
10028      &          AEAb1derx(1,lll,kkk,iii,1,1))
10029               call matvec2(auxmat(1,1),Ub2(1,i),
10030      &          AEAb2derx(1,lll,kkk,iii,1,1))
10031               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10032      &          AEAb1derx(1,lll,kkk,iii,2,1))
10033               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10034      &          AEAb2derx(1,lll,kkk,iii,2,1))
10035               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10036               call matvec2(auxmat(1,1),b1(1,j),
10037      &          AEAb1derx(1,lll,kkk,iii,1,2))
10038               call matvec2(auxmat(1,1),Ub2(1,j),
10039      &          AEAb2derx(1,lll,kkk,iii,1,2))
10040               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10041      &          AEAb1derx(1,lll,kkk,iii,2,2))
10042               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10043      &          AEAb2derx(1,lll,kkk,iii,2,2))
10044             enddo
10045           enddo
10046         enddo
10047         ENDIF
10048 C End vectors
10049       else
10050 C Antiparallel orientation of the two CA-CA-CA frames.
10051         if (i.gt.1) then
10052           iti=itype2loc(itype(i))
10053         else
10054           iti=nloctyp
10055         endif
10056         itk1=itype2loc(itype(k+1))
10057         itl=itype2loc(itype(l))
10058         itj=itype2loc(itype(j))
10059         if (j.lt.nres-1) then
10060           itj1=itype2loc(itype(j+1))
10061         else
10062           itj1=nloctyp
10063         endif
10064 C A2 kernel(j-1)T A1T
10065         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10066      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10067      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10068 C Following matrices are needed only for 6-th order cumulants
10069         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10070      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10071         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10072      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10073      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10074         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10075      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10076      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10077      &   ADtEAderx(1,1,1,1,1,1))
10078         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10079      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10080      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10081      &   ADtEA1derx(1,1,1,1,1,1))
10082         ENDIF
10083 C End 6-th order cumulants
10084         call transpose2(EUgder(1,1,k),auxmat(1,1))
10085         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10086         call transpose2(EUg(1,1,k),auxmat(1,1))
10087         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10088         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10089         do iii=1,2
10090           do kkk=1,5
10091             do lll=1,3
10092               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10093      &          EAEAderx(1,1,lll,kkk,iii,1))
10094             enddo
10095           enddo
10096         enddo
10097 C A2T kernel(i+1)T A1
10098         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10099      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10100      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10101 C Following matrices are needed only for 6-th order cumulants
10102         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10103      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10104         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10105      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10106      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10107         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10108      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10109      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10110      &   ADtEAderx(1,1,1,1,1,2))
10111         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10112      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10113      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10114      &   ADtEA1derx(1,1,1,1,1,2))
10115         ENDIF
10116 C End 6-th order cumulants
10117         call transpose2(EUgder(1,1,j),auxmat(1,1))
10118         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10119         call transpose2(EUg(1,1,j),auxmat(1,1))
10120         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10121         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10122         do iii=1,2
10123           do kkk=1,5
10124             do lll=1,3
10125               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10126      &          EAEAderx(1,1,lll,kkk,iii,2))
10127             enddo
10128           enddo
10129         enddo
10130 C AEAb1 and AEAb2
10131 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10132 C They are needed only when the fifth- or the sixth-order cumulants are
10133 C indluded.
10134         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10135      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10136         call transpose2(AEA(1,1,1),auxmat(1,1))
10137         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10138         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10139         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10140         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10141         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10142         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10143         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10144         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10145         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10146         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10147         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10148         call transpose2(AEA(1,1,2),auxmat(1,1))
10149         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10150         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10151         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10152         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10153         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10154         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10155         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10156         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10157         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10158         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10159         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10160 C Calculate the Cartesian derivatives of the vectors.
10161         do iii=1,2
10162           do kkk=1,5
10163             do lll=1,3
10164               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10165               call matvec2(auxmat(1,1),b1(1,i),
10166      &          AEAb1derx(1,lll,kkk,iii,1,1))
10167               call matvec2(auxmat(1,1),Ub2(1,i),
10168      &          AEAb2derx(1,lll,kkk,iii,1,1))
10169               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10170      &          AEAb1derx(1,lll,kkk,iii,2,1))
10171               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10172      &          AEAb2derx(1,lll,kkk,iii,2,1))
10173               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10174               call matvec2(auxmat(1,1),b1(1,l),
10175      &          AEAb1derx(1,lll,kkk,iii,1,2))
10176               call matvec2(auxmat(1,1),Ub2(1,l),
10177      &          AEAb2derx(1,lll,kkk,iii,1,2))
10178               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10179      &          AEAb1derx(1,lll,kkk,iii,2,2))
10180               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10181      &          AEAb2derx(1,lll,kkk,iii,2,2))
10182             enddo
10183           enddo
10184         enddo
10185         ENDIF
10186 C End vectors
10187       endif
10188       return
10189       end
10190 C---------------------------------------------------------------------------
10191       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10192      &  KK,KKderg,AKA,AKAderg,AKAderx)
10193       implicit none
10194       integer nderg
10195       logical transp
10196       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10197      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10198      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10199       integer iii,kkk,lll
10200       integer jjj,mmm
10201       logical lprn
10202       common /kutas/ lprn
10203       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10204       do iii=1,nderg
10205         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10206      &    AKAderg(1,1,iii))
10207       enddo
10208 cd      if (lprn) write (2,*) 'In kernel'
10209       do kkk=1,5
10210 cd        if (lprn) write (2,*) 'kkk=',kkk
10211         do lll=1,3
10212           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10213      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10214 cd          if (lprn) then
10215 cd            write (2,*) 'lll=',lll
10216 cd            write (2,*) 'iii=1'
10217 cd            do jjj=1,2
10218 cd              write (2,'(3(2f10.5),5x)')
10219 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10220 cd            enddo
10221 cd          endif
10222           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10223      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10224 cd          if (lprn) then
10225 cd            write (2,*) 'lll=',lll
10226 cd            write (2,*) 'iii=2'
10227 cd            do jjj=1,2
10228 cd              write (2,'(3(2f10.5),5x)')
10229 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10230 cd            enddo
10231 cd          endif
10232         enddo
10233       enddo
10234       return
10235       end
10236 C---------------------------------------------------------------------------
10237       double precision function eello4(i,j,k,l,jj,kk)
10238       implicit real*8 (a-h,o-z)
10239       include 'DIMENSIONS'
10240       include 'COMMON.IOUNITS'
10241       include 'COMMON.CHAIN'
10242       include 'COMMON.DERIV'
10243       include 'COMMON.INTERACT'
10244       include 'COMMON.CONTACTS'
10245       include 'COMMON.TORSION'
10246       include 'COMMON.VAR'
10247       include 'COMMON.GEO'
10248       double precision pizda(2,2),ggg1(3),ggg2(3)
10249 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10250 cd        eello4=0.0d0
10251 cd        return
10252 cd      endif
10253 cd      print *,'eello4:',i,j,k,l,jj,kk
10254 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10255 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10256 cold      eij=facont_hb(jj,i)
10257 cold      ekl=facont_hb(kk,k)
10258 cold      ekont=eij*ekl
10259       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10260 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10261       gcorr_loc(k-1)=gcorr_loc(k-1)
10262      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10263       if (l.eq.j+1) then
10264         gcorr_loc(l-1)=gcorr_loc(l-1)
10265      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10266 C Al 4/16/16: Derivatives in theta, to be added later.
10267 c#ifdef NEWCORR
10268 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10269 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10270 c#endif
10271       else
10272         gcorr_loc(j-1)=gcorr_loc(j-1)
10273      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10274 c#ifdef NEWCORR
10275 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10276 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10277 c#endif
10278       endif
10279       do iii=1,2
10280         do kkk=1,5
10281           do lll=1,3
10282             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10283      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10284 cd            derx(lll,kkk,iii)=0.0d0
10285           enddo
10286         enddo
10287       enddo
10288 cd      gcorr_loc(l-1)=0.0d0
10289 cd      gcorr_loc(j-1)=0.0d0
10290 cd      gcorr_loc(k-1)=0.0d0
10291 cd      eel4=1.0d0
10292 cd      write (iout,*)'Contacts have occurred for peptide groups',
10293 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10294 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10295       if (j.lt.nres-1) then
10296         j1=j+1
10297         j2=j-1
10298       else
10299         j1=j-1
10300         j2=j-2
10301       endif
10302       if (l.lt.nres-1) then
10303         l1=l+1
10304         l2=l-1
10305       else
10306         l1=l-1
10307         l2=l-2
10308       endif
10309       do ll=1,3
10310 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10311 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10312         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10313         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10314 cgrad        ghalf=0.5d0*ggg1(ll)
10315         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10316         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10317         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10318         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10319         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10320         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10321 cgrad        ghalf=0.5d0*ggg2(ll)
10322         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10323         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10324         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10325         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10326         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10327         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10328       enddo
10329 cgrad      do m=i+1,j-1
10330 cgrad        do ll=1,3
10331 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10332 cgrad        enddo
10333 cgrad      enddo
10334 cgrad      do m=k+1,l-1
10335 cgrad        do ll=1,3
10336 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10337 cgrad        enddo
10338 cgrad      enddo
10339 cgrad      do m=i+2,j2
10340 cgrad        do ll=1,3
10341 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10342 cgrad        enddo
10343 cgrad      enddo
10344 cgrad      do m=k+2,l2
10345 cgrad        do ll=1,3
10346 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10347 cgrad        enddo
10348 cgrad      enddo
10349 cd      do iii=1,nres-3
10350 cd        write (2,*) iii,gcorr_loc(iii)
10351 cd      enddo
10352       eello4=ekont*eel4
10353 cd      write (2,*) 'ekont',ekont
10354 cd      write (iout,*) 'eello4',ekont*eel4
10355       return
10356       end
10357 C---------------------------------------------------------------------------
10358       double precision function eello5(i,j,k,l,jj,kk)
10359       implicit real*8 (a-h,o-z)
10360       include 'DIMENSIONS'
10361       include 'COMMON.IOUNITS'
10362       include 'COMMON.CHAIN'
10363       include 'COMMON.DERIV'
10364       include 'COMMON.INTERACT'
10365       include 'COMMON.CONTACTS'
10366       include 'COMMON.TORSION'
10367       include 'COMMON.VAR'
10368       include 'COMMON.GEO'
10369       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10370       double precision ggg1(3),ggg2(3)
10371 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10372 C                                                                              C
10373 C                            Parallel chains                                   C
10374 C                                                                              C
10375 C          o             o                   o             o                   C
10376 C         /l\           / \             \   / \           / \   /              C
10377 C        /   \         /   \             \ /   \         /   \ /               C
10378 C       j| o |l1       | o |              o| o |         | o |o                C
10379 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10380 C      \i/   \         /   \ /             /   \         /   \                 C
10381 C       o    k1             o                                                  C
10382 C         (I)          (II)                (III)          (IV)                 C
10383 C                                                                              C
10384 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10385 C                                                                              C
10386 C                            Antiparallel chains                               C
10387 C                                                                              C
10388 C          o             o                   o             o                   C
10389 C         /j\           / \             \   / \           / \   /              C
10390 C        /   \         /   \             \ /   \         /   \ /               C
10391 C      j1| o |l        | o |              o| o |         | o |o                C
10392 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10393 C      \i/   \         /   \ /             /   \         /   \                 C
10394 C       o     k1            o                                                  C
10395 C         (I)          (II)                (III)          (IV)                 C
10396 C                                                                              C
10397 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10398 C                                                                              C
10399 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10400 C                                                                              C
10401 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10402 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10403 cd        eello5=0.0d0
10404 cd        return
10405 cd      endif
10406 cd      write (iout,*)
10407 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10408 cd     &   ' and',k,l
10409       itk=itype2loc(itype(k))
10410       itl=itype2loc(itype(l))
10411       itj=itype2loc(itype(j))
10412       eello5_1=0.0d0
10413       eello5_2=0.0d0
10414       eello5_3=0.0d0
10415       eello5_4=0.0d0
10416 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10417 cd     &   eel5_3_num,eel5_4_num)
10418       do iii=1,2
10419         do kkk=1,5
10420           do lll=1,3
10421             derx(lll,kkk,iii)=0.0d0
10422           enddo
10423         enddo
10424       enddo
10425 cd      eij=facont_hb(jj,i)
10426 cd      ekl=facont_hb(kk,k)
10427 cd      ekont=eij*ekl
10428 cd      write (iout,*)'Contacts have occurred for peptide groups',
10429 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10430 cd      goto 1111
10431 C Contribution from the graph I.
10432 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10433 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10434       call transpose2(EUg(1,1,k),auxmat(1,1))
10435       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10436       vv(1)=pizda(1,1)-pizda(2,2)
10437       vv(2)=pizda(1,2)+pizda(2,1)
10438       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10439      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10440 C Explicit gradient in virtual-dihedral angles.
10441       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10442      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10443      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10444       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10445       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10446       vv(1)=pizda(1,1)-pizda(2,2)
10447       vv(2)=pizda(1,2)+pizda(2,1)
10448       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10449      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10450      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10451       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10452       vv(1)=pizda(1,1)-pizda(2,2)
10453       vv(2)=pizda(1,2)+pizda(2,1)
10454       if (l.eq.j+1) then
10455         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10456      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10457      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10458       else
10459         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10460      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10461      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10462       endif
10463 C Cartesian gradient
10464       do iii=1,2
10465         do kkk=1,5
10466           do lll=1,3
10467             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10468      &        pizda(1,1))
10469             vv(1)=pizda(1,1)-pizda(2,2)
10470             vv(2)=pizda(1,2)+pizda(2,1)
10471             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10472      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10473      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10474           enddo
10475         enddo
10476       enddo
10477 c      goto 1112
10478 c1111  continue
10479 C Contribution from graph II
10480       call transpose2(EE(1,1,k),auxmat(1,1))
10481       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10482       vv(1)=pizda(1,1)+pizda(2,2)
10483       vv(2)=pizda(2,1)-pizda(1,2)
10484       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10485      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10486 C Explicit gradient in virtual-dihedral angles.
10487       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10488      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10489       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10490       vv(1)=pizda(1,1)+pizda(2,2)
10491       vv(2)=pizda(2,1)-pizda(1,2)
10492       if (l.eq.j+1) then
10493         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10494      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10495      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10496       else
10497         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10498      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10499      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10500       endif
10501 C Cartesian gradient
10502       do iii=1,2
10503         do kkk=1,5
10504           do lll=1,3
10505             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10506      &        pizda(1,1))
10507             vv(1)=pizda(1,1)+pizda(2,2)
10508             vv(2)=pizda(2,1)-pizda(1,2)
10509             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10510      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10511      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10512           enddo
10513         enddo
10514       enddo
10515 cd      goto 1112
10516 cd1111  continue
10517       if (l.eq.j+1) then
10518 cd        goto 1110
10519 C Parallel orientation
10520 C Contribution from graph III
10521         call transpose2(EUg(1,1,l),auxmat(1,1))
10522         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10523         vv(1)=pizda(1,1)-pizda(2,2)
10524         vv(2)=pizda(1,2)+pizda(2,1)
10525         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10526      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10527 C Explicit gradient in virtual-dihedral angles.
10528         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10529      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10530      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10531         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10532         vv(1)=pizda(1,1)-pizda(2,2)
10533         vv(2)=pizda(1,2)+pizda(2,1)
10534         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10535      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10536      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10537         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10538         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10539         vv(1)=pizda(1,1)-pizda(2,2)
10540         vv(2)=pizda(1,2)+pizda(2,1)
10541         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10542      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10543      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10544 C Cartesian gradient
10545         do iii=1,2
10546           do kkk=1,5
10547             do lll=1,3
10548               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10549      &          pizda(1,1))
10550               vv(1)=pizda(1,1)-pizda(2,2)
10551               vv(2)=pizda(1,2)+pizda(2,1)
10552               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10553      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10554      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10555             enddo
10556           enddo
10557         enddo
10558 cd        goto 1112
10559 C Contribution from graph IV
10560 cd1110    continue
10561         call transpose2(EE(1,1,l),auxmat(1,1))
10562         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10563         vv(1)=pizda(1,1)+pizda(2,2)
10564         vv(2)=pizda(2,1)-pizda(1,2)
10565         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10566      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10567 C Explicit gradient in virtual-dihedral angles.
10568         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10569      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10570         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10571         vv(1)=pizda(1,1)+pizda(2,2)
10572         vv(2)=pizda(2,1)-pizda(1,2)
10573         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10574      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10575      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10576 C Cartesian gradient
10577         do iii=1,2
10578           do kkk=1,5
10579             do lll=1,3
10580               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10581      &          pizda(1,1))
10582               vv(1)=pizda(1,1)+pizda(2,2)
10583               vv(2)=pizda(2,1)-pizda(1,2)
10584               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10585      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10586      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10587             enddo
10588           enddo
10589         enddo
10590       else
10591 C Antiparallel orientation
10592 C Contribution from graph III
10593 c        goto 1110
10594         call transpose2(EUg(1,1,j),auxmat(1,1))
10595         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10596         vv(1)=pizda(1,1)-pizda(2,2)
10597         vv(2)=pizda(1,2)+pizda(2,1)
10598         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10599      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10600 C Explicit gradient in virtual-dihedral angles.
10601         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10602      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10603      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10604         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10605         vv(1)=pizda(1,1)-pizda(2,2)
10606         vv(2)=pizda(1,2)+pizda(2,1)
10607         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10608      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10609      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10610         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10611         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10612         vv(1)=pizda(1,1)-pizda(2,2)
10613         vv(2)=pizda(1,2)+pizda(2,1)
10614         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10615      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10616      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10617 C Cartesian gradient
10618         do iii=1,2
10619           do kkk=1,5
10620             do lll=1,3
10621               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10622      &          pizda(1,1))
10623               vv(1)=pizda(1,1)-pizda(2,2)
10624               vv(2)=pizda(1,2)+pizda(2,1)
10625               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10626      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10627      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10628             enddo
10629           enddo
10630         enddo
10631 cd        goto 1112
10632 C Contribution from graph IV
10633 1110    continue
10634         call transpose2(EE(1,1,j),auxmat(1,1))
10635         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10636         vv(1)=pizda(1,1)+pizda(2,2)
10637         vv(2)=pizda(2,1)-pizda(1,2)
10638         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10639      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10640 C Explicit gradient in virtual-dihedral angles.
10641         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10642      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10643         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10644         vv(1)=pizda(1,1)+pizda(2,2)
10645         vv(2)=pizda(2,1)-pizda(1,2)
10646         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10647      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10648      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10649 C Cartesian gradient
10650         do iii=1,2
10651           do kkk=1,5
10652             do lll=1,3
10653               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10654      &          pizda(1,1))
10655               vv(1)=pizda(1,1)+pizda(2,2)
10656               vv(2)=pizda(2,1)-pizda(1,2)
10657               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10658      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10659      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10660             enddo
10661           enddo
10662         enddo
10663       endif
10664 1112  continue
10665       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10666 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10667 cd        write (2,*) 'ijkl',i,j,k,l
10668 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10669 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10670 cd      endif
10671 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10672 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10673 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10674 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10675       if (j.lt.nres-1) then
10676         j1=j+1
10677         j2=j-1
10678       else
10679         j1=j-1
10680         j2=j-2
10681       endif
10682       if (l.lt.nres-1) then
10683         l1=l+1
10684         l2=l-1
10685       else
10686         l1=l-1
10687         l2=l-2
10688       endif
10689 cd      eij=1.0d0
10690 cd      ekl=1.0d0
10691 cd      ekont=1.0d0
10692 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10693 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10694 C        summed up outside the subrouine as for the other subroutines
10695 C        handling long-range interactions. The old code is commented out
10696 C        with "cgrad" to keep track of changes.
10697       do ll=1,3
10698 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10699 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10700         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10701         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10702 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10703 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10704 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10705 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10706 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10707 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10708 c     &   gradcorr5ij,
10709 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10710 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10711 cgrad        ghalf=0.5d0*ggg1(ll)
10712 cd        ghalf=0.0d0
10713         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10714         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10715         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10716         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10717         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10718         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10719 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10720 cgrad        ghalf=0.5d0*ggg2(ll)
10721 cd        ghalf=0.0d0
10722         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10723         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10724         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10725         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10726         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10727         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10728       enddo
10729 cd      goto 1112
10730 cgrad      do m=i+1,j-1
10731 cgrad        do ll=1,3
10732 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10733 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10734 cgrad        enddo
10735 cgrad      enddo
10736 cgrad      do m=k+1,l-1
10737 cgrad        do ll=1,3
10738 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10739 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10740 cgrad        enddo
10741 cgrad      enddo
10742 c1112  continue
10743 cgrad      do m=i+2,j2
10744 cgrad        do ll=1,3
10745 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10746 cgrad        enddo
10747 cgrad      enddo
10748 cgrad      do m=k+2,l2
10749 cgrad        do ll=1,3
10750 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10751 cgrad        enddo
10752 cgrad      enddo
10753 cd      do iii=1,nres-3
10754 cd        write (2,*) iii,g_corr5_loc(iii)
10755 cd      enddo
10756       eello5=ekont*eel5
10757 cd      write (2,*) 'ekont',ekont
10758 cd      write (iout,*) 'eello5',ekont*eel5
10759       return
10760       end
10761 c--------------------------------------------------------------------------
10762       double precision function eello6(i,j,k,l,jj,kk)
10763       implicit real*8 (a-h,o-z)
10764       include 'DIMENSIONS'
10765       include 'COMMON.IOUNITS'
10766       include 'COMMON.CHAIN'
10767       include 'COMMON.DERIV'
10768       include 'COMMON.INTERACT'
10769       include 'COMMON.CONTACTS'
10770       include 'COMMON.TORSION'
10771       include 'COMMON.VAR'
10772       include 'COMMON.GEO'
10773       include 'COMMON.FFIELD'
10774       double precision ggg1(3),ggg2(3)
10775 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10776 cd        eello6=0.0d0
10777 cd        return
10778 cd      endif
10779 cd      write (iout,*)
10780 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10781 cd     &   ' and',k,l
10782       eello6_1=0.0d0
10783       eello6_2=0.0d0
10784       eello6_3=0.0d0
10785       eello6_4=0.0d0
10786       eello6_5=0.0d0
10787       eello6_6=0.0d0
10788 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10789 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10790       do iii=1,2
10791         do kkk=1,5
10792           do lll=1,3
10793             derx(lll,kkk,iii)=0.0d0
10794           enddo
10795         enddo
10796       enddo
10797 cd      eij=facont_hb(jj,i)
10798 cd      ekl=facont_hb(kk,k)
10799 cd      ekont=eij*ekl
10800 cd      eij=1.0d0
10801 cd      ekl=1.0d0
10802 cd      ekont=1.0d0
10803       if (l.eq.j+1) then
10804         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10805         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10806         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10807         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10808         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10809         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10810       else
10811         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10812         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10813         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10814         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10815         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10816           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10817         else
10818           eello6_5=0.0d0
10819         endif
10820         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10821       endif
10822 C If turn contributions are considered, they will be handled separately.
10823       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10824 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10825 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10826 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10827 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10828 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10829 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10830 cd      goto 1112
10831       if (j.lt.nres-1) then
10832         j1=j+1
10833         j2=j-1
10834       else
10835         j1=j-1
10836         j2=j-2
10837       endif
10838       if (l.lt.nres-1) then
10839         l1=l+1
10840         l2=l-1
10841       else
10842         l1=l-1
10843         l2=l-2
10844       endif
10845       do ll=1,3
10846 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10847 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10848 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10849 cgrad        ghalf=0.5d0*ggg1(ll)
10850 cd        ghalf=0.0d0
10851         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10852         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10853         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10854         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10855         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10856         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10857         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10858         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10859 cgrad        ghalf=0.5d0*ggg2(ll)
10860 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10861 cd        ghalf=0.0d0
10862         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10863         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10864         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10865         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10866         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10867         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10868       enddo
10869 cd      goto 1112
10870 cgrad      do m=i+1,j-1
10871 cgrad        do ll=1,3
10872 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10873 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10874 cgrad        enddo
10875 cgrad      enddo
10876 cgrad      do m=k+1,l-1
10877 cgrad        do ll=1,3
10878 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10879 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10880 cgrad        enddo
10881 cgrad      enddo
10882 cgrad1112  continue
10883 cgrad      do m=i+2,j2
10884 cgrad        do ll=1,3
10885 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10886 cgrad        enddo
10887 cgrad      enddo
10888 cgrad      do m=k+2,l2
10889 cgrad        do ll=1,3
10890 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10891 cgrad        enddo
10892 cgrad      enddo
10893 cd      do iii=1,nres-3
10894 cd        write (2,*) iii,g_corr6_loc(iii)
10895 cd      enddo
10896       eello6=ekont*eel6
10897 cd      write (2,*) 'ekont',ekont
10898 cd      write (iout,*) 'eello6',ekont*eel6
10899       return
10900       end
10901 c--------------------------------------------------------------------------
10902       double precision function eello6_graph1(i,j,k,l,imat,swap)
10903       implicit real*8 (a-h,o-z)
10904       include 'DIMENSIONS'
10905       include 'COMMON.IOUNITS'
10906       include 'COMMON.CHAIN'
10907       include 'COMMON.DERIV'
10908       include 'COMMON.INTERACT'
10909       include 'COMMON.CONTACTS'
10910       include 'COMMON.TORSION'
10911       include 'COMMON.VAR'
10912       include 'COMMON.GEO'
10913       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10914       logical swap
10915       logical lprn
10916       common /kutas/ lprn
10917 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10918 C                                                                              C
10919 C      Parallel       Antiparallel                                             C
10920 C                                                                              C
10921 C          o             o                                                     C
10922 C         /l\           /j\                                                    C
10923 C        /   \         /   \                                                   C
10924 C       /| o |         | o |\                                                  C
10925 C     \ j|/k\|  /   \  |/k\|l /                                                C
10926 C      \ /   \ /     \ /   \ /                                                 C
10927 C       o     o       o     o                                                  C
10928 C       i             i                                                        C
10929 C                                                                              C
10930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10931       itk=itype2loc(itype(k))
10932       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10933       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10934       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10935       call transpose2(EUgC(1,1,k),auxmat(1,1))
10936       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10937       vv1(1)=pizda1(1,1)-pizda1(2,2)
10938       vv1(2)=pizda1(1,2)+pizda1(2,1)
10939       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10940       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10941       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10942       s5=scalar2(vv(1),Dtobr2(1,i))
10943 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10944       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10945       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10946      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10947      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10948      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10949      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10950      & +scalar2(vv(1),Dtobr2der(1,i)))
10951       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10952       vv1(1)=pizda1(1,1)-pizda1(2,2)
10953       vv1(2)=pizda1(1,2)+pizda1(2,1)
10954       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10955       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10956       if (l.eq.j+1) then
10957         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10958      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10959      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10960      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10961      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10962       else
10963         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10964      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10965      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10966      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10967      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10968       endif
10969       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10970       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10971       vv1(1)=pizda1(1,1)-pizda1(2,2)
10972       vv1(2)=pizda1(1,2)+pizda1(2,1)
10973       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10974      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10975      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10976      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10977       do iii=1,2
10978         if (swap) then
10979           ind=3-iii
10980         else
10981           ind=iii
10982         endif
10983         do kkk=1,5
10984           do lll=1,3
10985             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10986             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10987             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10988             call transpose2(EUgC(1,1,k),auxmat(1,1))
10989             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10990      &        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)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10995      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10996             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10997      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10998             s5=scalar2(vv(1),Dtobr2(1,i))
10999             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11000           enddo
11001         enddo
11002       enddo
11003       return
11004       end
11005 c----------------------------------------------------------------------------
11006       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11007       implicit real*8 (a-h,o-z)
11008       include 'DIMENSIONS'
11009       include 'COMMON.IOUNITS'
11010       include 'COMMON.CHAIN'
11011       include 'COMMON.DERIV'
11012       include 'COMMON.INTERACT'
11013       include 'COMMON.CONTACTS'
11014       include 'COMMON.TORSION'
11015       include 'COMMON.VAR'
11016       include 'COMMON.GEO'
11017       logical swap
11018       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11019      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11020       logical lprn
11021       common /kutas/ lprn
11022 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11023 C                                                                              C
11024 C      Parallel       Antiparallel                                             C
11025 C                                                                              C
11026 C          o             o                                                     C
11027 C     \   /l\           /j\   /                                                C
11028 C      \ /   \         /   \ /                                                 C
11029 C       o| o |         | o |o                                                  C
11030 C     \ j|/k\|      \  |/k\|l                                                  C
11031 C      \ /   \       \ /   \                                                   C
11032 C       o             o                                                        C
11033 C       i             i                                                        C
11034 C                                                                              C
11035 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11036 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11037 C AL 7/4/01 s1 would occur in the sixth-order moment,
11038 C           but not in a cluster cumulant
11039 #ifdef MOMENT
11040       s1=dip(1,jj,i)*dip(1,kk,k)
11041 #endif
11042       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11043       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11044       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11045       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11046       call transpose2(EUg(1,1,k),auxmat(1,1))
11047       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11048       vv(1)=pizda(1,1)-pizda(2,2)
11049       vv(2)=pizda(1,2)+pizda(2,1)
11050       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11051 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11052 #ifdef MOMENT
11053       eello6_graph2=-(s1+s2+s3+s4)
11054 #else
11055       eello6_graph2=-(s2+s3+s4)
11056 #endif
11057 c      eello6_graph2=-s3
11058 C Derivatives in gamma(i-1)
11059       if (i.gt.1) then
11060 #ifdef MOMENT
11061         s1=dipderg(1,jj,i)*dip(1,kk,k)
11062 #endif
11063         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11064         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11065         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11066         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11067 #ifdef MOMENT
11068         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11069 #else
11070         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11071 #endif
11072 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11073       endif
11074 C Derivatives in gamma(k-1)
11075 #ifdef MOMENT
11076       s1=dip(1,jj,i)*dipderg(1,kk,k)
11077 #endif
11078       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11079       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11080       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11081       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11082       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11083       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11084       vv(1)=pizda(1,1)-pizda(2,2)
11085       vv(2)=pizda(1,2)+pizda(2,1)
11086       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11087 #ifdef MOMENT
11088       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11089 #else
11090       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11091 #endif
11092 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11093 C Derivatives in gamma(j-1) or gamma(l-1)
11094       if (j.gt.1) then
11095 #ifdef MOMENT
11096         s1=dipderg(3,jj,i)*dip(1,kk,k)
11097 #endif
11098         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11099         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11100         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11101         call matmat2(ADtEA1derg(1,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 #ifdef MOMENT
11106         if (swap) then
11107           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11108         else
11109           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11110         endif
11111 #endif
11112         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11113 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11114       endif
11115 C Derivatives in gamma(l-1) or gamma(j-1)
11116       if (l.gt.1) then
11117 #ifdef MOMENT
11118         s1=dip(1,jj,i)*dipderg(3,kk,k)
11119 #endif
11120         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11121         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11122         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11123         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11124         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11125         vv(1)=pizda(1,1)-pizda(2,2)
11126         vv(2)=pizda(1,2)+pizda(2,1)
11127         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11128 #ifdef MOMENT
11129         if (swap) then
11130           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11131         else
11132           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11133         endif
11134 #endif
11135         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11136 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11137       endif
11138 C Cartesian derivatives.
11139       if (lprn) then
11140         write (2,*) 'In eello6_graph2'
11141         do iii=1,2
11142           write (2,*) 'iii=',iii
11143           do kkk=1,5
11144             write (2,*) 'kkk=',kkk
11145             do jjj=1,2
11146               write (2,'(3(2f10.5),5x)')
11147      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11148             enddo
11149           enddo
11150         enddo
11151       endif
11152       do iii=1,2
11153         do kkk=1,5
11154           do lll=1,3
11155 #ifdef MOMENT
11156             if (iii.eq.1) then
11157               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11158             else
11159               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11160             endif
11161 #endif
11162             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11163      &        auxvec(1))
11164             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11165             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11166      &        auxvec(1))
11167             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11168             call transpose2(EUg(1,1,k),auxmat(1,1))
11169             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11170      &        pizda(1,1))
11171             vv(1)=pizda(1,1)-pizda(2,2)
11172             vv(2)=pizda(1,2)+pizda(2,1)
11173             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11174 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11175 #ifdef MOMENT
11176             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11177 #else
11178             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11179 #endif
11180             if (swap) then
11181               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11182             else
11183               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11184             endif
11185           enddo
11186         enddo
11187       enddo
11188       return
11189       end
11190 c----------------------------------------------------------------------------
11191       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11192       implicit real*8 (a-h,o-z)
11193       include 'DIMENSIONS'
11194       include 'COMMON.IOUNITS'
11195       include 'COMMON.CHAIN'
11196       include 'COMMON.DERIV'
11197       include 'COMMON.INTERACT'
11198       include 'COMMON.CONTACTS'
11199       include 'COMMON.TORSION'
11200       include 'COMMON.VAR'
11201       include 'COMMON.GEO'
11202       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11203       logical swap
11204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11205 C                                                                              C
11206 C      Parallel       Antiparallel                                             C
11207 C                                                                              C
11208 C          o             o                                                     C
11209 C         /l\   /   \   /j\                                                    C
11210 C        /   \ /     \ /   \                                                   C
11211 C       /| o |o       o| o |\                                                  C
11212 C       j|/k\|  /      |/k\|l /                                                C
11213 C        /   \ /       /   \ /                                                 C
11214 C       /     o       /     o                                                  C
11215 C       i             i                                                        C
11216 C                                                                              C
11217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11218 C
11219 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11220 C           energy moment and not to the cluster cumulant.
11221       iti=itortyp(itype(i))
11222       if (j.lt.nres-1) then
11223         itj1=itype2loc(itype(j+1))
11224       else
11225         itj1=nloctyp
11226       endif
11227       itk=itype2loc(itype(k))
11228       itk1=itype2loc(itype(k+1))
11229       if (l.lt.nres-1) then
11230         itl1=itype2loc(itype(l+1))
11231       else
11232         itl1=nloctyp
11233       endif
11234 #ifdef MOMENT
11235       s1=dip(4,jj,i)*dip(4,kk,k)
11236 #endif
11237       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11238       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11239       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11240       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11241       call transpose2(EE(1,1,k),auxmat(1,1))
11242       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11243       vv(1)=pizda(1,1)+pizda(2,2)
11244       vv(2)=pizda(2,1)-pizda(1,2)
11245       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11246 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11247 cd     & "sum",-(s2+s3+s4)
11248 #ifdef MOMENT
11249       eello6_graph3=-(s1+s2+s3+s4)
11250 #else
11251       eello6_graph3=-(s2+s3+s4)
11252 #endif
11253 c      eello6_graph3=-s4
11254 C Derivatives in gamma(k-1)
11255       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11256       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11257       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11258       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11259 C Derivatives in gamma(l-1)
11260       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11261       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11262       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11263       vv(1)=pizda(1,1)+pizda(2,2)
11264       vv(2)=pizda(2,1)-pizda(1,2)
11265       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11266       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11267 C Cartesian derivatives.
11268       do iii=1,2
11269         do kkk=1,5
11270           do lll=1,3
11271 #ifdef MOMENT
11272             if (iii.eq.1) then
11273               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11274             else
11275               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11276             endif
11277 #endif
11278             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11279      &        auxvec(1))
11280             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11281             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11282      &        auxvec(1))
11283             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11284             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11285      &        pizda(1,1))
11286             vv(1)=pizda(1,1)+pizda(2,2)
11287             vv(2)=pizda(2,1)-pizda(1,2)
11288             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11289 #ifdef MOMENT
11290             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11291 #else
11292             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11293 #endif
11294             if (swap) then
11295               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11296             else
11297               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11298             endif
11299 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11300           enddo
11301         enddo
11302       enddo
11303       return
11304       end
11305 c----------------------------------------------------------------------------
11306       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11307       implicit real*8 (a-h,o-z)
11308       include 'DIMENSIONS'
11309       include 'COMMON.IOUNITS'
11310       include 'COMMON.CHAIN'
11311       include 'COMMON.DERIV'
11312       include 'COMMON.INTERACT'
11313       include 'COMMON.CONTACTS'
11314       include 'COMMON.TORSION'
11315       include 'COMMON.VAR'
11316       include 'COMMON.GEO'
11317       include 'COMMON.FFIELD'
11318       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11319      & auxvec1(2),auxmat1(2,2)
11320       logical swap
11321 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11322 C                                                                              C
11323 C      Parallel       Antiparallel                                             C
11324 C                                                                              C
11325 C          o             o                                                     C
11326 C         /l\   /   \   /j\                                                    C
11327 C        /   \ /     \ /   \                                                   C
11328 C       /| o |o       o| o |\                                                  C
11329 C     \ j|/k\|      \  |/k\|l                                                  C
11330 C      \ /   \       \ /   \                                                   C
11331 C       o     \       o     \                                                  C
11332 C       i             i                                                        C
11333 C                                                                              C
11334 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11335 C
11336 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11337 C           energy moment and not to the cluster cumulant.
11338 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11339       iti=itype2loc(itype(i))
11340       itj=itype2loc(itype(j))
11341       if (j.lt.nres-1) then
11342         itj1=itype2loc(itype(j+1))
11343       else
11344         itj1=nloctyp
11345       endif
11346       itk=itype2loc(itype(k))
11347       if (k.lt.nres-1) then
11348         itk1=itype2loc(itype(k+1))
11349       else
11350         itk1=nloctyp
11351       endif
11352       itl=itype2loc(itype(l))
11353       if (l.lt.nres-1) then
11354         itl1=itype2loc(itype(l+1))
11355       else
11356         itl1=nloctyp
11357       endif
11358 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11359 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11360 cd     & ' itl',itl,' itl1',itl1
11361 #ifdef MOMENT
11362       if (imat.eq.1) then
11363         s1=dip(3,jj,i)*dip(3,kk,k)
11364       else
11365         s1=dip(2,jj,j)*dip(2,kk,l)
11366       endif
11367 #endif
11368       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11369       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11370       if (j.eq.l+1) then
11371         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11372         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11373       else
11374         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11375         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11376       endif
11377       call transpose2(EUg(1,1,k),auxmat(1,1))
11378       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11379       vv(1)=pizda(1,1)-pizda(2,2)
11380       vv(2)=pizda(2,1)+pizda(1,2)
11381       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11382 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11383 #ifdef MOMENT
11384       eello6_graph4=-(s1+s2+s3+s4)
11385 #else
11386       eello6_graph4=-(s2+s3+s4)
11387 #endif
11388 C Derivatives in gamma(i-1)
11389       if (i.gt.1) then
11390 #ifdef MOMENT
11391         if (imat.eq.1) then
11392           s1=dipderg(2,jj,i)*dip(3,kk,k)
11393         else
11394           s1=dipderg(4,jj,j)*dip(2,kk,l)
11395         endif
11396 #endif
11397         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11398         if (j.eq.l+1) then
11399           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11400           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11401         else
11402           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11403           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11404         endif
11405         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11406         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11407 cd          write (2,*) 'turn6 derivatives'
11408 #ifdef MOMENT
11409           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11410 #else
11411           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11412 #endif
11413         else
11414 #ifdef MOMENT
11415           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11416 #else
11417           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11418 #endif
11419         endif
11420       endif
11421 C Derivatives in gamma(k-1)
11422 #ifdef MOMENT
11423       if (imat.eq.1) then
11424         s1=dip(3,jj,i)*dipderg(2,kk,k)
11425       else
11426         s1=dip(2,jj,j)*dipderg(4,kk,l)
11427       endif
11428 #endif
11429       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11430       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11431       if (j.eq.l+1) then
11432         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11433         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11434       else
11435         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11436         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11437       endif
11438       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11439       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11440       vv(1)=pizda(1,1)-pizda(2,2)
11441       vv(2)=pizda(2,1)+pizda(1,2)
11442       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11443       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11444 #ifdef MOMENT
11445         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11446 #else
11447         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11448 #endif
11449       else
11450 #ifdef MOMENT
11451         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11452 #else
11453         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11454 #endif
11455       endif
11456 C Derivatives in gamma(j-1) or gamma(l-1)
11457       if (l.eq.j+1 .and. l.gt.1) then
11458         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11459         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11460         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11461         vv(1)=pizda(1,1)-pizda(2,2)
11462         vv(2)=pizda(2,1)+pizda(1,2)
11463         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11464         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11465       else if (j.gt.1) then
11466         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11467         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11468         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11469         vv(1)=pizda(1,1)-pizda(2,2)
11470         vv(2)=pizda(2,1)+pizda(1,2)
11471         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11472         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11473           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11474         else
11475           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11476         endif
11477       endif
11478 C Cartesian derivatives.
11479       do iii=1,2
11480         do kkk=1,5
11481           do lll=1,3
11482 #ifdef MOMENT
11483             if (iii.eq.1) then
11484               if (imat.eq.1) then
11485                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11486               else
11487                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11488               endif
11489             else
11490               if (imat.eq.1) then
11491                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11492               else
11493                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11494               endif
11495             endif
11496 #endif
11497             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11498      &        auxvec(1))
11499             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11500             if (j.eq.l+1) then
11501               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11502      &          b1(1,j+1),auxvec(1))
11503               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11504             else
11505               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11506      &          b1(1,l+1),auxvec(1))
11507               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11508             endif
11509             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11510      &        pizda(1,1))
11511             vv(1)=pizda(1,1)-pizda(2,2)
11512             vv(2)=pizda(2,1)+pizda(1,2)
11513             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11514             if (swap) then
11515               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11516 #ifdef MOMENT
11517                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11518      &             -(s1+s2+s4)
11519 #else
11520                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11521      &             -(s2+s4)
11522 #endif
11523                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11524               else
11525 #ifdef MOMENT
11526                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11527 #else
11528                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11529 #endif
11530                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11531               endif
11532             else
11533 #ifdef MOMENT
11534               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11535 #else
11536               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11537 #endif
11538               if (l.eq.j+1) then
11539                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11540               else
11541                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11542               endif
11543             endif
11544           enddo
11545         enddo
11546       enddo
11547       return
11548       end
11549 c----------------------------------------------------------------------------
11550       double precision function eello_turn6(i,jj,kk)
11551       implicit real*8 (a-h,o-z)
11552       include 'DIMENSIONS'
11553       include 'COMMON.IOUNITS'
11554       include 'COMMON.CHAIN'
11555       include 'COMMON.DERIV'
11556       include 'COMMON.INTERACT'
11557       include 'COMMON.CONTACTS'
11558       include 'COMMON.TORSION'
11559       include 'COMMON.VAR'
11560       include 'COMMON.GEO'
11561       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11562      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11563      &  ggg1(3),ggg2(3)
11564       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11565      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11566 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11567 C           the respective energy moment and not to the cluster cumulant.
11568       s1=0.0d0
11569       s8=0.0d0
11570       s13=0.0d0
11571 c
11572       eello_turn6=0.0d0
11573       j=i+4
11574       k=i+1
11575       l=i+3
11576       iti=itype2loc(itype(i))
11577       itk=itype2loc(itype(k))
11578       itk1=itype2loc(itype(k+1))
11579       itl=itype2loc(itype(l))
11580       itj=itype2loc(itype(j))
11581 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11582 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11583 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11584 cd        eello6=0.0d0
11585 cd        return
11586 cd      endif
11587 cd      write (iout,*)
11588 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11589 cd     &   ' and',k,l
11590 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11591       do iii=1,2
11592         do kkk=1,5
11593           do lll=1,3
11594             derx_turn(lll,kkk,iii)=0.0d0
11595           enddo
11596         enddo
11597       enddo
11598 cd      eij=1.0d0
11599 cd      ekl=1.0d0
11600 cd      ekont=1.0d0
11601       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11602 cd      eello6_5=0.0d0
11603 cd      write (2,*) 'eello6_5',eello6_5
11604 #ifdef MOMENT
11605       call transpose2(AEA(1,1,1),auxmat(1,1))
11606       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11607       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11608       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11609 #endif
11610       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11611       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11612       s2 = scalar2(b1(1,k),vtemp1(1))
11613 #ifdef MOMENT
11614       call transpose2(AEA(1,1,2),atemp(1,1))
11615       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11616       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11617       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11618 #endif
11619       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11620       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11621       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11622 #ifdef MOMENT
11623       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11624       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11625       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11626       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11627       ss13 = scalar2(b1(1,k),vtemp4(1))
11628       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11629 #endif
11630 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11631 c      s1=0.0d0
11632 c      s2=0.0d0
11633 c      s8=0.0d0
11634 c      s12=0.0d0
11635 c      s13=0.0d0
11636       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11637 C Derivatives in gamma(i+2)
11638       s1d =0.0d0
11639       s8d =0.0d0
11640 #ifdef MOMENT
11641       call transpose2(AEA(1,1,1),auxmatd(1,1))
11642       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11643       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11644       call transpose2(AEAderg(1,1,2),atempd(1,1))
11645       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11646       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11647 #endif
11648       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11649       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11650       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11651 c      s1d=0.0d0
11652 c      s2d=0.0d0
11653 c      s8d=0.0d0
11654 c      s12d=0.0d0
11655 c      s13d=0.0d0
11656       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11657 C Derivatives in gamma(i+3)
11658 #ifdef MOMENT
11659       call transpose2(AEA(1,1,1),auxmatd(1,1))
11660       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11661       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11662       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11663 #endif
11664       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11665       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11666       s2d = scalar2(b1(1,k),vtemp1d(1))
11667 #ifdef MOMENT
11668       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11669       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11670 #endif
11671       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11672 #ifdef MOMENT
11673       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11674       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11675       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11676 #endif
11677 c      s1d=0.0d0
11678 c      s2d=0.0d0
11679 c      s8d=0.0d0
11680 c      s12d=0.0d0
11681 c      s13d=0.0d0
11682 #ifdef MOMENT
11683       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11684      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11685 #else
11686       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11687      &               -0.5d0*ekont*(s2d+s12d)
11688 #endif
11689 C Derivatives in gamma(i+4)
11690       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11691       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11692       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11693 #ifdef MOMENT
11694       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11695       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11696       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11697 #endif
11698 c      s1d=0.0d0
11699 c      s2d=0.0d0
11700 c      s8d=0.0d0
11701 C      s12d=0.0d0
11702 c      s13d=0.0d0
11703 #ifdef MOMENT
11704       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11705 #else
11706       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11707 #endif
11708 C Derivatives in gamma(i+5)
11709 #ifdef MOMENT
11710       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11711       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11712       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11713 #endif
11714       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11715       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11716       s2d = scalar2(b1(1,k),vtemp1d(1))
11717 #ifdef MOMENT
11718       call transpose2(AEA(1,1,2),atempd(1,1))
11719       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11720       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11721 #endif
11722       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11723       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11724 #ifdef MOMENT
11725       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11726       ss13d = scalar2(b1(1,k),vtemp4d(1))
11727       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11728 #endif
11729 c      s1d=0.0d0
11730 c      s2d=0.0d0
11731 c      s8d=0.0d0
11732 c      s12d=0.0d0
11733 c      s13d=0.0d0
11734 #ifdef MOMENT
11735       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11736      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11737 #else
11738       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11739      &               -0.5d0*ekont*(s2d+s12d)
11740 #endif
11741 C Cartesian derivatives
11742       do iii=1,2
11743         do kkk=1,5
11744           do lll=1,3
11745 #ifdef MOMENT
11746             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11747             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11748             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11749 #endif
11750             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11751             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11752      &          vtemp1d(1))
11753             s2d = scalar2(b1(1,k),vtemp1d(1))
11754 #ifdef MOMENT
11755             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11756             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11757             s8d = -(atempd(1,1)+atempd(2,2))*
11758      &           scalar2(cc(1,1,l),vtemp2(1))
11759 #endif
11760             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11761      &           auxmatd(1,1))
11762             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11763             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11764 c      s1d=0.0d0
11765 c      s2d=0.0d0
11766 c      s8d=0.0d0
11767 c      s12d=0.0d0
11768 c      s13d=0.0d0
11769 #ifdef MOMENT
11770             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11771      &        - 0.5d0*(s1d+s2d)
11772 #else
11773             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11774      &        - 0.5d0*s2d
11775 #endif
11776 #ifdef MOMENT
11777             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11778      &        - 0.5d0*(s8d+s12d)
11779 #else
11780             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11781      &        - 0.5d0*s12d
11782 #endif
11783           enddo
11784         enddo
11785       enddo
11786 #ifdef MOMENT
11787       do kkk=1,5
11788         do lll=1,3
11789           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11790      &      achuj_tempd(1,1))
11791           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11792           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11793           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11794           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11795           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11796      &      vtemp4d(1))
11797           ss13d = scalar2(b1(1,k),vtemp4d(1))
11798           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11799           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11800         enddo
11801       enddo
11802 #endif
11803 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11804 cd     &  16*eel_turn6_num
11805 cd      goto 1112
11806       if (j.lt.nres-1) then
11807         j1=j+1
11808         j2=j-1
11809       else
11810         j1=j-1
11811         j2=j-2
11812       endif
11813       if (l.lt.nres-1) then
11814         l1=l+1
11815         l2=l-1
11816       else
11817         l1=l-1
11818         l2=l-2
11819       endif
11820       do ll=1,3
11821 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11822 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11823 cgrad        ghalf=0.5d0*ggg1(ll)
11824 cd        ghalf=0.0d0
11825         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11826         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11827         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11828      &    +ekont*derx_turn(ll,2,1)
11829         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11830         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11831      &    +ekont*derx_turn(ll,4,1)
11832         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11833         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11834         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11835 cgrad        ghalf=0.5d0*ggg2(ll)
11836 cd        ghalf=0.0d0
11837         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11838      &    +ekont*derx_turn(ll,2,2)
11839         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11840         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11841      &    +ekont*derx_turn(ll,4,2)
11842         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11843         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11844         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11845       enddo
11846 cd      goto 1112
11847 cgrad      do m=i+1,j-1
11848 cgrad        do ll=1,3
11849 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11850 cgrad        enddo
11851 cgrad      enddo
11852 cgrad      do m=k+1,l-1
11853 cgrad        do ll=1,3
11854 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11855 cgrad        enddo
11856 cgrad      enddo
11857 cgrad1112  continue
11858 cgrad      do m=i+2,j2
11859 cgrad        do ll=1,3
11860 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11861 cgrad        enddo
11862 cgrad      enddo
11863 cgrad      do m=k+2,l2
11864 cgrad        do ll=1,3
11865 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11866 cgrad        enddo
11867 cgrad      enddo
11868 cd      do iii=1,nres-3
11869 cd        write (2,*) iii,g_corr6_loc(iii)
11870 cd      enddo
11871       eello_turn6=ekont*eel_turn6
11872 cd      write (2,*) 'ekont',ekont
11873 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11874       return
11875       end
11876
11877 C-----------------------------------------------------------------------------
11878       double precision function scalar(u,v)
11879 !DIR$ INLINEALWAYS scalar
11880 #ifndef OSF
11881 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11882 #endif
11883       implicit none
11884       double precision u(3),v(3)
11885 cd      double precision sc
11886 cd      integer i
11887 cd      sc=0.0d0
11888 cd      do i=1,3
11889 cd        sc=sc+u(i)*v(i)
11890 cd      enddo
11891 cd      scalar=sc
11892
11893       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11894       return
11895       end
11896 crc-------------------------------------------------
11897       SUBROUTINE MATVEC2(A1,V1,V2)
11898 !DIR$ INLINEALWAYS MATVEC2
11899 #ifndef OSF
11900 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11901 #endif
11902       implicit real*8 (a-h,o-z)
11903       include 'DIMENSIONS'
11904       DIMENSION A1(2,2),V1(2),V2(2)
11905 c      DO 1 I=1,2
11906 c        VI=0.0
11907 c        DO 3 K=1,2
11908 c    3     VI=VI+A1(I,K)*V1(K)
11909 c        Vaux(I)=VI
11910 c    1 CONTINUE
11911
11912       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11913       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11914
11915       v2(1)=vaux1
11916       v2(2)=vaux2
11917       END
11918 C---------------------------------------
11919       SUBROUTINE MATMAT2(A1,A2,A3)
11920 #ifndef OSF
11921 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11922 #endif
11923       implicit real*8 (a-h,o-z)
11924       include 'DIMENSIONS'
11925       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11926 c      DIMENSION AI3(2,2)
11927 c        DO  J=1,2
11928 c          A3IJ=0.0
11929 c          DO K=1,2
11930 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11931 c          enddo
11932 c          A3(I,J)=A3IJ
11933 c       enddo
11934 c      enddo
11935
11936       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11937       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11938       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11939       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11940
11941       A3(1,1)=AI3_11
11942       A3(2,1)=AI3_21
11943       A3(1,2)=AI3_12
11944       A3(2,2)=AI3_22
11945       END
11946
11947 c-------------------------------------------------------------------------
11948       double precision function scalar2(u,v)
11949 !DIR$ INLINEALWAYS scalar2
11950       implicit none
11951       double precision u(2),v(2)
11952       double precision sc
11953       integer i
11954       scalar2=u(1)*v(1)+u(2)*v(2)
11955       return
11956       end
11957
11958 C-----------------------------------------------------------------------------
11959
11960       subroutine transpose2(a,at)
11961 !DIR$ INLINEALWAYS transpose2
11962 #ifndef OSF
11963 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11964 #endif
11965       implicit none
11966       double precision a(2,2),at(2,2)
11967       at(1,1)=a(1,1)
11968       at(1,2)=a(2,1)
11969       at(2,1)=a(1,2)
11970       at(2,2)=a(2,2)
11971       return
11972       end
11973 c--------------------------------------------------------------------------
11974       subroutine transpose(n,a,at)
11975       implicit none
11976       integer n,i,j
11977       double precision a(n,n),at(n,n)
11978       do i=1,n
11979         do j=1,n
11980           at(j,i)=a(i,j)
11981         enddo
11982       enddo
11983       return
11984       end
11985 C---------------------------------------------------------------------------
11986       subroutine prodmat3(a1,a2,kk,transp,prod)
11987 !DIR$ INLINEALWAYS prodmat3
11988 #ifndef OSF
11989 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11990 #endif
11991       implicit none
11992       integer i,j
11993       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11994       logical transp
11995 crc      double precision auxmat(2,2),prod_(2,2)
11996
11997       if (transp) then
11998 crc        call transpose2(kk(1,1),auxmat(1,1))
11999 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12000 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12001
12002            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12003      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12004            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12005      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12006            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12007      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12008            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12009      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12010
12011       else
12012 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12013 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12014
12015            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12016      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12017            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12018      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12019            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12020      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12021            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12022      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12023
12024       endif
12025 c      call transpose2(a2(1,1),a2t(1,1))
12026
12027 crc      print *,transp
12028 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12029 crc      print *,((prod(i,j),i=1,2),j=1,2)
12030
12031       return
12032       end
12033 CCC----------------------------------------------
12034       subroutine Eliptransfer(eliptran)
12035       implicit real*8 (a-h,o-z)
12036       include 'DIMENSIONS'
12037       include 'COMMON.GEO'
12038       include 'COMMON.VAR'
12039       include 'COMMON.LOCAL'
12040       include 'COMMON.CHAIN'
12041       include 'COMMON.DERIV'
12042       include 'COMMON.NAMES'
12043       include 'COMMON.INTERACT'
12044       include 'COMMON.IOUNITS'
12045       include 'COMMON.CALC'
12046       include 'COMMON.CONTROL'
12047       include 'COMMON.SPLITELE'
12048       include 'COMMON.SBRIDGE'
12049 C this is done by Adasko
12050 C      print *,"wchodze"
12051 C structure of box:
12052 C      water
12053 C--bordliptop-- buffore starts
12054 C--bufliptop--- here true lipid starts
12055 C      lipid
12056 C--buflipbot--- lipid ends buffore starts
12057 C--bordlipbot--buffore ends
12058       eliptran=0.0
12059       do i=ilip_start,ilip_end
12060 C       do i=1,1
12061         if (itype(i).eq.ntyp1) cycle
12062
12063         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12064         if (positi.le.0.0) positi=positi+boxzsize
12065 C        print *,i
12066 C first for peptide groups
12067 c for each residue check if it is in lipid or lipid water border area
12068        if ((positi.gt.bordlipbot)
12069      &.and.(positi.lt.bordliptop)) then
12070 C the energy transfer exist
12071         if (positi.lt.buflipbot) then
12072 C what fraction I am in
12073          fracinbuf=1.0d0-
12074      &        ((positi-bordlipbot)/lipbufthick)
12075 C lipbufthick is thickenes of lipid buffore
12076          sslip=sscalelip(fracinbuf)
12077          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12078          eliptran=eliptran+sslip*pepliptran
12079          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12080          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12081 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12082
12083 C        print *,"doing sccale for lower part"
12084 C         print *,i,sslip,fracinbuf,ssgradlip
12085         elseif (positi.gt.bufliptop) then
12086          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12087          sslip=sscalelip(fracinbuf)
12088          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12089          eliptran=eliptran+sslip*pepliptran
12090          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12091          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12092 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12093 C          print *, "doing sscalefor top part"
12094 C         print *,i,sslip,fracinbuf,ssgradlip
12095         else
12096          eliptran=eliptran+pepliptran
12097 C         print *,"I am in true lipid"
12098         endif
12099 C       else
12100 C       eliptran=elpitran+0.0 ! I am in water
12101        endif
12102        enddo
12103 C       print *, "nic nie bylo w lipidzie?"
12104 C now multiply all by the peptide group transfer factor
12105 C       eliptran=eliptran*pepliptran
12106 C now the same for side chains
12107 CV       do i=1,1
12108        do i=ilip_start,ilip_end
12109         if (itype(i).eq.ntyp1) cycle
12110         positi=(mod(c(3,i+nres),boxzsize))
12111         if (positi.le.0) positi=positi+boxzsize
12112 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12113 c for each residue check if it is in lipid or lipid water border area
12114 C       respos=mod(c(3,i+nres),boxzsize)
12115 C       print *,positi,bordlipbot,buflipbot
12116        if ((positi.gt.bordlipbot)
12117      & .and.(positi.lt.bordliptop)) then
12118 C the energy transfer exist
12119         if (positi.lt.buflipbot) then
12120          fracinbuf=1.0d0-
12121      &     ((positi-bordlipbot)/lipbufthick)
12122 C lipbufthick is thickenes of lipid buffore
12123          sslip=sscalelip(fracinbuf)
12124          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12125          eliptran=eliptran+sslip*liptranene(itype(i))
12126          gliptranx(3,i)=gliptranx(3,i)
12127      &+ssgradlip*liptranene(itype(i))
12128          gliptranc(3,i-1)= gliptranc(3,i-1)
12129      &+ssgradlip*liptranene(itype(i))
12130 C         print *,"doing sccale for lower part"
12131         elseif (positi.gt.bufliptop) then
12132          fracinbuf=1.0d0-
12133      &((bordliptop-positi)/lipbufthick)
12134          sslip=sscalelip(fracinbuf)
12135          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12136          eliptran=eliptran+sslip*liptranene(itype(i))
12137          gliptranx(3,i)=gliptranx(3,i)
12138      &+ssgradlip*liptranene(itype(i))
12139          gliptranc(3,i-1)= gliptranc(3,i-1)
12140      &+ssgradlip*liptranene(itype(i))
12141 C          print *, "doing sscalefor top part",sslip,fracinbuf
12142         else
12143          eliptran=eliptran+liptranene(itype(i))
12144 C         print *,"I am in true lipid"
12145         endif
12146         endif ! if in lipid or buffor
12147 C       else
12148 C       eliptran=elpitran+0.0 ! I am in water
12149        enddo
12150        return
12151        end
12152 C---------------------------------------------------------
12153 C AFM soubroutine for constant force
12154        subroutine AFMforce(Eafmforce)
12155        implicit real*8 (a-h,o-z)
12156       include 'DIMENSIONS'
12157       include 'COMMON.GEO'
12158       include 'COMMON.VAR'
12159       include 'COMMON.LOCAL'
12160       include 'COMMON.CHAIN'
12161       include 'COMMON.DERIV'
12162       include 'COMMON.NAMES'
12163       include 'COMMON.INTERACT'
12164       include 'COMMON.IOUNITS'
12165       include 'COMMON.CALC'
12166       include 'COMMON.CONTROL'
12167       include 'COMMON.SPLITELE'
12168       include 'COMMON.SBRIDGE'
12169       real*8 diffafm(3)
12170       dist=0.0d0
12171       Eafmforce=0.0d0
12172       do i=1,3
12173       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12174       dist=dist+diffafm(i)**2
12175       enddo
12176       dist=dsqrt(dist)
12177       Eafmforce=-forceAFMconst*(dist-distafminit)
12178       do i=1,3
12179       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12180       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12181       enddo
12182 C      print *,'AFM',Eafmforce
12183       return
12184       end
12185 C---------------------------------------------------------
12186 C AFM subroutine with pseudoconstant velocity
12187        subroutine AFMvel(Eafmforce)
12188        implicit real*8 (a-h,o-z)
12189       include 'DIMENSIONS'
12190       include 'COMMON.GEO'
12191       include 'COMMON.VAR'
12192       include 'COMMON.LOCAL'
12193       include 'COMMON.CHAIN'
12194       include 'COMMON.DERIV'
12195       include 'COMMON.NAMES'
12196       include 'COMMON.INTERACT'
12197       include 'COMMON.IOUNITS'
12198       include 'COMMON.CALC'
12199       include 'COMMON.CONTROL'
12200       include 'COMMON.SPLITELE'
12201       include 'COMMON.SBRIDGE'
12202       real*8 diffafm(3)
12203 C Only for check grad COMMENT if not used for checkgrad
12204 C      totT=3.0d0
12205 C--------------------------------------------------------
12206 C      print *,"wchodze"
12207       dist=0.0d0
12208       Eafmforce=0.0d0
12209       do i=1,3
12210       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12211       dist=dist+diffafm(i)**2
12212       enddo
12213       dist=dsqrt(dist)
12214       Eafmforce=0.5d0*forceAFMconst
12215      & *(distafminit+totTafm*velAFMconst-dist)**2
12216 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12217       do i=1,3
12218       gradafm(i,afmend-1)=-forceAFMconst*
12219      &(distafminit+totTafm*velAFMconst-dist)
12220      &*diffafm(i)/dist
12221       gradafm(i,afmbeg-1)=forceAFMconst*
12222      &(distafminit+totTafm*velAFMconst-dist)
12223      &*diffafm(i)/dist
12224       enddo
12225 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12226       return
12227       end
12228 C-----------------------------------------------------------
12229 C first for shielding is setting of function of side-chains
12230        subroutine set_shield_fac
12231       implicit real*8 (a-h,o-z)
12232       include 'DIMENSIONS'
12233       include 'COMMON.CHAIN'
12234       include 'COMMON.DERIV'
12235       include 'COMMON.IOUNITS'
12236       include 'COMMON.SHIELD'
12237       include 'COMMON.INTERACT'
12238 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12239       double precision div77_81/0.974996043d0/,
12240      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12241
12242 C the vector between center of side_chain and peptide group
12243        double precision pep_side(3),long,side_calf(3),
12244      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12245      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12246 C the line belowe needs to be changed for FGPROC>1
12247       do i=1,nres-1
12248       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12249       ishield_list(i)=0
12250 Cif there two consequtive dummy atoms there is no peptide group between them
12251 C the line below has to be changed for FGPROC>1
12252       VolumeTotal=0.0
12253       do k=1,nres
12254        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12255        dist_pep_side=0.0
12256        dist_side_calf=0.0
12257        do j=1,3
12258 C first lets set vector conecting the ithe side-chain with kth side-chain
12259       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12260 C      pep_side(j)=2.0d0
12261 C and vector conecting the side-chain with its proper calfa
12262       side_calf(j)=c(j,k+nres)-c(j,k)
12263 C      side_calf(j)=2.0d0
12264       pept_group(j)=c(j,i)-c(j,i+1)
12265 C lets have their lenght
12266       dist_pep_side=pep_side(j)**2+dist_pep_side
12267       dist_side_calf=dist_side_calf+side_calf(j)**2
12268       dist_pept_group=dist_pept_group+pept_group(j)**2
12269       enddo
12270        dist_pep_side=dsqrt(dist_pep_side)
12271        dist_pept_group=dsqrt(dist_pept_group)
12272        dist_side_calf=dsqrt(dist_side_calf)
12273       do j=1,3
12274         pep_side_norm(j)=pep_side(j)/dist_pep_side
12275         side_calf_norm(j)=dist_side_calf
12276       enddo
12277 C now sscale fraction
12278        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12279 C       print *,buff_shield,"buff"
12280 C now sscale
12281         if (sh_frac_dist.le.0.0) cycle
12282 C If we reach here it means that this side chain reaches the shielding sphere
12283 C Lets add him to the list for gradient
12284         ishield_list(i)=ishield_list(i)+1
12285 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12286 C this list is essential otherwise problem would be O3
12287         shield_list(ishield_list(i),i)=k
12288 C Lets have the sscale value
12289         if (sh_frac_dist.gt.1.0) then
12290          scale_fac_dist=1.0d0
12291          do j=1,3
12292          sh_frac_dist_grad(j)=0.0d0
12293          enddo
12294         else
12295          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12296      &                   *(2.0*sh_frac_dist-3.0d0)
12297          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12298      &                  /dist_pep_side/buff_shield*0.5
12299 C remember for the final gradient multiply sh_frac_dist_grad(j)
12300 C for side_chain by factor -2 !
12301          do j=1,3
12302          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12303 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12304 C     &                    sh_frac_dist_grad(j)
12305          enddo
12306         endif
12307 C        if ((i.eq.3).and.(k.eq.2)) then
12308 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12309 C     & ,"TU"
12310 C        endif
12311
12312 C this is what is now we have the distance scaling now volume...
12313       short=short_r_sidechain(itype(k))
12314       long=long_r_sidechain(itype(k))
12315       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12316 C now costhet_grad
12317 C       costhet=0.0d0
12318        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12319 C       costhet_fac=0.0d0
12320        do j=1,3
12321          costhet_grad(j)=costhet_fac*pep_side(j)
12322        enddo
12323 C remember for the final gradient multiply costhet_grad(j)
12324 C for side_chain by factor -2 !
12325 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12326 C pep_side0pept_group is vector multiplication
12327       pep_side0pept_group=0.0
12328       do j=1,3
12329       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12330       enddo
12331       cosalfa=(pep_side0pept_group/
12332      & (dist_pep_side*dist_side_calf))
12333       fac_alfa_sin=1.0-cosalfa**2
12334       fac_alfa_sin=dsqrt(fac_alfa_sin)
12335       rkprim=fac_alfa_sin*(long-short)+short
12336 C now costhet_grad
12337        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12338        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12339
12340        do j=1,3
12341          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12342      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12343      &*(long-short)/fac_alfa_sin*cosalfa/
12344      &((dist_pep_side*dist_side_calf))*
12345      &((side_calf(j))-cosalfa*
12346      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12347
12348         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12349      &*(long-short)/fac_alfa_sin*cosalfa
12350      &/((dist_pep_side*dist_side_calf))*
12351      &(pep_side(j)-
12352      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12353        enddo
12354
12355       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12356      &                    /VSolvSphere_div
12357      &                    *wshield
12358 C now the gradient...
12359 C grad_shield is gradient of Calfa for peptide groups
12360 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12361 C     &               costhet,cosphi
12362 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12363 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12364       do j=1,3
12365       grad_shield(j,i)=grad_shield(j,i)
12366 C gradient po skalowaniu
12367      &                +(sh_frac_dist_grad(j)
12368 C  gradient po costhet
12369      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12370      &-scale_fac_dist*(cosphi_grad_long(j))
12371      &/(1.0-cosphi) )*div77_81
12372      &*VofOverlap
12373 C grad_shield_side is Cbeta sidechain gradient
12374       grad_shield_side(j,ishield_list(i),i)=
12375      &        (sh_frac_dist_grad(j)*(-2.0d0)
12376      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12377      &       +scale_fac_dist*(cosphi_grad_long(j))
12378      &        *2.0d0/(1.0-cosphi))
12379      &        *div77_81*VofOverlap
12380
12381        grad_shield_loc(j,ishield_list(i),i)=
12382      &   scale_fac_dist*cosphi_grad_loc(j)
12383      &        *2.0d0/(1.0-cosphi)
12384      &        *div77_81*VofOverlap
12385       enddo
12386       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12387       enddo
12388       fac_shield(i)=VolumeTotal*div77_81+div4_81
12389 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12390       enddo
12391       return
12392       end
12393 C--------------------------------------------------------------------------
12394       double precision function tschebyshev(m,n,x,y)
12395       implicit none
12396       include "DIMENSIONS"
12397       integer i,m,n
12398       double precision x(n),y,yy(0:maxvar),aux
12399 c Tschebyshev polynomial. Note that the first term is omitted
12400 c m=0: the constant term is included
12401 c m=1: the constant term is not included
12402       yy(0)=1.0d0
12403       yy(1)=y
12404       do i=2,n
12405         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12406       enddo
12407       aux=0.0d0
12408       do i=m,n
12409         aux=aux+x(i)*yy(i)
12410       enddo
12411       tschebyshev=aux
12412       return
12413       end
12414 C--------------------------------------------------------------------------
12415       double precision function gradtschebyshev(m,n,x,y)
12416       implicit none
12417       include "DIMENSIONS"
12418       integer i,m,n
12419       double precision x(n+1),y,yy(0:maxvar),aux
12420 c Tschebyshev polynomial. Note that the first term is omitted
12421 c m=0: the constant term is included
12422 c m=1: the constant term is not included
12423       yy(0)=1.0d0
12424       yy(1)=2.0d0*y
12425       do i=2,n
12426         yy(i)=2*y*yy(i-1)-yy(i-2)
12427       enddo
12428       aux=0.0d0
12429       do i=m,n
12430         aux=aux+x(i+1)*yy(i)*(i+1)
12431 C        print *, x(i+1),yy(i),i
12432       enddo
12433       gradtschebyshev=aux
12434       return
12435       end
12436 C------------------------------------------------------------------------
12437 C first for shielding is setting of function of side-chains
12438        subroutine set_shield_fac2
12439       implicit real*8 (a-h,o-z)
12440       include 'DIMENSIONS'
12441       include 'COMMON.CHAIN'
12442       include 'COMMON.DERIV'
12443       include 'COMMON.IOUNITS'
12444       include 'COMMON.SHIELD'
12445       include 'COMMON.INTERACT'
12446 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12447       double precision div77_81/0.974996043d0/,
12448      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12449
12450 C the vector between center of side_chain and peptide group
12451        double precision pep_side(3),long,side_calf(3),
12452      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12453      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12454 C the line belowe needs to be changed for FGPROC>1
12455       do i=1,nres-1
12456       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12457       ishield_list(i)=0
12458 Cif there two consequtive dummy atoms there is no peptide group between them
12459 C the line below has to be changed for FGPROC>1
12460       VolumeTotal=0.0
12461       do k=1,nres
12462        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12463        dist_pep_side=0.0
12464        dist_side_calf=0.0
12465        do j=1,3
12466 C first lets set vector conecting the ithe side-chain with kth side-chain
12467       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12468 C      pep_side(j)=2.0d0
12469 C and vector conecting the side-chain with its proper calfa
12470       side_calf(j)=c(j,k+nres)-c(j,k)
12471 C      side_calf(j)=2.0d0
12472       pept_group(j)=c(j,i)-c(j,i+1)
12473 C lets have their lenght
12474       dist_pep_side=pep_side(j)**2+dist_pep_side
12475       dist_side_calf=dist_side_calf+side_calf(j)**2
12476       dist_pept_group=dist_pept_group+pept_group(j)**2
12477       enddo
12478        dist_pep_side=dsqrt(dist_pep_side)
12479        dist_pept_group=dsqrt(dist_pept_group)
12480        dist_side_calf=dsqrt(dist_side_calf)
12481       do j=1,3
12482         pep_side_norm(j)=pep_side(j)/dist_pep_side
12483         side_calf_norm(j)=dist_side_calf
12484       enddo
12485 C now sscale fraction
12486        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12487 C       print *,buff_shield,"buff"
12488 C now sscale
12489         if (sh_frac_dist.le.0.0) cycle
12490 C If we reach here it means that this side chain reaches the shielding sphere
12491 C Lets add him to the list for gradient
12492         ishield_list(i)=ishield_list(i)+1
12493 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12494 C this list is essential otherwise problem would be O3
12495         shield_list(ishield_list(i),i)=k
12496 C Lets have the sscale value
12497         if (sh_frac_dist.gt.1.0) then
12498          scale_fac_dist=1.0d0
12499          do j=1,3
12500          sh_frac_dist_grad(j)=0.0d0
12501          enddo
12502         else
12503          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12504      &                   *(2.0d0*sh_frac_dist-3.0d0)
12505          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12506      &                  /dist_pep_side/buff_shield*0.5d0
12507 C remember for the final gradient multiply sh_frac_dist_grad(j)
12508 C for side_chain by factor -2 !
12509          do j=1,3
12510          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12511 C         sh_frac_dist_grad(j)=0.0d0
12512 C         scale_fac_dist=1.0d0
12513 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12514 C     &                    sh_frac_dist_grad(j)
12515          enddo
12516         endif
12517 C this is what is now we have the distance scaling now volume...
12518       short=short_r_sidechain(itype(k))
12519       long=long_r_sidechain(itype(k))
12520       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12521       sinthet=short/dist_pep_side*costhet
12522 C now costhet_grad
12523 C       costhet=0.6d0
12524 C       sinthet=0.8
12525        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12526 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12527 C     &             -short/dist_pep_side**2/costhet)
12528 C       costhet_fac=0.0d0
12529        do j=1,3
12530          costhet_grad(j)=costhet_fac*pep_side(j)
12531        enddo
12532 C remember for the final gradient multiply costhet_grad(j)
12533 C for side_chain by factor -2 !
12534 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12535 C pep_side0pept_group is vector multiplication
12536       pep_side0pept_group=0.0d0
12537       do j=1,3
12538       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12539       enddo
12540       cosalfa=(pep_side0pept_group/
12541      & (dist_pep_side*dist_side_calf))
12542       fac_alfa_sin=1.0d0-cosalfa**2
12543       fac_alfa_sin=dsqrt(fac_alfa_sin)
12544       rkprim=fac_alfa_sin*(long-short)+short
12545 C      rkprim=short
12546
12547 C now costhet_grad
12548        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12549 C       cosphi=0.6
12550        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12551        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12552      &      dist_pep_side**2)
12553 C       sinphi=0.8
12554        do j=1,3
12555          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12556      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12557      &*(long-short)/fac_alfa_sin*cosalfa/
12558      &((dist_pep_side*dist_side_calf))*
12559      &((side_calf(j))-cosalfa*
12560      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12561 C       cosphi_grad_long(j)=0.0d0
12562         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12563      &*(long-short)/fac_alfa_sin*cosalfa
12564      &/((dist_pep_side*dist_side_calf))*
12565      &(pep_side(j)-
12566      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12567 C       cosphi_grad_loc(j)=0.0d0
12568        enddo
12569 C      print *,sinphi,sinthet
12570 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12571 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12572       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12573      &                    /VSolvSphere_div
12574 C     &                    *wshield
12575 C now the gradient...
12576       do j=1,3
12577       grad_shield(j,i)=grad_shield(j,i)
12578 C gradient po skalowaniu
12579      &                +(sh_frac_dist_grad(j)*VofOverlap
12580 C  gradient po costhet
12581      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12582      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12583      &       sinphi/sinthet*costhet*costhet_grad(j)
12584      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12585      & )*wshield
12586 C grad_shield_side is Cbeta sidechain gradient
12587       grad_shield_side(j,ishield_list(i),i)=
12588      &        (sh_frac_dist_grad(j)*(-2.0d0)
12589      &        *VofOverlap
12590      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12591      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12592      &       sinphi/sinthet*costhet*costhet_grad(j)
12593      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12594      &       )*wshield
12595
12596        grad_shield_loc(j,ishield_list(i),i)=
12597      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12598      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12599      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12600      &        ))
12601      &        *wshield
12602       enddo
12603 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12604 c     & scale_fac_dist
12605       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12606       enddo
12607       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12608 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12609 c     &  " wshield",wshield
12610 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12611       enddo
12612       return
12613       end
12614 C-----------------------------------------------------------------------
12615 C-----------------------------------------------------------
12616 C This subroutine is to mimic the histone like structure but as well can be
12617 C utilizet to nanostructures (infinit) small modification has to be used to
12618 C make it finite (z gradient at the ends has to be changes as well as the x,y
12619 C gradient has to be modified at the ends
12620 C The energy function is Kihara potential
12621 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12622 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12623 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12624 C simple Kihara potential
12625       subroutine calctube(Etube)
12626        implicit real*8 (a-h,o-z)
12627       include 'DIMENSIONS'
12628       include 'COMMON.GEO'
12629       include 'COMMON.VAR'
12630       include 'COMMON.LOCAL'
12631       include 'COMMON.CHAIN'
12632       include 'COMMON.DERIV'
12633       include 'COMMON.NAMES'
12634       include 'COMMON.INTERACT'
12635       include 'COMMON.IOUNITS'
12636       include 'COMMON.CALC'
12637       include 'COMMON.CONTROL'
12638       include 'COMMON.SPLITELE'
12639       include 'COMMON.SBRIDGE'
12640       double precision tub_r,vectube(3),enetube(maxres*2)
12641       Etube=0.0d0
12642       do i=1,2*nres
12643         enetube(i)=0.0d0
12644       enddo
12645 C first we calculate the distance from tube center
12646 C first sugare-phosphate group for NARES this would be peptide group
12647 C for UNRES
12648       do i=1,nres
12649 C lets ommit dummy atoms for now
12650        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12651 C now calculate distance from center of tube and direction vectors
12652       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12653           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12654       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12655           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12656       vectube(1)=vectube(1)-tubecenter(1)
12657       vectube(2)=vectube(2)-tubecenter(2)
12658
12659 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12660 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12661
12662 C as the tube is infinity we do not calculate the Z-vector use of Z
12663 C as chosen axis
12664       vectube(3)=0.0d0
12665 C now calculte the distance
12666        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12667 C now normalize vector
12668       vectube(1)=vectube(1)/tub_r
12669       vectube(2)=vectube(2)/tub_r
12670 C calculte rdiffrence between r and r0
12671       rdiff=tub_r-tubeR0
12672 C and its 6 power
12673       rdiff6=rdiff**6.0d0
12674 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12675        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12676 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12677 C       print *,rdiff,rdiff6,pep_aa_tube
12678 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12679 C now we calculate gradient
12680        fac=(-12.0d0*pep_aa_tube/rdiff6+
12681      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12682 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12683 C     &rdiff,fac
12684
12685 C now direction of gg_tube vector
12686         do j=1,3
12687         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12688         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12689         enddo
12690         enddo
12691 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12692         do i=1,nres
12693 C Lets not jump over memory as we use many times iti
12694          iti=itype(i)
12695 C lets ommit dummy atoms for now
12696          if ((iti.eq.ntyp1)
12697 C in UNRES uncomment the line below as GLY has no side-chain...
12698 C      .or.(iti.eq.10)
12699      &   ) cycle
12700           vectube(1)=c(1,i+nres)
12701           vectube(1)=mod(vectube(1),boxxsize)
12702           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12703           vectube(2)=c(2,i+nres)
12704           vectube(2)=mod(vectube(2),boxxsize)
12705           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12706
12707       vectube(1)=vectube(1)-tubecenter(1)
12708       vectube(2)=vectube(2)-tubecenter(2)
12709
12710 C as the tube is infinity we do not calculate the Z-vector use of Z
12711 C as chosen axis
12712       vectube(3)=0.0d0
12713 C now calculte the distance
12714        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12715 C now normalize vector
12716       vectube(1)=vectube(1)/tub_r
12717       vectube(2)=vectube(2)/tub_r
12718 C calculte rdiffrence between r and r0
12719       rdiff=tub_r-tubeR0
12720 C and its 6 power
12721       rdiff6=rdiff**6.0d0
12722 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12723        sc_aa_tube=sc_aa_tube_par(iti)
12724        sc_bb_tube=sc_bb_tube_par(iti)
12725        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12726 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12727 C now we calculate gradient
12728        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12729      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12730 C now direction of gg_tube vector
12731          do j=1,3
12732           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12733           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12734          enddo
12735         enddo
12736         do i=1,2*nres
12737           Etube=Etube+enetube(i)
12738         enddo
12739 C        print *,"ETUBE", etube
12740         return
12741         end
12742 C TO DO 1) add to total energy
12743 C       2) add to gradient summation
12744 C       3) add reading parameters (AND of course oppening of PARAM file)
12745 C       4) add reading the center of tube
12746 C       5) add COMMONs
12747 C       6) add to zerograd
12748
12749 C-----------------------------------------------------------------------
12750 C-----------------------------------------------------------
12751 C This subroutine is to mimic the histone like structure but as well can be
12752 C utilizet to nanostructures (infinit) small modification has to be used to
12753 C make it finite (z gradient at the ends has to be changes as well as the x,y
12754 C gradient has to be modified at the ends
12755 C The energy function is Kihara potential
12756 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12757 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12758 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12759 C simple Kihara potential
12760       subroutine calctube2(Etube)
12761        implicit real*8 (a-h,o-z)
12762       include 'DIMENSIONS'
12763       include 'COMMON.GEO'
12764       include 'COMMON.VAR'
12765       include 'COMMON.LOCAL'
12766       include 'COMMON.CHAIN'
12767       include 'COMMON.DERIV'
12768       include 'COMMON.NAMES'
12769       include 'COMMON.INTERACT'
12770       include 'COMMON.IOUNITS'
12771       include 'COMMON.CALC'
12772       include 'COMMON.CONTROL'
12773       include 'COMMON.SPLITELE'
12774       include 'COMMON.SBRIDGE'
12775       double precision tub_r,vectube(3),enetube(maxres*2)
12776       Etube=0.0d0
12777       do i=1,2*nres
12778         enetube(i)=0.0d0
12779       enddo
12780 C first we calculate the distance from tube center
12781 C first sugare-phosphate group for NARES this would be peptide group
12782 C for UNRES
12783       do i=1,nres
12784 C lets ommit dummy atoms for now
12785        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12786 C now calculate distance from center of tube and direction vectors
12787       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12788           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12789       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12790           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12791       vectube(1)=vectube(1)-tubecenter(1)
12792       vectube(2)=vectube(2)-tubecenter(2)
12793
12794 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12795 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12796
12797 C as the tube is infinity we do not calculate the Z-vector use of Z
12798 C as chosen axis
12799       vectube(3)=0.0d0
12800 C now calculte the distance
12801        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12802 C now normalize vector
12803       vectube(1)=vectube(1)/tub_r
12804       vectube(2)=vectube(2)/tub_r
12805 C calculte rdiffrence between r and r0
12806       rdiff=tub_r-tubeR0
12807 C and its 6 power
12808       rdiff6=rdiff**6.0d0
12809 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12810        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12811 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12812 C       print *,rdiff,rdiff6,pep_aa_tube
12813 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12814 C now we calculate gradient
12815        fac=(-12.0d0*pep_aa_tube/rdiff6+
12816      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12817 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12818 C     &rdiff,fac
12819
12820 C now direction of gg_tube vector
12821         do j=1,3
12822         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12823         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12824         enddo
12825         enddo
12826 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12827         do i=1,nres
12828 C Lets not jump over memory as we use many times iti
12829          iti=itype(i)
12830 C lets ommit dummy atoms for now
12831          if ((iti.eq.ntyp1)
12832 C in UNRES uncomment the line below as GLY has no side-chain...
12833      &      .or.(iti.eq.10)
12834      &   ) cycle
12835           vectube(1)=c(1,i+nres)
12836           vectube(1)=mod(vectube(1),boxxsize)
12837           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12838           vectube(2)=c(2,i+nres)
12839           vectube(2)=mod(vectube(2),boxxsize)
12840           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12841
12842       vectube(1)=vectube(1)-tubecenter(1)
12843       vectube(2)=vectube(2)-tubecenter(2)
12844 C THIS FRAGMENT MAKES TUBE FINITE
12845         positi=(mod(c(3,i+nres),boxzsize))
12846         if (positi.le.0) positi=positi+boxzsize
12847 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12848 c for each residue check if it is in lipid or lipid water border area
12849 C       respos=mod(c(3,i+nres),boxzsize)
12850        print *,positi,bordtubebot,buftubebot,bordtubetop
12851        if ((positi.gt.bordtubebot)
12852      & .and.(positi.lt.bordtubetop)) then
12853 C the energy transfer exist
12854         if (positi.lt.buftubebot) then
12855          fracinbuf=1.0d0-
12856      &     ((positi-bordtubebot)/tubebufthick)
12857 C lipbufthick is thickenes of lipid buffore
12858          sstube=sscalelip(fracinbuf)
12859          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12860          print *,ssgradtube, sstube,tubetranene(itype(i))
12861          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12862          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12863      &+ssgradtube*tubetranene(itype(i))
12864          gg_tube(3,i-1)= gg_tube(3,i-1)
12865      &+ssgradtube*tubetranene(itype(i))
12866 C         print *,"doing sccale for lower part"
12867         elseif (positi.gt.buftubetop) then
12868          fracinbuf=1.0d0-
12869      &((bordtubetop-positi)/tubebufthick)
12870          sstube=sscalelip(fracinbuf)
12871          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12872          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12873 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12874 C     &+ssgradtube*tubetranene(itype(i))
12875 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12876 C     &+ssgradtube*tubetranene(itype(i))
12877 C          print *, "doing sscalefor top part",sslip,fracinbuf
12878         else
12879          sstube=1.0d0
12880          ssgradtube=0.0d0
12881          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12882 C         print *,"I am in true lipid"
12883         endif
12884         else
12885 C          sstube=0.0d0
12886 C          ssgradtube=0.0d0
12887         cycle
12888         endif ! if in lipid or buffor
12889 CEND OF FINITE FRAGMENT
12890 C as the tube is infinity we do not calculate the Z-vector use of Z
12891 C as chosen axis
12892       vectube(3)=0.0d0
12893 C now calculte the distance
12894        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12895 C now normalize vector
12896       vectube(1)=vectube(1)/tub_r
12897       vectube(2)=vectube(2)/tub_r
12898 C calculte rdiffrence between r and r0
12899       rdiff=tub_r-tubeR0
12900 C and its 6 power
12901       rdiff6=rdiff**6.0d0
12902 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12903        sc_aa_tube=sc_aa_tube_par(iti)
12904        sc_bb_tube=sc_bb_tube_par(iti)
12905        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12906      &                 *sstube+enetube(i+nres)
12907 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12908 C now we calculate gradient
12909        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12910      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12911 C now direction of gg_tube vector
12912          do j=1,3
12913           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12914           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12915          enddo
12916          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12917      &+ssgradtube*enetube(i+nres)/sstube
12918          gg_tube(3,i-1)= gg_tube(3,i-1)
12919      &+ssgradtube*enetube(i+nres)/sstube
12920
12921         enddo
12922         do i=1,2*nres
12923           Etube=Etube+enetube(i)
12924         enddo
12925 C        print *,"ETUBE", etube
12926         return
12927         end
12928 C TO DO 1) add to total energy
12929 C       2) add to gradient summation
12930 C       3) add reading parameters (AND of course oppening of PARAM file)
12931 C       4) add reading the center of tube
12932 C       5) add COMMONs
12933 C       6) add to zerograd
12934 c----------------------------------------------------------------------------
12935       subroutine e_saxs(Esaxs_constr)
12936       implicit none
12937       include 'DIMENSIONS'
12938 #ifdef MPI
12939       include "mpif.h"
12940       include "COMMON.SETUP"
12941       integer IERR
12942 #endif
12943       include 'COMMON.SBRIDGE'
12944       include 'COMMON.CHAIN'
12945       include 'COMMON.GEO'
12946       include 'COMMON.DERIV'
12947       include 'COMMON.LOCAL'
12948       include 'COMMON.INTERACT'
12949       include 'COMMON.VAR'
12950       include 'COMMON.IOUNITS'
12951 c      include 'COMMON.MD'
12952 #ifdef LANG0
12953 #ifdef FIVEDIAG
12954       include 'COMMON.LANGEVIN.lang0.5diag'
12955 #else
12956       include 'COMMON.LANGEVIN.lang0'
12957 #endif
12958 #else
12959       include 'COMMON.LANGEVIN'
12960 #endif
12961       include 'COMMON.CONTROL'
12962       include 'COMMON.SAXS'
12963       include 'COMMON.NAMES'
12964       include 'COMMON.TIME1'
12965       include 'COMMON.FFIELD'
12966 c
12967       double precision Esaxs_constr
12968       integer i,iint,j,k,l
12969       double precision PgradC(maxSAXS,3,maxres),
12970      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12971 #ifdef MPI
12972       double precision PgradC_(maxSAXS,3,maxres),
12973      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12974 #endif
12975       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12976      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12977      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12978      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12979       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12980       double precision dist,mygauss,mygaussder
12981       external dist
12982       integer llicz,lllicz
12983       double precision time01
12984 c  SAXS restraint penalty function
12985 #ifdef DEBUG
12986       write(iout,*) "------- SAXS penalty function start -------"
12987       write (iout,*) "nsaxs",nsaxs
12988       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12989       write (iout,*) "Psaxs"
12990       do i=1,nsaxs
12991         write (iout,'(i5,e15.5)') i, Psaxs(i)
12992       enddo
12993 #endif
12994 #ifdef TIMING
12995       time01=MPI_Wtime()
12996 #endif
12997       Esaxs_constr = 0.0d0
12998       do k=1,nsaxs
12999         Pcalc(k)=0.0d0
13000         do j=1,nres
13001           do l=1,3
13002             PgradC(k,l,j)=0.0d0
13003             PgradX(k,l,j)=0.0d0
13004           enddo
13005         enddo
13006       enddo
13007 c      lllicz=0
13008       do i=iatsc_s,iatsc_e
13009        if (itype(i).eq.ntyp1) cycle
13010        do iint=1,nint_gr(i)
13011          do j=istart(i,iint),iend(i,iint)
13012            if (itype(j).eq.ntyp1) cycle
13013 #ifdef ALLSAXS
13014            dijCACA=dist(i,j)
13015            dijCASC=dist(i,j+nres)
13016            dijSCCA=dist(i+nres,j)
13017            dijSCSC=dist(i+nres,j+nres)
13018            sigma2CACA=2.0d0/(pstok**2)
13019            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13020            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13021            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13022            do k=1,nsaxs
13023              dk = distsaxs(k)
13024              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13025              if (itype(j).ne.10) then
13026              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13027              else
13028              endif
13029              expCASC = 0.0d0
13030              if (itype(i).ne.10) then
13031              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13032              else
13033              expSCCA = 0.0d0
13034              endif
13035              if (itype(i).ne.10 .and. itype(j).ne.10) then
13036              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13037              else
13038              expSCSC = 0.0d0
13039              endif
13040              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13041 #ifdef DEBUG
13042              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13043 #endif
13044              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13045              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13046              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13047              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13048              do l=1,3
13049 c CA CA
13050                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13051                PgradC(k,l,i) = PgradC(k,l,i)-aux
13052                PgradC(k,l,j) = PgradC(k,l,j)+aux
13053 c CA SC
13054                if (itype(j).ne.10) then
13055                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13056                PgradC(k,l,i) = PgradC(k,l,i)-aux
13057                PgradC(k,l,j) = PgradC(k,l,j)+aux
13058                PgradX(k,l,j) = PgradX(k,l,j)+aux
13059                endif
13060 c SC CA
13061                if (itype(i).ne.10) then
13062                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13063                PgradX(k,l,i) = PgradX(k,l,i)-aux
13064                PgradC(k,l,i) = PgradC(k,l,i)-aux
13065                PgradC(k,l,j) = PgradC(k,l,j)+aux
13066                endif
13067 c SC SC
13068                if (itype(i).ne.10 .and. itype(j).ne.10) then
13069                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13070                PgradC(k,l,i) = PgradC(k,l,i)-aux
13071                PgradC(k,l,j) = PgradC(k,l,j)+aux
13072                PgradX(k,l,i) = PgradX(k,l,i)-aux
13073                PgradX(k,l,j) = PgradX(k,l,j)+aux
13074                endif
13075              enddo ! l
13076            enddo ! k
13077 #else
13078            dijCACA=dist(i,j)
13079            sigma2CACA=scal_rad**2*0.25d0/
13080      &        (restok(itype(j))**2+restok(itype(i))**2)
13081 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13082 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13083 #ifdef MYGAUSS
13084            sigmaCACA=dsqrt(sigma2CACA)
13085            threesig=3.0d0/sigmaCACA
13086 c           llicz=0
13087            do k=1,nsaxs
13088              dk = distsaxs(k)
13089              if (dabs(dijCACA-dk).ge.threesig) cycle
13090 c             llicz=llicz+1
13091 c             lllicz=lllicz+1
13092              aux = sigmaCACA*(dijCACA-dk)
13093              expCACA = mygauss(aux)
13094 c             if (expcaca.eq.0.0d0) cycle
13095              Pcalc(k) = Pcalc(k)+expCACA
13096              CACAgrad = -sigmaCACA*mygaussder(aux)
13097 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13098              do l=1,3
13099                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13100                PgradC(k,l,i) = PgradC(k,l,i)-aux
13101                PgradC(k,l,j) = PgradC(k,l,j)+aux
13102              enddo ! l
13103            enddo ! k
13104 c           write (iout,*) "i",i," j",j," llicz",llicz
13105 #else
13106            IF (saxs_cutoff.eq.0) THEN
13107            do k=1,nsaxs
13108              dk = distsaxs(k)
13109              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13110              Pcalc(k) = Pcalc(k)+expCACA
13111              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13112              do l=1,3
13113                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13114                PgradC(k,l,i) = PgradC(k,l,i)-aux
13115                PgradC(k,l,j) = PgradC(k,l,j)+aux
13116              enddo ! l
13117            enddo ! k
13118            ELSE
13119            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13120            do k=1,nsaxs
13121              dk = distsaxs(k)
13122 c             write (2,*) "ijk",i,j,k
13123              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13124              if (sss2.eq.0.0d0) cycle
13125              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13126              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13127      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13128      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13129      &           sss2,ssgrad2
13130              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13131              Pcalc(k) = Pcalc(k)+expCACA
13132 #ifdef DEBUG
13133              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13134 #endif
13135              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13136      &             ssgrad2*expCACA/sss2
13137              do l=1,3
13138 c CA CA
13139                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13140                PgradC(k,l,i) = PgradC(k,l,i)+aux
13141                PgradC(k,l,j) = PgradC(k,l,j)-aux
13142              enddo ! l
13143            enddo ! k
13144            ENDIF
13145 #endif
13146 #endif
13147          enddo ! j
13148        enddo ! iint
13149       enddo ! i
13150 c#ifdef TIMING
13151 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13152 c#endif
13153 c      write (iout,*) "lllicz",lllicz
13154 c#ifdef TIMING
13155 c      time01=MPI_Wtime()
13156 c#endif
13157 #ifdef MPI
13158       if (nfgtasks.gt.1) then
13159        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13160      &    MPI_SUM,FG_COMM,IERR)
13161 c        if (fg_rank.eq.king) then
13162           do k=1,nsaxs
13163             Pcalc(k) = Pcalc_(k)
13164           enddo
13165 c        endif
13166 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13167 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13168 c        if (fg_rank.eq.king) then
13169 c          do i=1,nres
13170 c            do l=1,3
13171 c              do k=1,nsaxs
13172 c                PgradC(k,l,i) = PgradC_(k,l,i)
13173 c              enddo
13174 c            enddo
13175 c          enddo
13176 c        endif
13177 #ifdef ALLSAXS
13178 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13179 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13180 c        if (fg_rank.eq.king) then
13181 c          do i=1,nres
13182 c            do l=1,3
13183 c              do k=1,nsaxs
13184 c                PgradX(k,l,i) = PgradX_(k,l,i)
13185 c              enddo
13186 c            enddo
13187 c          enddo
13188 c        endif
13189 #endif
13190       endif
13191 #endif
13192       Cnorm = 0.0d0
13193       do k=1,nsaxs
13194         Cnorm = Cnorm + Pcalc(k)
13195       enddo
13196 #ifdef MPI
13197       if (fg_rank.eq.king) then
13198 #endif
13199       Esaxs_constr = dlog(Cnorm)-wsaxs0
13200       do k=1,nsaxs
13201         if (Pcalc(k).gt.0.0d0)
13202      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13203 #ifdef DEBUG
13204         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13205 #endif
13206       enddo
13207 #ifdef DEBUG
13208       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13209 #endif
13210 #ifdef MPI
13211       endif
13212 #endif
13213       gsaxsC=0.0d0
13214       gsaxsX=0.0d0
13215       do i=nnt,nct
13216         do l=1,3
13217           auxC=0.0d0
13218           auxC1=0.0d0
13219           auxX=0.0d0
13220           auxX1=0.d0
13221           do k=1,nsaxs
13222             if (Pcalc(k).gt.0)
13223      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13224             auxC1 = auxC1+PgradC(k,l,i)
13225 #ifdef ALLSAXS
13226             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13227             auxX1 = auxX1+PgradX(k,l,i)
13228 #endif
13229           enddo
13230           gsaxsC(l,i) = auxC - auxC1/Cnorm
13231 #ifdef ALLSAXS
13232           gsaxsX(l,i) = auxX - auxX1/Cnorm
13233 #endif
13234 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13235 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13236 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13237 c     *     " gradX",wsaxs*gsaxsX(l,i)
13238         enddo
13239       enddo
13240 #ifdef TIMING
13241       time_SAXS=time_SAXS+MPI_Wtime()-time01
13242 #endif
13243 #ifdef DEBUG
13244       write (iout,*) "gsaxsc"
13245       do i=nnt,nct
13246         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13247       enddo
13248 #endif
13249 #ifdef MPI
13250 c      endif
13251 #endif
13252       return
13253       end
13254 c----------------------------------------------------------------------------
13255       subroutine e_saxsC(Esaxs_constr)
13256       implicit none
13257       include 'DIMENSIONS'
13258 #ifdef MPI
13259       include "mpif.h"
13260       include "COMMON.SETUP"
13261       integer IERR
13262 #endif
13263       include 'COMMON.SBRIDGE'
13264       include 'COMMON.CHAIN'
13265       include 'COMMON.GEO'
13266       include 'COMMON.DERIV'
13267       include 'COMMON.LOCAL'
13268       include 'COMMON.INTERACT'
13269       include 'COMMON.VAR'
13270       include 'COMMON.IOUNITS'
13271 c      include 'COMMON.MD'
13272 #ifdef LANG0
13273 #ifdef FIVEDIAG
13274       include 'COMMON.LANGEVIN.lang0.5diag'
13275 #else
13276       include 'COMMON.LANGEVIN.lang0'
13277 #endif
13278 #else
13279       include 'COMMON.LANGEVIN'
13280 #endif
13281       include 'COMMON.CONTROL'
13282       include 'COMMON.SAXS'
13283       include 'COMMON.NAMES'
13284       include 'COMMON.TIME1'
13285       include 'COMMON.FFIELD'
13286 c
13287       double precision Esaxs_constr
13288       integer i,iint,j,k,l
13289       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13290 #ifdef MPI
13291       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13292 #endif
13293       double precision dk,dijCASPH,dijSCSPH,
13294      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13295      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13296      & auxX,auxX1,Cnorm
13297 c  SAXS restraint penalty function
13298 #ifdef DEBUG
13299       write(iout,*) "------- SAXS penalty function start -------"
13300       write (iout,*) "nsaxs",nsaxs
13301
13302       do i=nnt,nct
13303         print *,MyRank,"C",i,(C(j,i),j=1,3)
13304       enddo
13305       do i=nnt,nct
13306         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13307       enddo
13308 #endif
13309       Esaxs_constr = 0.0d0
13310       logPtot=0.0d0
13311       do j=isaxs_start,isaxs_end
13312         Pcalc=0.0d0
13313         do i=1,nres
13314           do l=1,3
13315             PgradC(l,i)=0.0d0
13316             PgradX(l,i)=0.0d0
13317           enddo
13318         enddo
13319         do i=nnt,nct
13320           if (itype(i).eq.ntyp1) cycle
13321           dijCASPH=0.0d0
13322           dijSCSPH=0.0d0
13323           do l=1,3
13324             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13325           enddo
13326           if (itype(i).ne.10) then
13327           do l=1,3
13328             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13329           enddo
13330           endif
13331           sigma2CA=2.0d0/pstok**2
13332           sigma2SC=4.0d0/restok(itype(i))**2
13333           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13334           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13335           Pcalc = Pcalc+expCASPH+expSCSPH
13336 #ifdef DEBUG
13337           write(*,*) "processor i j Pcalc",
13338      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13339 #endif
13340           CASPHgrad = sigma2CA*expCASPH
13341           SCSPHgrad = sigma2SC*expSCSPH
13342           do l=1,3
13343             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13344             PgradX(l,i) = PgradX(l,i) + aux
13345             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13346           enddo ! l
13347         enddo ! i
13348         do i=nnt,nct
13349           do l=1,3
13350             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13351             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13352           enddo
13353         enddo
13354         logPtot = logPtot - dlog(Pcalc)
13355 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13356 c     &    " logPtot",logPtot
13357       enddo ! j
13358 #ifdef MPI
13359       if (nfgtasks.gt.1) then
13360 c        write (iout,*) "logPtot before reduction",logPtot
13361         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13362      &    MPI_SUM,king,FG_COMM,IERR)
13363         logPtot = logPtot_
13364 c        write (iout,*) "logPtot after reduction",logPtot
13365         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13366      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13367         if (fg_rank.eq.king) then
13368           do i=1,nres
13369             do l=1,3
13370               gsaxsC(l,i) = gsaxsC_(l,i)
13371             enddo
13372           enddo
13373         endif
13374         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13375      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13376         if (fg_rank.eq.king) then
13377           do i=1,nres
13378             do l=1,3
13379               gsaxsX(l,i) = gsaxsX_(l,i)
13380             enddo
13381           enddo
13382         endif
13383       endif
13384 #endif
13385       Esaxs_constr = logPtot
13386       return
13387       end
13388 c----------------------------------------------------------------------------
13389       double precision function sscale2(r,r_cut,r0,rlamb)
13390       implicit none
13391       double precision r,gamm,r_cut,r0,rlamb,rr
13392       rr = dabs(r-r0)
13393 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13394 c      write (2,*) "rr",rr
13395       if(rr.lt.r_cut-rlamb) then
13396         sscale2=1.0d0
13397       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13398         gamm=(rr-(r_cut-rlamb))/rlamb
13399         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13400       else
13401         sscale2=0d0
13402       endif
13403       return
13404       end
13405 C-----------------------------------------------------------------------
13406       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13407       implicit none
13408       double precision r,gamm,r_cut,r0,rlamb,rr
13409       rr = dabs(r-r0)
13410       if(rr.lt.r_cut-rlamb) then
13411         sscalgrad2=0.0d0
13412       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13413         gamm=(rr-(r_cut-rlamb))/rlamb
13414         if (r.ge.r0) then
13415           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13416         else
13417           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13418         endif
13419       else
13420         sscalgrad2=0.0d0
13421       endif
13422       return
13423       end