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 #ifdef FOURBODY
 328 C      print *,"PRZED MULIt"
 329 c      print *,"Processor",myrank," computed Usccorr"
 330 C
 331 C 12/1/95 Multi-body terms
 332 C
 333       n_corr=0
 334       n_corr1=0
 335       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 336      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 337          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 338 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 339 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 340 c        call flush(iout)
 341       else
 342          ecorr=0.0d0
 343          ecorr5=0.0d0
 344          ecorr6=0.0d0
 345          eturn6=0.0d0
 346       endif
 347       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 348 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 349 c     &     n_corr,n_corr1
 350 c         call flush(iout)
 351          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 352 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 353 c     &     n_corr1
 354 c         call flush(iout)
 355       endif
 356 #endif
 357 c      print *,"Processor",myrank," computed Ucorr"
 358 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 359       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 360         call e_saxs(Esaxs_constr)
 361 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 362       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 363         call e_saxsC(Esaxs_constr)
 364 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 365       else
 366         Esaxs_constr = 0.0d0
 367       endif
 368 C
 369 C If performing constraint dynamics, call the constraint energy
 370 C  after the equilibration time
 371 c      if(usampl.and.totT.gt.eq_time) then
 372 c      write (iout,*) "usampl",usampl
 373       if(usampl) then
 374          call EconstrQ
 375          if (loc_qlike) then
 376            call Econstr_back_qlike
 377          else
 378            call Econstr_back
 379          endif
 380       else
 381          Uconst=0.0d0
 382          Uconst_back=0.0d0
 383       endif
 384 C 01/27/2015 added by adasko
 385 C the energy component below is energy transfer into lipid environment
 386 C based on partition function
 387 C      print *,"przed lipidami"
 388       if (wliptran.gt.0) then
 389         call Eliptransfer(eliptran)
 390       endif
 391 C      print *,"za lipidami"
 392       if (AFMlog.gt.0) then
 393         call AFMforce(Eafmforce)
 394       else if (selfguide.gt.0) then
 395         call AFMvel(Eafmforce)
 396       endif
 397       if (TUBElog.eq.1) then
 398 C      print *,"just before call"
 399         call calctube(Etube)
 400        elseif (TUBElog.eq.2) then
 401         call calctube2(Etube)
 402        else
 403        Etube=0.0d0
 404        endif
 405
 406 #ifdef TIMING
 407       time_enecalc=time_enecalc+MPI_Wtime()-time00
 408 #endif
 409 c      print *,"Processor",myrank," computed Uconstr"
 410 #ifdef TIMING
 411       time00=MPI_Wtime()
 412 #endif
 413 c
 414 C Sum the energies
 415 C
 416       energia(1)=evdw
 417 #ifdef SCP14
 418       energia(2)=evdw2-evdw2_14
 419       energia(18)=evdw2_14
 420 #else
 421       energia(2)=evdw2
 422       energia(18)=0.0d0
 423 #endif
 424 #ifdef SPLITELE
 425       energia(3)=ees
 426       energia(16)=evdw1
 427 #else
 428       energia(3)=ees+evdw1
 429       energia(16)=0.0d0
 430 #endif
 431       energia(4)=ecorr
 432       energia(5)=ecorr5
 433       energia(6)=ecorr6
 434       energia(7)=eel_loc
 435       energia(8)=eello_turn3
 436       energia(9)=eello_turn4
 437       energia(10)=eturn6
 438       energia(11)=ebe
 439       energia(12)=escloc
 440       energia(13)=etors
 441       energia(14)=etors_d
 442       energia(15)=ehpb
 443       energia(19)=edihcnstr
 444       energia(17)=estr
 445       energia(20)=Uconst+Uconst_back
 446       energia(21)=esccor
 447       energia(22)=eliptran
 448       energia(23)=Eafmforce
 449       energia(24)=ethetacnstr
 450       energia(25)=Etube
 451       energia(26)=Esaxs_constr
 452       energia(27)=ehomology_constr
 453       energia(28)=edfadis
 454       energia(29)=edfator
 455       energia(30)=edfanei
 456       energia(31)=edfabet
 457 c      write (iout,*) "esaxs_constr",energia(26)
 458 c    Here are the energies showed per procesor if the are more processors
 459 c    per molecule then we sum it up in sum_energy subroutine
 460 c      print *," Processor",myrank," calls SUM_ENERGY"
 461       call sum_energy(energia,.true.)
 462 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 463       if (dyn_ss) call dyn_set_nss
 464 c      print *," Processor",myrank," left SUM_ENERGY"
 465 #ifdef TIMING
 466       time_sumene=time_sumene+MPI_Wtime()-time00
 467 #endif
 468       return
 469       end
 470 c-------------------------------------------------------------------------------
 471       subroutine sum_energy(energia,reduce)
 472       implicit none
 473       include 'DIMENSIONS'
 474 #ifndef ISNAN
 475       external proc_proc
 476 #ifdef WINPGI
 477 cMS$ATTRIBUTES C ::  proc_proc
 478 #endif
 479 #endif
 480 #ifdef MPI
 481       include "mpif.h"
 482       integer ierr
 483       double precision time00
 484 #endif
 485       include 'COMMON.SETUP'
 486       include 'COMMON.IOUNITS'
 487       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 488       include 'COMMON.FFIELD'
 489       include 'COMMON.DERIV'
 490       include 'COMMON.INTERACT'
 491       include 'COMMON.SBRIDGE'
 492       include 'COMMON.CHAIN'
 493       include 'COMMON.VAR'
 494       include 'COMMON.CONTROL'
 495       include 'COMMON.TIME1'
 496       logical reduce
 497       integer i
 498       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 499      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 500      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 501      & eliptran,Eafmforce,Etube,
 502      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 503       double precision Uconst,etot
 504 #ifdef MPI
 505       if (nfgtasks.gt.1 .and. reduce) then
 506 #ifdef DEBUG
 507         write (iout,*) "energies before REDUCE"
 508         call enerprint(energia)
 509         call flush(iout)
 510 #endif
 511         do i=0,n_ene
 512           enebuff(i)=energia(i)
 513         enddo
 514         time00=MPI_Wtime()
 515         call MPI_Barrier(FG_COMM,IERR)
 516         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 517         time00=MPI_Wtime()
 518         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 519      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 520 #ifdef DEBUG
 521         write (iout,*) "energies after REDUCE"
 522         call enerprint(energia)
 523         call flush(iout)
 524 #endif
 525         time_Reduce=time_Reduce+MPI_Wtime()-time00
 526       endif
 527       if (fg_rank.eq.0) then
 528 #endif
 529       evdw=energia(1)
 530 #ifdef SCP14
 531       evdw2=energia(2)+energia(18)
 532       evdw2_14=energia(18)
 533 #else
 534       evdw2=energia(2)
 535 #endif
 536 #ifdef SPLITELE
 537       ees=energia(3)
 538       evdw1=energia(16)
 539 #else
 540       ees=energia(3)
 541       evdw1=0.0d0
 542 #endif
 543       ecorr=energia(4)
 544       ecorr5=energia(5)
 545       ecorr6=energia(6)
 546       eel_loc=energia(7)
 547       eello_turn3=energia(8)
 548       eello_turn4=energia(9)
 549       eturn6=energia(10)
 550       ebe=energia(11)
 551       escloc=energia(12)
 552       etors=energia(13)
 553       etors_d=energia(14)
 554       ehpb=energia(15)
 555       edihcnstr=energia(19)
 556       estr=energia(17)
 557       Uconst=energia(20)
 558       esccor=energia(21)
 559       eliptran=energia(22)
 560       Eafmforce=energia(23)
 561       ethetacnstr=energia(24)
 562       Etube=energia(25)
 563       esaxs_constr=energia(26)
 564       ehomology_constr=energia(27)
 565       edfadis=energia(28)
 566       edfator=energia(29)
 567       edfanei=energia(30)
 568       edfabet=energia(31)
 569 #ifdef SPLITELE
 570       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 571      & +wang*ebe+wtor*etors+wscloc*escloc
 572      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 573      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 574      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 575      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 576      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 577      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 578      & +wdfa_beta*edfabet
 579 #else
 580       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 581      & +wang*ebe+wtor*etors+wscloc*escloc
 582      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 583      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 584      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 585      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 586      & +Eafmforce
 587      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 588      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 589      & +wdfa_beta*edfabet
 590 #endif
 591       energia(0)=etot
 592 c detecting NaNQ
 593 #ifdef ISNAN
 594 #ifdef AIX
 595       if (isnan(etot).ne.0) energia(0)=1.0d+99
 596 #else
 597       if (isnan(etot)) energia(0)=1.0d+99
 598 #endif
 599 #else
 600       i=0
 601 #ifdef WINPGI
 602       idumm=proc_proc(etot,i)
 603 #else
 604       call proc_proc(etot,i)
 605 #endif
 606       if(i.eq.1)energia(0)=1.0d+99
 607 #endif
 608 #ifdef MPI
 609       endif
 610 #endif
 611       return
 612       end
 613 c-------------------------------------------------------------------------------
 614       subroutine sum_gradient
 615       implicit none
 616       include 'DIMENSIONS'
 617 #ifndef ISNAN
 618       external proc_proc
 619 #ifdef WINPGI
 620 cMS$ATTRIBUTES C ::  proc_proc
 621 #endif
 622 #endif
 623 #ifdef MPI
 624       include 'mpif.h'
 625       integer ierror,ierr
 626       double precision time00,time01
 627 #endif
 628       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 629      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 630      & ,gloc_scbuf(3,-1:maxres)
 631       include 'COMMON.SETUP'
 632       include 'COMMON.IOUNITS'
 633       include 'COMMON.FFIELD'
 634       include 'COMMON.DERIV'
 635       include 'COMMON.INTERACT'
 636       include 'COMMON.SBRIDGE'
 637       include 'COMMON.CHAIN'
 638       include 'COMMON.VAR'
 639       include 'COMMON.CONTROL'
 640       include 'COMMON.TIME1'
 641       include 'COMMON.MAXGRAD'
 642       include 'COMMON.SCCOR'
 643 c      include 'COMMON.MD'
 644       include 'COMMON.QRESTR'
 645       integer i,j,k
 646       double precision scalar
 647       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 648      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 649      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 650      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 651      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 652      &gsclocx_norm
 653 #ifdef TIMING
 654       time01=MPI_Wtime()
 655 #endif
 656 #ifdef DEBUG
 657       write (iout,*) "sum_gradient gvdwc, gvdwx"
 658       do i=1,nres
 659         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 660      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 661       enddo
 662       call flush(iout)
 663 #endif
 664 #ifdef DEBUG
 665       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 666       do i=0,nres
 667         write (iout,'(i3,3e15.5,5x,3e15.5)')
 668      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 669       enddo
 670       call flush(iout)
 671 #endif
 672 #ifdef MPI
 673 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 674         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 675      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 676 #endif
 677 C
 678 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 679 C            in virtual-bond-vector coordinates
 680 C
 681 #ifdef DEBUG
 682 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 683 c      do i=1,nres-1
 684 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 685 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 686 c      enddo
 687 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 688 c      do i=1,nres-1
 689 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 690 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 691 c      enddo
 692       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 693       do i=1,nres
 694         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 695      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 696      &   g_corr5_loc(i)
 697       enddo
 698       call flush(iout)
 699 #endif
 700 #ifdef DEBUG
 701       write (iout,*) "gsaxsc"
 702       do i=1,nres
 703         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 704       enddo
 705       call flush(iout)
 706 #endif
 707 #ifdef SPLITELE
 708       do i=0,nct
 709         do j=1,3
 710           gradbufc(j,i)=wsc*gvdwc(j,i)+
 711      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 712      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 713      &                wel_loc*gel_loc_long(j,i)+
 714      &                wcorr*gradcorr_long(j,i)+
 715      &                wcorr5*gradcorr5_long(j,i)+
 716      &                wcorr6*gradcorr6_long(j,i)+
 717      &                wturn6*gcorr6_turn_long(j,i)+
 718      &                wstrain*ghpbc(j,i)
 719      &                +wliptran*gliptranc(j,i)
 720      &                +gradafm(j,i)
 721      &                +welec*gshieldc(j,i)
 722      &                +wcorr*gshieldc_ec(j,i)
 723      &                +wturn3*gshieldc_t3(j,i)
 724      &                +wturn4*gshieldc_t4(j,i)
 725      &                +wel_loc*gshieldc_ll(j,i)
 726      &                +wtube*gg_tube(j,i)
 727      &                +wsaxs*gsaxsc(j,i)
 728         enddo
 729       enddo
 730 #else
 731       do i=0,nct
 732         do j=1,3
 733           gradbufc(j,i)=wsc*gvdwc(j,i)+
 734      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 735      &                welec*gelc_long(j,i)+
 736      &                wbond*gradb(j,i)+
 737      &                wel_loc*gel_loc_long(j,i)+
 738      &                wcorr*gradcorr_long(j,i)+
 739      &                wcorr5*gradcorr5_long(j,i)+
 740      &                wcorr6*gradcorr6_long(j,i)+
 741      &                wturn6*gcorr6_turn_long(j,i)+
 742      &                wstrain*ghpbc(j,i)
 743      &                +wliptran*gliptranc(j,i)
 744      &                +gradafm(j,i)
 745      &                 +welec*gshieldc(j,i)
 746      &                 +wcorr*gshieldc_ec(j,i)
 747      &                 +wturn4*gshieldc_t4(j,i)
 748      &                 +wel_loc*gshieldc_ll(j,i)
 749      &                +wtube*gg_tube(j,i)
 750      &                +wsaxs*gsaxsc(j,i)
 751         enddo
 752       enddo
 753 #endif
 754       do i=1,nct
 755         do j=1,3
 756           gradbufc(j,i)=gradbufc(j,i)+
 757      &                wdfa_dist*gdfad(j,i)+
 758      &                wdfa_tor*gdfat(j,i)+
 759      &                wdfa_nei*gdfan(j,i)+
 760      &                wdfa_beta*gdfab(j,i)
 761         enddo
 762       enddo
 763 #ifdef DEBUG
 764       write (iout,*) "gradc from gradbufc"
 765       do i=1,nres
 766         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 767       enddo
 768       call flush(iout)
 769 #endif
 770 #ifdef MPI
 771       if (nfgtasks.gt.1) then
 772       time00=MPI_Wtime()
 773 #ifdef DEBUG
 774       write (iout,*) "gradbufc before allreduce"
 775       do i=1,nres
 776         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 777       enddo
 778       call flush(iout)
 779 #endif
 780       do i=0,nres
 781         do j=1,3
 782           gradbufc_sum(j,i)=gradbufc(j,i)
 783         enddo
 784       enddo
 785 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 786 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 787 c      time_reduce=time_reduce+MPI_Wtime()-time00
 788 #ifdef DEBUG
 789 c      write (iout,*) "gradbufc_sum after allreduce"
 790 c      do i=1,nres
 791 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 792 c      enddo
 793 c      call flush(iout)
 794 #endif
 795 #ifdef TIMING
 796 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 797 #endif
 798       do i=nnt,nres
 799         do k=1,3
 800           gradbufc(k,i)=0.0d0
 801         enddo
 802       enddo
 803 #ifdef DEBUG
 804       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 805       write (iout,*) (i," jgrad_start",jgrad_start(i),
 806      &                  " jgrad_end  ",jgrad_end(i),
 807      &                  i=igrad_start,igrad_end)
 808 #endif
 809 c
 810 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 811 c do not parallelize this part.
 812 c
 813 c      do i=igrad_start,igrad_end
 814 c        do j=jgrad_start(i),jgrad_end(i)
 815 c          do k=1,3
 816 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 817 c          enddo
 818 c        enddo
 819 c      enddo
 820       do j=1,3
 821         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 822       enddo
 823       do i=nres-2,-1,-1
 824         do j=1,3
 825           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 826         enddo
 827       enddo
 828 #ifdef DEBUG
 829       write (iout,*) "gradbufc after summing"
 830       do i=1,nres
 831         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 832       enddo
 833       call flush(iout)
 834 #endif
 835       else
 836 #endif
 837 #ifdef DEBUG
 838       write (iout,*) "gradbufc"
 839       do i=1,nres
 840         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 841       enddo
 842       call flush(iout)
 843 #endif
 844       do i=-1,nres
 845         do j=1,3
 846           gradbufc_sum(j,i)=gradbufc(j,i)
 847           gradbufc(j,i)=0.0d0
 848         enddo
 849       enddo
 850       do j=1,3
 851         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 852       enddo
 853       do i=nres-2,-1,-1
 854         do j=1,3
 855           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 856         enddo
 857       enddo
 858 c      do i=nnt,nres-1
 859 c        do k=1,3
 860 c          gradbufc(k,i)=0.0d0
 861 c        enddo
 862 c        do j=i+1,nres
 863 c          do k=1,3
 864 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 865 c          enddo
 866 c        enddo
 867 c      enddo
 868 #ifdef DEBUG
 869       write (iout,*) "gradbufc after summing"
 870       do i=1,nres
 871         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 872       enddo
 873       call flush(iout)
 874 #endif
 875 #ifdef MPI
 876       endif
 877 #endif
 878       do k=1,3
 879         gradbufc(k,nres)=0.0d0
 880       enddo
 881       do i=-1,nct
 882         do j=1,3
 883 #ifdef SPLITELE
 884 C          print *,gradbufc(1,13)
 885 C          print *,welec*gelc(1,13)
 886 C          print *,wel_loc*gel_loc(1,13)
 887 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 888 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 889 C          print *,wel_loc*gel_loc_long(1,13)
 890 C          print *,gradafm(1,13),"AFM"
 891           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 892      &                wel_loc*gel_loc(j,i)+
 893      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 894      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 895      &                wel_loc*gel_loc_long(j,i)+
 896      &                wcorr*gradcorr_long(j,i)+
 897      &                wcorr5*gradcorr5_long(j,i)+
 898      &                wcorr6*gradcorr6_long(j,i)+
 899      &                wturn6*gcorr6_turn_long(j,i))+
 900      &                wbond*gradb(j,i)+
 901      &                wcorr*gradcorr(j,i)+
 902      &                wturn3*gcorr3_turn(j,i)+
 903      &                wturn4*gcorr4_turn(j,i)+
 904      &                wcorr5*gradcorr5(j,i)+
 905      &                wcorr6*gradcorr6(j,i)+
 906      &                wturn6*gcorr6_turn(j,i)+
 907      &                wsccor*gsccorc(j,i)
 908      &               +wscloc*gscloc(j,i)
 909      &               +wliptran*gliptranc(j,i)
 910      &                +gradafm(j,i)
 911      &                 +welec*gshieldc(j,i)
 912      &                 +welec*gshieldc_loc(j,i)
 913      &                 +wcorr*gshieldc_ec(j,i)
 914      &                 +wcorr*gshieldc_loc_ec(j,i)
 915      &                 +wturn3*gshieldc_t3(j,i)
 916      &                 +wturn3*gshieldc_loc_t3(j,i)
 917      &                 +wturn4*gshieldc_t4(j,i)
 918      &                 +wturn4*gshieldc_loc_t4(j,i)
 919      &                 +wel_loc*gshieldc_ll(j,i)
 920      &                 +wel_loc*gshieldc_loc_ll(j,i)
 921      &                +wtube*gg_tube(j,i)
 922
 923 #else
 924           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 925      &                wel_loc*gel_loc(j,i)+
 926      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 927      &                welec*gelc_long(j,i)+
 928      &                wel_loc*gel_loc_long(j,i)+
 929      &                wcorr*gcorr_long(j,i)+
 930      &                wcorr5*gradcorr5_long(j,i)+
 931      &                wcorr6*gradcorr6_long(j,i)+
 932      &                wturn6*gcorr6_turn_long(j,i))+
 933      &                wbond*gradb(j,i)+
 934      &                wcorr*gradcorr(j,i)+
 935      &                wturn3*gcorr3_turn(j,i)+
 936      &                wturn4*gcorr4_turn(j,i)+
 937      &                wcorr5*gradcorr5(j,i)+
 938      &                wcorr6*gradcorr6(j,i)+
 939      &                wturn6*gcorr6_turn(j,i)+
 940      &                wsccor*gsccorc(j,i)
 941      &               +wscloc*gscloc(j,i)
 942      &               +wliptran*gliptranc(j,i)
 943      &                +gradafm(j,i)
 944      &                 +welec*gshieldc(j,i)
 945      &                 +welec*gshieldc_loc(j,i)
 946      &                 +wcorr*gshieldc_ec(j,i)
 947      &                 +wcorr*gshieldc_loc_ec(j,i)
 948      &                 +wturn3*gshieldc_t3(j,i)
 949      &                 +wturn3*gshieldc_loc_t3(j,i)
 950      &                 +wturn4*gshieldc_t4(j,i)
 951      &                 +wturn4*gshieldc_loc_t4(j,i)
 952      &                 +wel_loc*gshieldc_ll(j,i)
 953      &                 +wel_loc*gshieldc_loc_ll(j,i)
 954      &                +wtube*gg_tube(j,i)
 955
 956
 957 #endif
 958           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 959      &                  wbond*gradbx(j,i)+
 960      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 961      &                  wsccor*gsccorx(j,i)
 962      &                 +wscloc*gsclocx(j,i)
 963      &                 +wliptran*gliptranx(j,i)
 964      &                 +welec*gshieldx(j,i)
 965      &                 +wcorr*gshieldx_ec(j,i)
 966      &                 +wturn3*gshieldx_t3(j,i)
 967      &                 +wturn4*gshieldx_t4(j,i)
 968      &                 +wel_loc*gshieldx_ll(j,i)
 969      &                 +wtube*gg_tube_sc(j,i)
 970      &                 +wsaxs*gsaxsx(j,i)
 971
 972
 973
 974         enddo
 975       enddo
 976       if (constr_homology.gt.0) then
 977         do i=1,nct
 978           do j=1,3
 979             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 980             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 981           enddo
 982         enddo
 983       endif
 984 #ifdef DEBUG
 985       write (iout,*) "gradc gradx gloc after adding"
 986       do i=1,nres
 987         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 988      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 989       enddo
 990 #endif
 991 #ifdef DEBUG
 992       write (iout,*) "gloc before adding corr"
 993       do i=1,4*nres
 994         write (iout,*) i,gloc(i,icg)
 995       enddo
 996 #endif
 997       do i=1,nres-3
 998         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 999      &   +wcorr5*g_corr5_loc(i)
1000      &   +wcorr6*g_corr6_loc(i)
1001      &   +wturn4*gel_loc_turn4(i)
1002      &   +wturn3*gel_loc_turn3(i)
1003      &   +wturn6*gel_loc_turn6(i)
1004      &   +wel_loc*gel_loc_loc(i)
1005       enddo
1006 #ifdef DEBUG
1007       write (iout,*) "gloc after adding corr"
1008       do i=1,4*nres
1009         write (iout,*) i,gloc(i,icg)
1010       enddo
1011 #endif
1012 #ifdef MPI
1013       if (nfgtasks.gt.1) then
1014         do j=1,3
1015           do i=1,nres
1016             gradbufc(j,i)=gradc(j,i,icg)
1017             gradbufx(j,i)=gradx(j,i,icg)
1018           enddo
1019         enddo
1020         do i=1,4*nres
1021           glocbuf(i)=gloc(i,icg)
1022         enddo
1023 c#define DEBUG
1024 #ifdef DEBUG
1025       write (iout,*) "gloc_sc before reduce"
1026       do i=1,nres
1027        do j=1,1
1028         write (iout,*) i,j,gloc_sc(j,i,icg)
1029        enddo
1030       enddo
1031 #endif
1032 c#undef DEBUG
1033         do i=1,nres
1034          do j=1,3
1035           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1036          enddo
1037         enddo
1038         time00=MPI_Wtime()
1039         call MPI_Barrier(FG_COMM,IERR)
1040         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1041         time00=MPI_Wtime()
1042         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1043      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1044         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1045      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1046         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1047      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1048         time_reduce=time_reduce+MPI_Wtime()-time00
1049         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1050      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1051         time_reduce=time_reduce+MPI_Wtime()-time00
1052 #ifdef DEBUG
1053       write (iout,*) "gradc after reduce"
1054       do i=1,nres
1055        do j=1,3
1056         write (iout,*) i,j,gradc(j,i,icg)
1057        enddo
1058       enddo
1059 #endif
1060 #ifdef DEBUG
1061       write (iout,*) "gloc_sc after reduce"
1062       do i=1,nres
1063        do j=1,1
1064         write (iout,*) i,j,gloc_sc(j,i,icg)
1065        enddo
1066       enddo
1067 #endif
1068 #ifdef DEBUG
1069       write (iout,*) "gloc after reduce"
1070       do i=1,4*nres
1071         write (iout,*) i,gloc(i,icg)
1072       enddo
1073 #endif
1074       endif
1075 #endif
1076       if (gnorm_check) then
1077 c
1078 c Compute the maximum elements of the gradient
1079 c
1080       gvdwc_max=0.0d0
1081       gvdwc_scp_max=0.0d0
1082       gelc_max=0.0d0
1083       gvdwpp_max=0.0d0
1084       gradb_max=0.0d0
1085       ghpbc_max=0.0d0
1086       gradcorr_max=0.0d0
1087       gel_loc_max=0.0d0
1088       gcorr3_turn_max=0.0d0
1089       gcorr4_turn_max=0.0d0
1090       gradcorr5_max=0.0d0
1091       gradcorr6_max=0.0d0
1092       gcorr6_turn_max=0.0d0
1093       gsccorrc_max=0.0d0
1094       gscloc_max=0.0d0
1095       gvdwx_max=0.0d0
1096       gradx_scp_max=0.0d0
1097       ghpbx_max=0.0d0
1098       gradxorr_max=0.0d0
1099       gsccorrx_max=0.0d0
1100       gsclocx_max=0.0d0
1101       do i=1,nct
1102         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1103         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1104         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1105         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1106      &   gvdwc_scp_max=gvdwc_scp_norm
1107         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1108         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1109         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1110         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1111         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1112         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1113         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1114         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1115         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1116         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1117         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1118         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1119         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1120      &    gcorr3_turn(1,i)))
1121         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1122      &    gcorr3_turn_max=gcorr3_turn_norm
1123         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1124      &    gcorr4_turn(1,i)))
1125         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1126      &    gcorr4_turn_max=gcorr4_turn_norm
1127         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1128         if (gradcorr5_norm.gt.gradcorr5_max)
1129      &    gradcorr5_max=gradcorr5_norm
1130         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1131         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1132         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1133      &    gcorr6_turn(1,i)))
1134         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1135      &    gcorr6_turn_max=gcorr6_turn_norm
1136         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1137         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1138         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1139         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1140         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1141         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1142         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1143         if (gradx_scp_norm.gt.gradx_scp_max)
1144      &    gradx_scp_max=gradx_scp_norm
1145         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1146         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1147         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1148         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1149         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1150         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1151         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1152         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1153       enddo
1154       if (gradout) then
1155 #if (defined AIX || defined CRAY)
1156         open(istat,file=statname,position="append")
1157 #else
1158         open(istat,file=statname,access="append")
1159 #endif
1160         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1161      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1162      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1163      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1164      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1165      &     gsccorrx_max,gsclocx_max
1166         close(istat)
1167         if (gvdwc_max.gt.1.0d4) then
1168           write (iout,*) "gvdwc gvdwx gradb gradbx"
1169           do i=nnt,nct
1170             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1171      &        gradb(j,i),gradbx(j,i),j=1,3)
1172           enddo
1173           call pdbout(0.0d0,'cipiszcze',iout)
1174           call flush(iout)
1175         endif
1176       endif
1177       endif
1178 #ifdef DEBUG
1179       write (iout,*) "gradc gradx gloc"
1180       do i=1,nres
1181         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1182      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1183       enddo
1184 #endif
1185 #ifdef TIMING
1186       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1187 #endif
1188       return
1189       end
1190 c-------------------------------------------------------------------------------
1191       subroutine rescale_weights(t_bath)
1192       implicit none
1193 #ifdef MPI
1194       include 'mpif.h'
1195       integer ierror
1196 #endif
1197       include 'DIMENSIONS'
1198       include 'COMMON.IOUNITS'
1199       include 'COMMON.FFIELD'
1200       include 'COMMON.SBRIDGE'
1201       include 'COMMON.CONTROL'
1202       double precision t_bath
1203       double precision facT,facT2,facT3,facT4,facT5
1204       double precision kfac /2.4d0/
1205       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1206 c      facT=temp0/t_bath
1207 c      facT=2*temp0/(t_bath+temp0)
1208       if (rescale_mode.eq.0) then
1209         facT=1.0d0
1210         facT2=1.0d0
1211         facT3=1.0d0
1212         facT4=1.0d0
1213         facT5=1.0d0
1214       else if (rescale_mode.eq.1) then
1215         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1216         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1217         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1218         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1219         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1220       else if (rescale_mode.eq.2) then
1221         x=t_bath/temp0
1222         x2=x*x
1223         x3=x2*x
1224         x4=x3*x
1225         x5=x4*x
1226         facT=licznik/dlog(dexp(x)+dexp(-x))
1227         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1228         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1229         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1230         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1231       else
1232         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1233         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1234 #ifdef MPI
1235        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1236 #endif
1237        stop 555
1238       endif
1239       if (shield_mode.gt.0) then
1240        wscp=weights(2)*fact
1241        wsc=weights(1)*fact
1242        wvdwpp=weights(16)*fact
1243       endif
1244       welec=weights(3)*fact
1245       wcorr=weights(4)*fact3
1246       wcorr5=weights(5)*fact4
1247       wcorr6=weights(6)*fact5
1248       wel_loc=weights(7)*fact2
1249       wturn3=weights(8)*fact2
1250       wturn4=weights(9)*fact3
1251       wturn6=weights(10)*fact5
1252       wtor=weights(13)*fact
1253       wtor_d=weights(14)*fact2
1254       wsccor=weights(21)*fact
1255       if (scale_umb) wumb=t_bath/temp0
1256 c      write (iout,*) "scale_umb",scale_umb
1257 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1258
1259       return
1260       end
1261 C------------------------------------------------------------------------
1262       subroutine enerprint(energia)
1263       implicit none
1264       include 'DIMENSIONS'
1265       include 'COMMON.IOUNITS'
1266       include 'COMMON.FFIELD'
1267       include 'COMMON.SBRIDGE'
1268       include 'COMMON.QRESTR'
1269       double precision energia(0:n_ene)
1270       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1271      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1272      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1273      & eello_turn6,
1274      & eliptran,Eafmforce,Etube,
1275      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1276       etot=energia(0)
1277       evdw=energia(1)
1278       evdw2=energia(2)
1279 #ifdef SCP14
1280       evdw2=energia(2)+energia(18)
1281 #else
1282       evdw2=energia(2)
1283 #endif
1284       ees=energia(3)
1285 #ifdef SPLITELE
1286       evdw1=energia(16)
1287 #endif
1288       ecorr=energia(4)
1289       ecorr5=energia(5)
1290       ecorr6=energia(6)
1291       eel_loc=energia(7)
1292       eello_turn3=energia(8)
1293       eello_turn4=energia(9)
1294       eello_turn6=energia(10)
1295       ebe=energia(11)
1296       escloc=energia(12)
1297       etors=energia(13)
1298       etors_d=energia(14)
1299       ehpb=energia(15)
1300       edihcnstr=energia(19)
1301       estr=energia(17)
1302       Uconst=energia(20)
1303       esccor=energia(21)
1304       eliptran=energia(22)
1305       Eafmforce=energia(23)
1306       ethetacnstr=energia(24)
1307       etube=energia(25)
1308       esaxs=energia(26)
1309       ehomology_constr=energia(27)
1310 C     Bartek
1311       edfadis = energia(28)
1312       edfator = energia(29)
1313       edfanei = energia(30)
1314       edfabet = energia(31)
1315 #ifdef SPLITELE
1316       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1317      &  estr,wbond,ebe,wang,
1318      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1319 #ifdef FOURBODY
1320      &  ecorr,wcorr,
1321      &  ecorr5,wcorr5,ecorr6,wcorr6,
1322 #endif
1323      &  eel_loc,wel_loc,eello_turn3,wturn3,
1324      &  eello_turn4,wturn4,
1325 #ifdef FOURBODY
1326      &  eello_turn6,wturn6,
1327 #endif
1328      &  esccor,wsccor,edihcnstr,
1329      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1330      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1331      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1332      &  edfabet,wdfa_beta,
1333      &  etot
1334    10 format (/'Virtual-chain energies:'//
1335      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1336      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1337      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1338      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1339      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1340      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1341      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1342      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1343      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1344      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1345      & ' (SS bridges & dist. cnstr.)'/
1346 #ifdef FOURBODY
1347      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1348      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1349      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1350 #endif
1351      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1352      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1353      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1354 #ifdef FOURBODY
1355      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1356 #endif
1357      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1358      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1359      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1360      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1361      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1362      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1363      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1364      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1365      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1366      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1367      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1368      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1369      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1370      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1371      & 'ETOT=  ',1pE16.6,' (total)')
1372
1373 #else
1374       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1375      &  estr,wbond,ebe,wang,
1376      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1377 #ifdef FOURBODY
1378      &  ecorr,wcorr,
1379      &  ecorr5,wcorr5,ecorr6,wcorr6,
1380 #endif
1381      &  eel_loc,wel_loc,eello_turn3,wturn3,
1382      &  eello_turn4,wturn4,
1383 #ifdef FOURBODY
1384      &  eello_turn6,wturn6,
1385 #endif
1386      &  esccor,wsccor,edihcnstr,
1387      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1388      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1389      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1390      &  edfabet,wdfa_beta,
1391      &  etot
1392    10 format (/'Virtual-chain energies:'//
1393      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1394      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1395      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1396      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1397      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1398      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1399      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1400      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1401      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1402      & ' (SS bridges & dist. restr.)'/
1403 #ifdef FOURBODY
1404      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1405      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1406      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1407 #endif
1408      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1409      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1410      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1411 #ifdef FOURBODY
1412      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1413 #endif
1414      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1415      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1416      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1417      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1418      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1419      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1420      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1421      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1422      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1423      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1424      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1425      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1426      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1427      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1428      & 'ETOT=  ',1pE16.6,' (total)')
1429 #endif
1430       return
1431       end
1432 C-----------------------------------------------------------------------
1433       subroutine elj(evdw)
1434 C
1435 C This subroutine calculates the interaction energy of nonbonded side chains
1436 C assuming the LJ potential of interaction.
1437 C
1438       implicit none
1439       double precision accur
1440       include 'DIMENSIONS'
1441       parameter (accur=1.0d-10)
1442       include 'COMMON.GEO'
1443       include 'COMMON.VAR'
1444       include 'COMMON.LOCAL'
1445       include 'COMMON.CHAIN'
1446       include 'COMMON.DERIV'
1447       include 'COMMON.INTERACT'
1448       include 'COMMON.TORSION'
1449       include 'COMMON.SBRIDGE'
1450       include 'COMMON.NAMES'
1451       include 'COMMON.IOUNITS'
1452 #ifdef FOURBODY
1453       include 'COMMON.CONTACTS'
1454       include 'COMMON.CONTMAT'
1455 #endif
1456       double precision gg(3)
1457       double precision evdw,evdwij
1458       integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1459       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1460      & sigij,r0ij,rcut
1461       double precision fcont,fprimcont
1462 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1463       evdw=0.0D0
1464       do i=iatsc_s,iatsc_e
1465         itypi=iabs(itype(i))
1466         if (itypi.eq.ntyp1) cycle
1467         itypi1=iabs(itype(i+1))
1468         xi=c(1,nres+i)
1469         yi=c(2,nres+i)
1470         zi=c(3,nres+i)
1471 C Change 12/1/95
1472         num_conti=0
1473 C
1474 C Calculate SC interaction energy.
1475 C
1476         do iint=1,nint_gr(i)
1477 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1478 cd   &                  'iend=',iend(i,iint)
1479           do j=istart(i,iint),iend(i,iint)
1480             itypj=iabs(itype(j))
1481             if (itypj.eq.ntyp1) cycle
1482             xj=c(1,nres+j)-xi
1483             yj=c(2,nres+j)-yi
1484             zj=c(3,nres+j)-zi
1485 C Change 12/1/95 to calculate four-body interactions
1486             rij=xj*xj+yj*yj+zj*zj
1487             rrij=1.0D0/rij
1488 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1489             eps0ij=eps(itypi,itypj)
1490             fac=rrij**expon2
1491 C have you changed here?
1492             e1=fac*fac*aa
1493             e2=fac*bb
1494             evdwij=e1+e2
1495 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1496 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1497 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1498 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1499 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1500 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1501             evdw=evdw+evdwij
1502 C
1503 C Calculate the components of the gradient in DC and X
1504 C
1505             fac=-rrij*(e1+evdwij)
1506             gg(1)=xj*fac
1507             gg(2)=yj*fac
1508             gg(3)=zj*fac
1509             do k=1,3
1510               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1511               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1512               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1513               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1514             enddo
1515 cgrad            do k=i,j-1
1516 cgrad              do l=1,3
1517 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1518 cgrad              enddo
1519 cgrad            enddo
1520 C
1521 #ifdef FOURBODY
1522 C 12/1/95, revised on 5/20/97
1523 C
1524 C Calculate the contact function. The ith column of the array JCONT will
1525 C contain the numbers of atoms that make contacts with the atom I (of numbers
1526 C greater than I). The arrays FACONT and GACONT will contain the values of
1527 C the contact function and its derivative.
1528 C
1529 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1530 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1531 C Uncomment next line, if the correlation interactions are contact function only
1532             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1533               rij=dsqrt(rij)
1534               sigij=sigma(itypi,itypj)
1535               r0ij=rs0(itypi,itypj)
1536 C
1537 C Check whether the SC's are not too far to make a contact.
1538 C
1539               rcut=1.5d0*r0ij
1540               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1541 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1542 C
1543               if (fcont.gt.0.0D0) then
1544 C If the SC-SC distance if close to sigma, apply spline.
1545 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1546 cAdam &             fcont1,fprimcont1)
1547 cAdam           fcont1=1.0d0-fcont1
1548 cAdam           if (fcont1.gt.0.0d0) then
1549 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1550 cAdam             fcont=fcont*fcont1
1551 cAdam           endif
1552 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1553 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1554 cga             do k=1,3
1555 cga               gg(k)=gg(k)*eps0ij
1556 cga             enddo
1557 cga             eps0ij=-evdwij*eps0ij
1558 C Uncomment for AL's type of SC correlation interactions.
1559 cadam           eps0ij=-evdwij
1560                 num_conti=num_conti+1
1561                 jcont(num_conti,i)=j
1562                 facont(num_conti,i)=fcont*eps0ij
1563                 fprimcont=eps0ij*fprimcont/rij
1564                 fcont=expon*fcont
1565 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1566 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1567 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1568 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1569                 gacont(1,num_conti,i)=-fprimcont*xj
1570                 gacont(2,num_conti,i)=-fprimcont*yj
1571                 gacont(3,num_conti,i)=-fprimcont*zj
1572 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1573 cd              write (iout,'(2i3,3f10.5)')
1574 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1575               endif
1576             endif
1577 #endif
1578           enddo      ! j
1579         enddo        ! iint
1580 C Change 12/1/95
1581 #ifdef FOURBODY
1582         num_cont(i)=num_conti
1583 #endif
1584       enddo          ! i
1585       do i=1,nct
1586         do j=1,3
1587           gvdwc(j,i)=expon*gvdwc(j,i)
1588           gvdwx(j,i)=expon*gvdwx(j,i)
1589         enddo
1590       enddo
1591 C******************************************************************************
1592 C
1593 C                              N O T E !!!
1594 C
1595 C To save time, the factor of EXPON has been extracted from ALL components
1596 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1597 C use!
1598 C
1599 C******************************************************************************
1600       return
1601       end
1602 C-----------------------------------------------------------------------------
1603       subroutine eljk(evdw)
1604 C
1605 C This subroutine calculates the interaction energy of nonbonded side chains
1606 C assuming the LJK potential of interaction.
1607 C
1608       implicit none
1609       include 'DIMENSIONS'
1610       include 'COMMON.GEO'
1611       include 'COMMON.VAR'
1612       include 'COMMON.LOCAL'
1613       include 'COMMON.CHAIN'
1614       include 'COMMON.DERIV'
1615       include 'COMMON.INTERACT'
1616       include 'COMMON.IOUNITS'
1617       include 'COMMON.NAMES'
1618       double precision gg(3)
1619       double precision evdw,evdwij
1620       integer i,j,k,itypi,itypj,itypi1,iint
1621       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1622      & fac_augm,e_augm,r_inv_ij,r_shift_inv
1623       logical scheck
1624 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1625       evdw=0.0D0
1626       do i=iatsc_s,iatsc_e
1627         itypi=iabs(itype(i))
1628         if (itypi.eq.ntyp1) cycle
1629         itypi1=iabs(itype(i+1))
1630         xi=c(1,nres+i)
1631         yi=c(2,nres+i)
1632         zi=c(3,nres+i)
1633 C
1634 C Calculate SC interaction energy.
1635 C
1636         do iint=1,nint_gr(i)
1637           do j=istart(i,iint),iend(i,iint)
1638             itypj=iabs(itype(j))
1639             if (itypj.eq.ntyp1) cycle
1640             xj=c(1,nres+j)-xi
1641             yj=c(2,nres+j)-yi
1642             zj=c(3,nres+j)-zi
1643             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1644             fac_augm=rrij**expon
1645             e_augm=augm(itypi,itypj)*fac_augm
1646             r_inv_ij=dsqrt(rrij)
1647             rij=1.0D0/r_inv_ij
1648             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1649             fac=r_shift_inv**expon
1650 C have you changed here?
1651             e1=fac*fac*aa
1652             e2=fac*bb
1653             evdwij=e_augm+e1+e2
1654 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1655 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1656 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1657 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1658 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1659 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1660 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1661             evdw=evdw+evdwij
1662 C
1663 C Calculate the components of the gradient in DC and X
1664 C
1665             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1666             gg(1)=xj*fac
1667             gg(2)=yj*fac
1668             gg(3)=zj*fac
1669             do k=1,3
1670               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1671               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1672               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1673               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1674             enddo
1675 cgrad            do k=i,j-1
1676 cgrad              do l=1,3
1677 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1678 cgrad              enddo
1679 cgrad            enddo
1680           enddo      ! j
1681         enddo        ! iint
1682       enddo          ! i
1683       do i=1,nct
1684         do j=1,3
1685           gvdwc(j,i)=expon*gvdwc(j,i)
1686           gvdwx(j,i)=expon*gvdwx(j,i)
1687         enddo
1688       enddo
1689       return
1690       end
1691 C-----------------------------------------------------------------------------
1692       subroutine ebp(evdw)
1693 C
1694 C This subroutine calculates the interaction energy of nonbonded side chains
1695 C assuming the Berne-Pechukas potential of interaction.
1696 C
1697       implicit none
1698       include 'DIMENSIONS'
1699       include 'COMMON.GEO'
1700       include 'COMMON.VAR'
1701       include 'COMMON.LOCAL'
1702       include 'COMMON.CHAIN'
1703       include 'COMMON.DERIV'
1704       include 'COMMON.NAMES'
1705       include 'COMMON.INTERACT'
1706       include 'COMMON.IOUNITS'
1707       include 'COMMON.CALC'
1708       integer icall
1709       common /srutu/ icall
1710       double precision evdw
1711       integer itypi,itypj,itypi1,iint,ind
1712       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1713 c     double precision rrsave(maxdim)
1714       logical lprn
1715       evdw=0.0D0
1716 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1717       evdw=0.0D0
1718 c     if (icall.eq.0) then
1719 c       lprn=.true.
1720 c     else
1721         lprn=.false.
1722 c     endif
1723       ind=0
1724       do i=iatsc_s,iatsc_e
1725         itypi=iabs(itype(i))
1726         if (itypi.eq.ntyp1) cycle
1727         itypi1=iabs(itype(i+1))
1728         xi=c(1,nres+i)
1729         yi=c(2,nres+i)
1730         zi=c(3,nres+i)
1731         dxi=dc_norm(1,nres+i)
1732         dyi=dc_norm(2,nres+i)
1733         dzi=dc_norm(3,nres+i)
1734 c        dsci_inv=dsc_inv(itypi)
1735         dsci_inv=vbld_inv(i+nres)
1736 C
1737 C Calculate SC interaction energy.
1738 C
1739         do iint=1,nint_gr(i)
1740           do j=istart(i,iint),iend(i,iint)
1741             ind=ind+1
1742             itypj=iabs(itype(j))
1743             if (itypj.eq.ntyp1) cycle
1744 c            dscj_inv=dsc_inv(itypj)
1745             dscj_inv=vbld_inv(j+nres)
1746             chi1=chi(itypi,itypj)
1747             chi2=chi(itypj,itypi)
1748             chi12=chi1*chi2
1749             chip1=chip(itypi)
1750             chip2=chip(itypj)
1751             chip12=chip1*chip2
1752             alf1=alp(itypi)
1753             alf2=alp(itypj)
1754             alf12=0.5D0*(alf1+alf2)
1755 C For diagnostics only!!!
1756 c           chi1=0.0D0
1757 c           chi2=0.0D0
1758 c           chi12=0.0D0
1759 c           chip1=0.0D0
1760 c           chip2=0.0D0
1761 c           chip12=0.0D0
1762 c           alf1=0.0D0
1763 c           alf2=0.0D0
1764 c           alf12=0.0D0
1765             xj=c(1,nres+j)-xi
1766             yj=c(2,nres+j)-yi
1767             zj=c(3,nres+j)-zi
1768             dxj=dc_norm(1,nres+j)
1769             dyj=dc_norm(2,nres+j)
1770             dzj=dc_norm(3,nres+j)
1771             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1772 cd          if (icall.eq.0) then
1773 cd            rrsave(ind)=rrij
1774 cd          else
1775 cd            rrij=rrsave(ind)
1776 cd          endif
1777             rij=dsqrt(rrij)
1778 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1779             call sc_angular
1780 C Calculate whole angle-dependent part of epsilon and contributions
1781 C to its derivatives
1782 C have you changed here?
1783             fac=(rrij*sigsq)**expon2
1784             e1=fac*fac*aa
1785             e2=fac*bb
1786             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1787             eps2der=evdwij*eps3rt
1788             eps3der=evdwij*eps2rt
1789             evdwij=evdwij*eps2rt*eps3rt
1790             evdw=evdw+evdwij
1791             if (lprn) then
1792             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1793             epsi=bb**2/aa
1794 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1795 cd     &        restyp(itypi),i,restyp(itypj),j,
1796 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1797 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1798 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1799 cd     &        evdwij
1800             endif
1801 C Calculate gradient components.
1802             e1=e1*eps1*eps2rt**2*eps3rt**2
1803             fac=-expon*(e1+evdwij)
1804             sigder=fac/sigsq
1805             fac=rrij*fac
1806 C Calculate radial part of the gradient
1807             gg(1)=xj*fac
1808             gg(2)=yj*fac
1809             gg(3)=zj*fac
1810 C Calculate the angular part of the gradient and sum add the contributions
1811 C to the appropriate components of the Cartesian gradient.
1812             call sc_grad
1813           enddo      ! j
1814         enddo        ! iint
1815       enddo          ! i
1816 c     stop
1817       return
1818       end
1819 C-----------------------------------------------------------------------------
1820       subroutine egb(evdw)
1821 C
1822 C This subroutine calculates the interaction energy of nonbonded side chains
1823 C assuming the Gay-Berne potential of interaction.
1824 C
1825       implicit none
1826       include 'DIMENSIONS'
1827       include 'COMMON.GEO'
1828       include 'COMMON.VAR'
1829       include 'COMMON.LOCAL'
1830       include 'COMMON.CHAIN'
1831       include 'COMMON.DERIV'
1832       include 'COMMON.NAMES'
1833       include 'COMMON.INTERACT'
1834       include 'COMMON.IOUNITS'
1835       include 'COMMON.CALC'
1836       include 'COMMON.CONTROL'
1837       include 'COMMON.SPLITELE'
1838       include 'COMMON.SBRIDGE'
1839       logical lprn
1840       integer xshift,yshift,zshift,subchap
1841       double precision evdw
1842       integer itypi,itypj,itypi1,iint,ind
1843       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1844       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1845      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1846      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1847       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1848       evdw=0.0D0
1849 ccccc      energy_dec=.false.
1850 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1851       evdw=0.0D0
1852       lprn=.false.
1853 c     if (icall.eq.0) lprn=.false.
1854       ind=0
1855 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1856 C we have the original box)
1857 C      do xshift=-1,1
1858 C      do yshift=-1,1
1859 C      do zshift=-1,1
1860       do i=iatsc_s,iatsc_e
1861         itypi=iabs(itype(i))
1862         if (itypi.eq.ntyp1) cycle
1863         itypi1=iabs(itype(i+1))
1864         xi=c(1,nres+i)
1865         yi=c(2,nres+i)
1866         zi=c(3,nres+i)
1867 C Return atom into box, boxxsize is size of box in x dimension
1868 c  134   continue
1869 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1870 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1871 C Condition for being inside the proper box
1872 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1873 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1874 c        go to 134
1875 c        endif
1876 c  135   continue
1877 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1878 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1879 C Condition for being inside the proper box
1880 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1881 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1882 c        go to 135
1883 c        endif
1884 c  136   continue
1885 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1886 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1887 C Condition for being inside the proper box
1888 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1889 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1890 c        go to 136
1891 c        endif
1892           xi=mod(xi,boxxsize)
1893           if (xi.lt.0) xi=xi+boxxsize
1894           yi=mod(yi,boxysize)
1895           if (yi.lt.0) yi=yi+boxysize
1896           zi=mod(zi,boxzsize)
1897           if (zi.lt.0) zi=zi+boxzsize
1898 C define scaling factor for lipids
1899
1900 C        if (positi.le.0) positi=positi+boxzsize
1901 C        print *,i
1902 C first for peptide groups
1903 c for each residue check if it is in lipid or lipid water border area
1904        if ((zi.gt.bordlipbot)
1905      &.and.(zi.lt.bordliptop)) then
1906 C the energy transfer exist
1907         if (zi.lt.buflipbot) then
1908 C what fraction I am in
1909          fracinbuf=1.0d0-
1910      &        ((zi-bordlipbot)/lipbufthick)
1911 C lipbufthick is thickenes of lipid buffore
1912          sslipi=sscalelip(fracinbuf)
1913          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1914         elseif (zi.gt.bufliptop) then
1915          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1916          sslipi=sscalelip(fracinbuf)
1917          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1918         else
1919          sslipi=1.0d0
1920          ssgradlipi=0.0
1921         endif
1922        else
1923          sslipi=0.0d0
1924          ssgradlipi=0.0
1925        endif
1926
1927 C          xi=xi+xshift*boxxsize
1928 C          yi=yi+yshift*boxysize
1929 C          zi=zi+zshift*boxzsize
1930
1931         dxi=dc_norm(1,nres+i)
1932         dyi=dc_norm(2,nres+i)
1933         dzi=dc_norm(3,nres+i)
1934 c        dsci_inv=dsc_inv(itypi)
1935         dsci_inv=vbld_inv(i+nres)
1936 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1937 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1938 C
1939 C Calculate SC interaction energy.
1940 C
1941         do iint=1,nint_gr(i)
1942           do j=istart(i,iint),iend(i,iint)
1943             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1944
1945 c              write(iout,*) "PRZED ZWYKLE", evdwij
1946               call dyn_ssbond_ene(i,j,evdwij)
1947 c              write(iout,*) "PO ZWYKLE", evdwij
1948
1949               evdw=evdw+evdwij
1950               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1951      &                        'evdw',i,j,evdwij,' ss'
1952 C triple bond artifac removal
1953              do k=j+1,iend(i,iint)
1954 C search over all next residues
1955               if (dyn_ss_mask(k)) then
1956 C check if they are cysteins
1957 C              write(iout,*) 'k=',k
1958
1959 c              write(iout,*) "PRZED TRI", evdwij
1960                evdwij_przed_tri=evdwij
1961               call triple_ssbond_ene(i,j,k,evdwij)
1962 c               if(evdwij_przed_tri.ne.evdwij) then
1963 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1964 c               endif
1965
1966 c              write(iout,*) "PO TRI", evdwij
1967 C call the energy function that removes the artifical triple disulfide
1968 C bond the soubroutine is located in ssMD.F
1969               evdw=evdw+evdwij
1970               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1971      &                        'evdw',i,j,evdwij,'tss'
1972               endif!dyn_ss_mask(k)
1973              enddo! k
1974             ELSE
1975             ind=ind+1
1976             itypj=iabs(itype(j))
1977             if (itypj.eq.ntyp1) cycle
1978 c            dscj_inv=dsc_inv(itypj)
1979             dscj_inv=vbld_inv(j+nres)
1980 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1981 c     &       1.0d0/vbld(j+nres)
1982 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1983             sig0ij=sigma(itypi,itypj)
1984             chi1=chi(itypi,itypj)
1985             chi2=chi(itypj,itypi)
1986             chi12=chi1*chi2
1987             chip1=chip(itypi)
1988             chip2=chip(itypj)
1989             chip12=chip1*chip2
1990             alf1=alp(itypi)
1991             alf2=alp(itypj)
1992             alf12=0.5D0*(alf1+alf2)
1993 C For diagnostics only!!!
1994 c           chi1=0.0D0
1995 c           chi2=0.0D0
1996 c           chi12=0.0D0
1997 c           chip1=0.0D0
1998 c           chip2=0.0D0
1999 c           chip12=0.0D0
2000 c           alf1=0.0D0
2001 c           alf2=0.0D0
2002 c           alf12=0.0D0
2003             xj=c(1,nres+j)
2004             yj=c(2,nres+j)
2005             zj=c(3,nres+j)
2006 C Return atom J into box the original box
2007 c  137   continue
2008 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2009 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2010 C Condition for being inside the proper box
2011 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2012 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2013 c        go to 137
2014 c        endif
2015 c  138   continue
2016 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2017 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2018 C Condition for being inside the proper box
2019 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2020 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2021 c        go to 138
2022 c        endif
2023 c  139   continue
2024 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2025 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2026 C Condition for being inside the proper box
2027 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2028 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2029 c        go to 139
2030 c        endif
2031           xj=mod(xj,boxxsize)
2032           if (xj.lt.0) xj=xj+boxxsize
2033           yj=mod(yj,boxysize)
2034           if (yj.lt.0) yj=yj+boxysize
2035           zj=mod(zj,boxzsize)
2036           if (zj.lt.0) zj=zj+boxzsize
2037        if ((zj.gt.bordlipbot)
2038      &.and.(zj.lt.bordliptop)) then
2039 C the energy transfer exist
2040         if (zj.lt.buflipbot) then
2041 C what fraction I am in
2042          fracinbuf=1.0d0-
2043      &        ((zj-bordlipbot)/lipbufthick)
2044 C lipbufthick is thickenes of lipid buffore
2045          sslipj=sscalelip(fracinbuf)
2046          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2047         elseif (zj.gt.bufliptop) then
2048          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2049          sslipj=sscalelip(fracinbuf)
2050          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2051         else
2052          sslipj=1.0d0
2053          ssgradlipj=0.0
2054         endif
2055        else
2056          sslipj=0.0d0
2057          ssgradlipj=0.0
2058        endif
2059       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2060      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2061       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2062      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2063 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2064 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2065 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2066 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2067 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2068       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2069       xj_safe=xj
2070       yj_safe=yj
2071       zj_safe=zj
2072       subchap=0
2073       do xshift=-1,1
2074       do yshift=-1,1
2075       do zshift=-1,1
2076           xj=xj_safe+xshift*boxxsize
2077           yj=yj_safe+yshift*boxysize
2078           zj=zj_safe+zshift*boxzsize
2079           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2080           if(dist_temp.lt.dist_init) then
2081             dist_init=dist_temp
2082             xj_temp=xj
2083             yj_temp=yj
2084             zj_temp=zj
2085             subchap=1
2086           endif
2087        enddo
2088        enddo
2089        enddo
2090        if (subchap.eq.1) then
2091           xj=xj_temp-xi
2092           yj=yj_temp-yi
2093           zj=zj_temp-zi
2094        else
2095           xj=xj_safe-xi
2096           yj=yj_safe-yi
2097           zj=zj_safe-zi
2098        endif
2099             dxj=dc_norm(1,nres+j)
2100             dyj=dc_norm(2,nres+j)
2101             dzj=dc_norm(3,nres+j)
2102 C            xj=xj-xi
2103 C            yj=yj-yi
2104 C            zj=zj-zi
2105 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2106 c            write (iout,*) "j",j," dc_norm",
2107 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2108             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2109             rij=dsqrt(rrij)
2110             sss=sscale(1.0d0/rij,r_cut_int)
2111             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2112
2113 c            write (iout,'(a7,4f8.3)')
2114 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2115             if (sss.gt.0.0d0) then
2116 C Calculate angle-dependent terms of energy and contributions to their
2117 C derivatives.
2118             call sc_angular
2119             sigsq=1.0D0/sigsq
2120             sig=sig0ij*dsqrt(sigsq)
2121             rij_shift=1.0D0/rij-sig+sig0ij
2122 c for diagnostics; uncomment
2123 c            rij_shift=1.2*sig0ij
2124 C I hate to put IF's in the loops, but here don't have another choice!!!!
2125             if (rij_shift.le.0.0D0) then
2126               evdw=1.0D20
2127 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2128 cd     &        restyp(itypi),i,restyp(itypj),j,
2129 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2130               return
2131             endif
2132             sigder=-sig*sigsq
2133 c---------------------------------------------------------------
2134             rij_shift=1.0D0/rij_shift
2135             fac=rij_shift**expon
2136 C here to start with
2137 C            if (c(i,3).gt.
2138             faclip=fac
2139             e1=fac*fac*aa
2140             e2=fac*bb
2141             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2142             eps2der=evdwij*eps3rt
2143             eps3der=evdwij*eps2rt
2144 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2145 C     &((sslipi+sslipj)/2.0d0+
2146 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2147 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2148 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2149             evdwij=evdwij*eps2rt*eps3rt
2150             evdw=evdw+evdwij*sss
2151             if (lprn) then
2152             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2153             epsi=bb**2/aa
2154             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2155      &        restyp(itypi),i,restyp(itypj),j,
2156      &        epsi,sigm,chi1,chi2,chip1,chip2,
2157      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2158      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2159      &        evdwij
2160             endif
2161
2162             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2163      &                        'evdw',i,j,evdwij
2164
2165 C Calculate gradient components.
2166             e1=e1*eps1*eps2rt**2*eps3rt**2
2167             fac=-expon*(e1+evdwij)*rij_shift
2168             sigder=fac*sigder
2169             fac=rij*fac
2170 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2171 c     &      evdwij,fac,sigma(itypi,itypj),expon
2172             fac=fac+evdwij/sss*sssgrad*rij
2173 c            fac=0.0d0
2174 C Calculate the radial part of the gradient
2175             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2176      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2177      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2178      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2179             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2180             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2181 C            gg_lipi(3)=0.0d0
2182 C            gg_lipj(3)=0.0d0
2183             gg(1)=xj*fac
2184             gg(2)=yj*fac
2185             gg(3)=zj*fac
2186 C Calculate angular part of the gradient.
2187             call sc_grad
2188             endif
2189             ENDIF    ! dyn_ss
2190           enddo      ! j
2191         enddo        ! iint
2192       enddo          ! i
2193 C      enddo          ! zshift
2194 C      enddo          ! yshift
2195 C      enddo          ! xshift
2196 c      write (iout,*) "Number of loop steps in EGB:",ind
2197 cccc      energy_dec=.false.
2198       return
2199       end
2200 C-----------------------------------------------------------------------------
2201       subroutine egbv(evdw)
2202 C
2203 C This subroutine calculates the interaction energy of nonbonded side chains
2204 C assuming the Gay-Berne-Vorobjev potential of interaction.
2205 C
2206       implicit none
2207       include 'DIMENSIONS'
2208       include 'COMMON.GEO'
2209       include 'COMMON.VAR'
2210       include 'COMMON.LOCAL'
2211       include 'COMMON.CHAIN'
2212       include 'COMMON.DERIV'
2213       include 'COMMON.NAMES'
2214       include 'COMMON.INTERACT'
2215       include 'COMMON.IOUNITS'
2216       include 'COMMON.CALC'
2217       integer xshift,yshift,zshift,subchap
2218       integer icall
2219       common /srutu/ icall
2220       logical lprn
2221       double precision evdw
2222       integer itypi,itypj,itypi1,iint,ind
2223       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2224      & xi,yi,zi,fac_augm,e_augm
2225       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2226      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2227      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
2228       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2229       evdw=0.0D0
2230 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2231       evdw=0.0D0
2232       lprn=.false.
2233 c     if (icall.eq.0) lprn=.true.
2234       ind=0
2235       do i=iatsc_s,iatsc_e
2236         itypi=iabs(itype(i))
2237         if (itypi.eq.ntyp1) cycle
2238         itypi1=iabs(itype(i+1))
2239         xi=c(1,nres+i)
2240         yi=c(2,nres+i)
2241         zi=c(3,nres+i)
2242           xi=mod(xi,boxxsize)
2243           if (xi.lt.0) xi=xi+boxxsize
2244           yi=mod(yi,boxysize)
2245           if (yi.lt.0) yi=yi+boxysize
2246           zi=mod(zi,boxzsize)
2247           if (zi.lt.0) zi=zi+boxzsize
2248 C define scaling factor for lipids
2249
2250 C        if (positi.le.0) positi=positi+boxzsize
2251 C        print *,i
2252 C first for peptide groups
2253 c for each residue check if it is in lipid or lipid water border area
2254        if ((zi.gt.bordlipbot)
2255      &.and.(zi.lt.bordliptop)) then
2256 C the energy transfer exist
2257         if (zi.lt.buflipbot) then
2258 C what fraction I am in
2259          fracinbuf=1.0d0-
2260      &        ((zi-bordlipbot)/lipbufthick)
2261 C lipbufthick is thickenes of lipid buffore
2262          sslipi=sscalelip(fracinbuf)
2263          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2264         elseif (zi.gt.bufliptop) then
2265          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2266          sslipi=sscalelip(fracinbuf)
2267          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2268         else
2269          sslipi=1.0d0
2270          ssgradlipi=0.0
2271         endif
2272        else
2273          sslipi=0.0d0
2274          ssgradlipi=0.0
2275        endif
2276
2277         dxi=dc_norm(1,nres+i)
2278         dyi=dc_norm(2,nres+i)
2279         dzi=dc_norm(3,nres+i)
2280 c        dsci_inv=dsc_inv(itypi)
2281         dsci_inv=vbld_inv(i+nres)
2282 C
2283 C Calculate SC interaction energy.
2284 C
2285         do iint=1,nint_gr(i)
2286           do j=istart(i,iint),iend(i,iint)
2287             ind=ind+1
2288             itypj=iabs(itype(j))
2289             if (itypj.eq.ntyp1) cycle
2290 c            dscj_inv=dsc_inv(itypj)
2291             dscj_inv=vbld_inv(j+nres)
2292             sig0ij=sigma(itypi,itypj)
2293             r0ij=r0(itypi,itypj)
2294             chi1=chi(itypi,itypj)
2295             chi2=chi(itypj,itypi)
2296             chi12=chi1*chi2
2297             chip1=chip(itypi)
2298             chip2=chip(itypj)
2299             chip12=chip1*chip2
2300             alf1=alp(itypi)
2301             alf2=alp(itypj)
2302             alf12=0.5D0*(alf1+alf2)
2303 C For diagnostics only!!!
2304 c           chi1=0.0D0
2305 c           chi2=0.0D0
2306 c           chi12=0.0D0
2307 c           chip1=0.0D0
2308 c           chip2=0.0D0
2309 c           chip12=0.0D0
2310 c           alf1=0.0D0
2311 c           alf2=0.0D0
2312 c           alf12=0.0D0
2313 C            xj=c(1,nres+j)-xi
2314 C            yj=c(2,nres+j)-yi
2315 C            zj=c(3,nres+j)-zi
2316           xj=mod(xj,boxxsize)
2317           if (xj.lt.0) xj=xj+boxxsize
2318           yj=mod(yj,boxysize)
2319           if (yj.lt.0) yj=yj+boxysize
2320           zj=mod(zj,boxzsize)
2321           if (zj.lt.0) zj=zj+boxzsize
2322        if ((zj.gt.bordlipbot)
2323      &.and.(zj.lt.bordliptop)) then
2324 C the energy transfer exist
2325         if (zj.lt.buflipbot) then
2326 C what fraction I am in
2327          fracinbuf=1.0d0-
2328      &        ((zj-bordlipbot)/lipbufthick)
2329 C lipbufthick is thickenes of lipid buffore
2330          sslipj=sscalelip(fracinbuf)
2331          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2332         elseif (zj.gt.bufliptop) then
2333          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2334          sslipj=sscalelip(fracinbuf)
2335          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2336         else
2337          sslipj=1.0d0
2338          ssgradlipj=0.0
2339         endif
2340        else
2341          sslipj=0.0d0
2342          ssgradlipj=0.0
2343        endif
2344       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2345      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2346       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2347      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2348 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2349 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2350 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2351       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2352       xj_safe=xj
2353       yj_safe=yj
2354       zj_safe=zj
2355       subchap=0
2356       do xshift=-1,1
2357       do yshift=-1,1
2358       do zshift=-1,1
2359           xj=xj_safe+xshift*boxxsize
2360           yj=yj_safe+yshift*boxysize
2361           zj=zj_safe+zshift*boxzsize
2362           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2363           if(dist_temp.lt.dist_init) then
2364             dist_init=dist_temp
2365             xj_temp=xj
2366             yj_temp=yj
2367             zj_temp=zj
2368             subchap=1
2369           endif
2370        enddo
2371        enddo
2372        enddo
2373        if (subchap.eq.1) then
2374           xj=xj_temp-xi
2375           yj=yj_temp-yi
2376           zj=zj_temp-zi
2377        else
2378           xj=xj_safe-xi
2379           yj=yj_safe-yi
2380           zj=zj_safe-zi
2381        endif
2382             dxj=dc_norm(1,nres+j)
2383             dyj=dc_norm(2,nres+j)
2384             dzj=dc_norm(3,nres+j)
2385             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2386             rij=dsqrt(rrij)
2387 C Calculate angle-dependent terms of energy and contributions to their
2388 C derivatives.
2389             call sc_angular
2390             sigsq=1.0D0/sigsq
2391             sig=sig0ij*dsqrt(sigsq)
2392             rij_shift=1.0D0/rij-sig+r0ij
2393 C I hate to put IF's in the loops, but here don't have another choice!!!!
2394             if (rij_shift.le.0.0D0) then
2395               evdw=1.0D20
2396               return
2397             endif
2398             sigder=-sig*sigsq
2399 c---------------------------------------------------------------
2400             rij_shift=1.0D0/rij_shift
2401             fac=rij_shift**expon
2402             e1=fac*fac*aa
2403             e2=fac*bb
2404             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2405             eps2der=evdwij*eps3rt
2406             eps3der=evdwij*eps2rt
2407             fac_augm=rrij**expon
2408             e_augm=augm(itypi,itypj)*fac_augm
2409             evdwij=evdwij*eps2rt*eps3rt
2410             evdw=evdw+evdwij+e_augm
2411             if (lprn) then
2412             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2413             epsi=bb**2/aa
2414             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2415      &        restyp(itypi),i,restyp(itypj),j,
2416      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2417      &        chi1,chi2,chip1,chip2,
2418      &        eps1,eps2rt**2,eps3rt**2,
2419      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2420      &        evdwij+e_augm
2421             endif
2422 C Calculate gradient components.
2423             e1=e1*eps1*eps2rt**2*eps3rt**2
2424             fac=-expon*(e1+evdwij)*rij_shift
2425             sigder=fac*sigder
2426             fac=rij*fac-2*expon*rrij*e_augm
2427             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2428 C Calculate the radial part of the gradient
2429             gg(1)=xj*fac
2430             gg(2)=yj*fac
2431             gg(3)=zj*fac
2432 C Calculate angular part of the gradient.
2433             call sc_grad
2434           enddo      ! j
2435         enddo        ! iint
2436       enddo          ! i
2437       end
2438 C-----------------------------------------------------------------------------
2439       subroutine sc_angular
2440 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2441 C om12. Called by ebp, egb, and egbv.
2442       implicit none
2443       include 'COMMON.CALC'
2444       include 'COMMON.IOUNITS'
2445       erij(1)=xj*rij
2446       erij(2)=yj*rij
2447       erij(3)=zj*rij
2448       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2449       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2450       om12=dxi*dxj+dyi*dyj+dzi*dzj
2451       chiom12=chi12*om12
2452 C Calculate eps1(om12) and its derivative in om12
2453       faceps1=1.0D0-om12*chiom12
2454       faceps1_inv=1.0D0/faceps1
2455       eps1=dsqrt(faceps1_inv)
2456 C Following variable is eps1*deps1/dom12
2457       eps1_om12=faceps1_inv*chiom12
2458 c diagnostics only
2459 c      faceps1_inv=om12
2460 c      eps1=om12
2461 c      eps1_om12=1.0d0
2462 c      write (iout,*) "om12",om12," eps1",eps1
2463 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2464 C and om12.
2465       om1om2=om1*om2
2466       chiom1=chi1*om1
2467       chiom2=chi2*om2
2468       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2469       sigsq=1.0D0-facsig*faceps1_inv
2470       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2471       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2472       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2473 c diagnostics only
2474 c      sigsq=1.0d0
2475 c      sigsq_om1=0.0d0
2476 c      sigsq_om2=0.0d0
2477 c      sigsq_om12=0.0d0
2478 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2479 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2480 c     &    " eps1",eps1
2481 C Calculate eps2 and its derivatives in om1, om2, and om12.
2482       chipom1=chip1*om1
2483       chipom2=chip2*om2
2484       chipom12=chip12*om12
2485       facp=1.0D0-om12*chipom12
2486       facp_inv=1.0D0/facp
2487       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2488 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2489 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2490 C Following variable is the square root of eps2
2491       eps2rt=1.0D0-facp1*facp_inv
2492 C Following three variables are the derivatives of the square root of eps
2493 C in om1, om2, and om12.
2494       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2495       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2496       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2497 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2498       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2499 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2500 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2501 c     &  " eps2rt_om12",eps2rt_om12
2502 C Calculate whole angle-dependent part of epsilon and contributions
2503 C to its derivatives
2504       return
2505       end
2506 C----------------------------------------------------------------------------
2507       subroutine sc_grad
2508       implicit real*8 (a-h,o-z)
2509       include 'DIMENSIONS'
2510       include 'COMMON.CHAIN'
2511       include 'COMMON.DERIV'
2512       include 'COMMON.CALC'
2513       include 'COMMON.IOUNITS'
2514       double precision dcosom1(3),dcosom2(3)
2515 cc      print *,'sss=',sss
2516       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2517       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2518       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2519      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2520 c diagnostics only
2521 c      eom1=0.0d0
2522 c      eom2=0.0d0
2523 c      eom12=evdwij*eps1_om12
2524 c end diagnostics
2525 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2526 c     &  " sigder",sigder
2527 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2528 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2529       do k=1,3
2530         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2531         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2532       enddo
2533       do k=1,3
2534         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2535       enddo
2536 c      write (iout,*) "gg",(gg(k),k=1,3)
2537       do k=1,3
2538         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2539      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2540      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2541         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2542      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2543      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2544 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2545 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2546 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2547 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2548       enddo
2549 C
2550 C Calculate the components of the gradient in DC and X
2551 C
2552 cgrad      do k=i,j-1
2553 cgrad        do l=1,3
2554 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2555 cgrad        enddo
2556 cgrad      enddo
2557       do l=1,3
2558         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2559         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2560       enddo
2561       return
2562       end
2563 C-----------------------------------------------------------------------
2564       subroutine e_softsphere(evdw)
2565 C
2566 C This subroutine calculates the interaction energy of nonbonded side chains
2567 C assuming the LJ potential of interaction.
2568 C
2569       implicit real*8 (a-h,o-z)
2570       include 'DIMENSIONS'
2571       parameter (accur=1.0d-10)
2572       include 'COMMON.GEO'
2573       include 'COMMON.VAR'
2574       include 'COMMON.LOCAL'
2575       include 'COMMON.CHAIN'
2576       include 'COMMON.DERIV'
2577       include 'COMMON.INTERACT'
2578       include 'COMMON.TORSION'
2579       include 'COMMON.SBRIDGE'
2580       include 'COMMON.NAMES'
2581       include 'COMMON.IOUNITS'
2582 c      include 'COMMON.CONTACTS'
2583       dimension gg(3)
2584 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2585       evdw=0.0D0
2586       do i=iatsc_s,iatsc_e
2587         itypi=iabs(itype(i))
2588         if (itypi.eq.ntyp1) cycle
2589         itypi1=iabs(itype(i+1))
2590         xi=c(1,nres+i)
2591         yi=c(2,nres+i)
2592         zi=c(3,nres+i)
2593 C
2594 C Calculate SC interaction energy.
2595 C
2596         do iint=1,nint_gr(i)
2597 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2598 cd   &                  'iend=',iend(i,iint)
2599           do j=istart(i,iint),iend(i,iint)
2600             itypj=iabs(itype(j))
2601             if (itypj.eq.ntyp1) cycle
2602             xj=c(1,nres+j)-xi
2603             yj=c(2,nres+j)-yi
2604             zj=c(3,nres+j)-zi
2605             rij=xj*xj+yj*yj+zj*zj
2606 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2607             r0ij=r0(itypi,itypj)
2608             r0ijsq=r0ij*r0ij
2609 c            print *,i,j,r0ij,dsqrt(rij)
2610             if (rij.lt.r0ijsq) then
2611               evdwij=0.25d0*(rij-r0ijsq)**2
2612               fac=rij-r0ijsq
2613             else
2614               evdwij=0.0d0
2615               fac=0.0d0
2616             endif
2617             evdw=evdw+evdwij
2618 C
2619 C Calculate the components of the gradient in DC and X
2620 C
2621             gg(1)=xj*fac
2622             gg(2)=yj*fac
2623             gg(3)=zj*fac
2624             do k=1,3
2625               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2626               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2627               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2628               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2629             enddo
2630 cgrad            do k=i,j-1
2631 cgrad              do l=1,3
2632 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2633 cgrad              enddo
2634 cgrad            enddo
2635           enddo ! j
2636         enddo ! iint
2637       enddo ! i
2638       return
2639       end
2640 C--------------------------------------------------------------------------
2641       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2642      &              eello_turn4)
2643 C
2644 C Soft-sphere potential of p-p interaction
2645 C
2646       implicit real*8 (a-h,o-z)
2647       include 'DIMENSIONS'
2648       include 'COMMON.CONTROL'
2649       include 'COMMON.IOUNITS'
2650       include 'COMMON.GEO'
2651       include 'COMMON.VAR'
2652       include 'COMMON.LOCAL'
2653       include 'COMMON.CHAIN'
2654       include 'COMMON.DERIV'
2655       include 'COMMON.INTERACT'
2656 c      include 'COMMON.CONTACTS'
2657       include 'COMMON.TORSION'
2658       include 'COMMON.VECTORS'
2659       include 'COMMON.FFIELD'
2660       dimension ggg(3)
2661       integer xshift,yshift,zshift
2662 C      write(iout,*) 'In EELEC_soft_sphere'
2663       ees=0.0D0
2664       evdw1=0.0D0
2665       eel_loc=0.0d0
2666       eello_turn3=0.0d0
2667       eello_turn4=0.0d0
2668       ind=0
2669       do i=iatel_s,iatel_e
2670         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2671         dxi=dc(1,i)
2672         dyi=dc(2,i)
2673         dzi=dc(3,i)
2674         xmedi=c(1,i)+0.5d0*dxi
2675         ymedi=c(2,i)+0.5d0*dyi
2676         zmedi=c(3,i)+0.5d0*dzi
2677           xmedi=mod(xmedi,boxxsize)
2678           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2679           ymedi=mod(ymedi,boxysize)
2680           if (ymedi.lt.0) ymedi=ymedi+boxysize
2681           zmedi=mod(zmedi,boxzsize)
2682           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2683         num_conti=0
2684 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2685         do j=ielstart(i),ielend(i)
2686           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2687           ind=ind+1
2688           iteli=itel(i)
2689           itelj=itel(j)
2690           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2691           r0ij=rpp(iteli,itelj)
2692           r0ijsq=r0ij*r0ij
2693           dxj=dc(1,j)
2694           dyj=dc(2,j)
2695           dzj=dc(3,j)
2696           xj=c(1,j)+0.5D0*dxj
2697           yj=c(2,j)+0.5D0*dyj
2698           zj=c(3,j)+0.5D0*dzj
2699           xj=mod(xj,boxxsize)
2700           if (xj.lt.0) xj=xj+boxxsize
2701           yj=mod(yj,boxysize)
2702           if (yj.lt.0) yj=yj+boxysize
2703           zj=mod(zj,boxzsize)
2704           if (zj.lt.0) zj=zj+boxzsize
2705       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2706       xj_safe=xj
2707       yj_safe=yj
2708       zj_safe=zj
2709       isubchap=0
2710       do xshift=-1,1
2711       do yshift=-1,1
2712       do zshift=-1,1
2713           xj=xj_safe+xshift*boxxsize
2714           yj=yj_safe+yshift*boxysize
2715           zj=zj_safe+zshift*boxzsize
2716           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2717           if(dist_temp.lt.dist_init) then
2718             dist_init=dist_temp
2719             xj_temp=xj
2720             yj_temp=yj
2721             zj_temp=zj
2722             isubchap=1
2723           endif
2724        enddo
2725        enddo
2726        enddo
2727        if (isubchap.eq.1) then
2728           xj=xj_temp-xmedi
2729           yj=yj_temp-ymedi
2730           zj=zj_temp-zmedi
2731        else
2732           xj=xj_safe-xmedi
2733           yj=yj_safe-ymedi
2734           zj=zj_safe-zmedi
2735        endif
2736           rij=xj*xj+yj*yj+zj*zj
2737             sss=sscale(sqrt(rij),r_cut_int)
2738             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2739           if (rij.lt.r0ijsq) then
2740             evdw1ij=0.25d0*(rij-r0ijsq)**2
2741             fac=rij-r0ijsq
2742           else
2743             evdw1ij=0.0d0
2744             fac=0.0d0
2745           endif
2746           evdw1=evdw1+evdw1ij*sss
2747 C
2748 C Calculate contributions to the Cartesian gradient.
2749 C
2750           ggg(1)=fac*xj*sssgrad
2751           ggg(2)=fac*yj*sssgrad
2752           ggg(3)=fac*zj*sssgrad
2753           do k=1,3
2754             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2755             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2756           enddo
2757 *
2758 * Loop over residues i+1 thru j-1.
2759 *
2760 cgrad          do k=i+1,j-1
2761 cgrad            do l=1,3
2762 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2763 cgrad            enddo
2764 cgrad          enddo
2765         enddo ! j
2766       enddo   ! i
2767 cgrad      do i=nnt,nct-1
2768 cgrad        do k=1,3
2769 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2770 cgrad        enddo
2771 cgrad        do j=i+1,nct-1
2772 cgrad          do k=1,3
2773 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2774 cgrad          enddo
2775 cgrad        enddo
2776 cgrad      enddo
2777       return
2778       end
2779 c------------------------------------------------------------------------------
2780       subroutine vec_and_deriv
2781       implicit real*8 (a-h,o-z)
2782       include 'DIMENSIONS'
2783 #ifdef MPI
2784       include 'mpif.h'
2785 #endif
2786       include 'COMMON.IOUNITS'
2787       include 'COMMON.GEO'
2788       include 'COMMON.VAR'
2789       include 'COMMON.LOCAL'
2790       include 'COMMON.CHAIN'
2791       include 'COMMON.VECTORS'
2792       include 'COMMON.SETUP'
2793       include 'COMMON.TIME1'
2794       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2795 C Compute the local reference systems. For reference system (i), the
2796 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2797 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2798 #ifdef PARVEC
2799       do i=ivec_start,ivec_end
2800 #else
2801       do i=1,nres-1
2802 #endif
2803           if (i.eq.nres-1) then
2804 C Case of the last full residue
2805 C Compute the Z-axis
2806             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2807             costh=dcos(pi-theta(nres))
2808             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2809             do k=1,3
2810               uz(k,i)=fac*uz(k,i)
2811             enddo
2812 C Compute the derivatives of uz
2813             uzder(1,1,1)= 0.0d0
2814             uzder(2,1,1)=-dc_norm(3,i-1)
2815             uzder(3,1,1)= dc_norm(2,i-1)
2816             uzder(1,2,1)= dc_norm(3,i-1)
2817             uzder(2,2,1)= 0.0d0
2818             uzder(3,2,1)=-dc_norm(1,i-1)
2819             uzder(1,3,1)=-dc_norm(2,i-1)
2820             uzder(2,3,1)= dc_norm(1,i-1)
2821             uzder(3,3,1)= 0.0d0
2822             uzder(1,1,2)= 0.0d0
2823             uzder(2,1,2)= dc_norm(3,i)
2824             uzder(3,1,2)=-dc_norm(2,i)
2825             uzder(1,2,2)=-dc_norm(3,i)
2826             uzder(2,2,2)= 0.0d0
2827             uzder(3,2,2)= dc_norm(1,i)
2828             uzder(1,3,2)= dc_norm(2,i)
2829             uzder(2,3,2)=-dc_norm(1,i)
2830             uzder(3,3,2)= 0.0d0
2831 C Compute the Y-axis
2832             facy=fac
2833             do k=1,3
2834               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2835             enddo
2836 C Compute the derivatives of uy
2837             do j=1,3
2838               do k=1,3
2839                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2840      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2841                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2842               enddo
2843               uyder(j,j,1)=uyder(j,j,1)-costh
2844               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2845             enddo
2846             do j=1,2
2847               do k=1,3
2848                 do l=1,3
2849                   uygrad(l,k,j,i)=uyder(l,k,j)
2850                   uzgrad(l,k,j,i)=uzder(l,k,j)
2851                 enddo
2852               enddo
2853             enddo
2854             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2855             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2856             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2857             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2858           else
2859 C Other residues
2860 C Compute the Z-axis
2861             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2862             costh=dcos(pi-theta(i+2))
2863             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2864             do k=1,3
2865               uz(k,i)=fac*uz(k,i)
2866             enddo
2867 C Compute the derivatives of uz
2868             uzder(1,1,1)= 0.0d0
2869             uzder(2,1,1)=-dc_norm(3,i+1)
2870             uzder(3,1,1)= dc_norm(2,i+1)
2871             uzder(1,2,1)= dc_norm(3,i+1)
2872             uzder(2,2,1)= 0.0d0
2873             uzder(3,2,1)=-dc_norm(1,i+1)
2874             uzder(1,3,1)=-dc_norm(2,i+1)
2875             uzder(2,3,1)= dc_norm(1,i+1)
2876             uzder(3,3,1)= 0.0d0
2877             uzder(1,1,2)= 0.0d0
2878             uzder(2,1,2)= dc_norm(3,i)
2879             uzder(3,1,2)=-dc_norm(2,i)
2880             uzder(1,2,2)=-dc_norm(3,i)
2881             uzder(2,2,2)= 0.0d0
2882             uzder(3,2,2)= dc_norm(1,i)
2883             uzder(1,3,2)= dc_norm(2,i)
2884             uzder(2,3,2)=-dc_norm(1,i)
2885             uzder(3,3,2)= 0.0d0
2886 C Compute the Y-axis
2887             facy=fac
2888             do k=1,3
2889               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2890             enddo
2891 C Compute the derivatives of uy
2892             do j=1,3
2893               do k=1,3
2894                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2895      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2896                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2897               enddo
2898               uyder(j,j,1)=uyder(j,j,1)-costh
2899               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2900             enddo
2901             do j=1,2
2902               do k=1,3
2903                 do l=1,3
2904                   uygrad(l,k,j,i)=uyder(l,k,j)
2905                   uzgrad(l,k,j,i)=uzder(l,k,j)
2906                 enddo
2907               enddo
2908             enddo
2909             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2910             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2911             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2912             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2913           endif
2914       enddo
2915       do i=1,nres-1
2916         vbld_inv_temp(1)=vbld_inv(i+1)
2917         if (i.lt.nres-1) then
2918           vbld_inv_temp(2)=vbld_inv(i+2)
2919           else
2920           vbld_inv_temp(2)=vbld_inv(i)
2921           endif
2922         do j=1,2
2923           do k=1,3
2924             do l=1,3
2925               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2926               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2927             enddo
2928           enddo
2929         enddo
2930       enddo
2931 #if defined(PARVEC) && defined(MPI)
2932       if (nfgtasks1.gt.1) then
2933         time00=MPI_Wtime()
2934 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2935 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2936 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2937         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2938      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2939      &   FG_COMM1,IERR)
2940         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2941      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2942      &   FG_COMM1,IERR)
2943         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2944      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2945      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2946         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2947      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2948      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2949         time_gather=time_gather+MPI_Wtime()-time00
2950       endif
2951 #endif
2952 #ifdef DEBUG
2953       if (fg_rank.eq.0) then
2954         write (iout,*) "Arrays UY and UZ"
2955         do i=1,nres-1
2956           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2957      &     (uz(k,i),k=1,3)
2958         enddo
2959       endif
2960 #endif
2961       return
2962       end
2963 C--------------------------------------------------------------------------
2964       subroutine set_matrices
2965       implicit real*8 (a-h,o-z)
2966       include 'DIMENSIONS'
2967 #ifdef MPI
2968       include "mpif.h"
2969       include "COMMON.SETUP"
2970       integer IERR
2971       integer status(MPI_STATUS_SIZE)
2972 #endif
2973       include 'COMMON.IOUNITS'
2974       include 'COMMON.GEO'
2975       include 'COMMON.VAR'
2976       include 'COMMON.LOCAL'
2977       include 'COMMON.CHAIN'
2978       include 'COMMON.DERIV'
2979       include 'COMMON.INTERACT'
2980       include 'COMMON.CORRMAT'
2981       include 'COMMON.TORSION'
2982       include 'COMMON.VECTORS'
2983       include 'COMMON.FFIELD'
2984       double precision auxvec(2),auxmat(2,2)
2985 C
2986 C Compute the virtual-bond-torsional-angle dependent quantities needed
2987 C to calculate the el-loc multibody terms of various order.
2988 C
2989 c      write(iout,*) 'nphi=',nphi,nres
2990 c      write(iout,*) "itype2loc",itype2loc
2991 #ifdef PARMAT
2992       do i=ivec_start+2,ivec_end+2
2993 #else
2994       do i=3,nres+1
2995 #endif
2996         ii=ireschain(i-2)
2997 c        write (iout,*) "i",i,i-2," ii",ii
2998         if (ii.eq.0) cycle
2999         innt=chain_border(1,ii)
3000         inct=chain_border(2,ii)
3001 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3002 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3003         if (i.gt. innt+2 .and. i.lt.inct+2) then
3004           iti = itype2loc(itype(i-2))
3005         else
3006           iti=nloctyp
3007         endif
3008 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3009         if (i.gt. innt+1 .and. i.lt.inct+1) then
3010           iti1 = itype2loc(itype(i-1))
3011         else
3012           iti1=nloctyp
3013         endif
3014 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3015 c     &  " iti1",itype(i-1),iti1
3016 #ifdef NEWCORR
3017         cost1=dcos(theta(i-1))
3018         sint1=dsin(theta(i-1))
3019         sint1sq=sint1*sint1
3020         sint1cub=sint1sq*sint1
3021         sint1cost1=2*sint1*cost1
3022 c        write (iout,*) "bnew1",i,iti
3023 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
3024 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3025 c        write (iout,*) "bnew2",i,iti
3026 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3027 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3028         do k=1,2
3029           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3030           b1(k,i-2)=sint1*b1k
3031           gtb1(k,i-2)=cost1*b1k-sint1sq*
3032      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3033           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3034           b2(k,i-2)=sint1*b2k
3035           gtb2(k,i-2)=cost1*b2k-sint1sq*
3036      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3037         enddo
3038         do k=1,2
3039           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3040           cc(1,k,i-2)=sint1sq*aux
3041           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3042      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3043           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3044           dd(1,k,i-2)=sint1sq*aux
3045           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3046      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3047         enddo
3048         cc(2,1,i-2)=cc(1,2,i-2)
3049         cc(2,2,i-2)=-cc(1,1,i-2)
3050         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3051         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3052         dd(2,1,i-2)=dd(1,2,i-2)
3053         dd(2,2,i-2)=-dd(1,1,i-2)
3054         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3055         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3056         do k=1,2
3057           do l=1,2
3058             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3059             EE(l,k,i-2)=sint1sq*aux
3060             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3061           enddo
3062         enddo
3063         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3064         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3065         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3066         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3067         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3068         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3069         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3070 c        b1tilde(1,i-2)=b1(1,i-2)
3071 c        b1tilde(2,i-2)=-b1(2,i-2)
3072 c        b2tilde(1,i-2)=b2(1,i-2)
3073 c        b2tilde(2,i-2)=-b2(2,i-2)
3074 #ifdef DEBUG
3075         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3076         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3077         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3078         write (iout,*) 'theta=', theta(i-1)
3079 #endif
3080 #else
3081         if (i.gt. innt+2 .and. i.lt.inct+2) then
3082 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3083           iti = itype2loc(itype(i-2))
3084         else
3085           iti=nloctyp
3086         endif
3087 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3088 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3089         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3090           iti1 = itype2loc(itype(i-1))
3091         else
3092           iti1=nloctyp
3093         endif
3094         b1(1,i-2)=b(3,iti)
3095         b1(2,i-2)=b(5,iti)
3096         b2(1,i-2)=b(2,iti)
3097         b2(2,i-2)=b(4,iti)
3098         do k=1,2
3099           do l=1,2
3100            CC(k,l,i-2)=ccold(k,l,iti)
3101            DD(k,l,i-2)=ddold(k,l,iti)
3102            EE(k,l,i-2)=eeold(k,l,iti)
3103            gtEE(k,l,i-2)=0.0d0
3104           enddo
3105         enddo
3106 #endif
3107         b1tilde(1,i-2)= b1(1,i-2)
3108         b1tilde(2,i-2)=-b1(2,i-2)
3109         b2tilde(1,i-2)= b2(1,i-2)
3110         b2tilde(2,i-2)=-b2(2,i-2)
3111 c
3112         Ctilde(1,1,i-2)= CC(1,1,i-2)
3113         Ctilde(1,2,i-2)= CC(1,2,i-2)
3114         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3115         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3116 c
3117         Dtilde(1,1,i-2)= DD(1,1,i-2)
3118         Dtilde(1,2,i-2)= DD(1,2,i-2)
3119         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3120         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3121 #ifdef DEBUG
3122         write(iout,*) "i",i," iti",iti
3123         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3124         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3125 #endif
3126       enddo
3127       mu=0.0d0
3128 #ifdef PARMAT
3129       do i=ivec_start+2,ivec_end+2
3130 #else
3131       do i=3,nres+1
3132 #endif
3133 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3134         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3135           sin1=dsin(phi(i))
3136           cos1=dcos(phi(i))
3137           sintab(i-2)=sin1
3138           costab(i-2)=cos1
3139           obrot(1,i-2)=cos1
3140           obrot(2,i-2)=sin1
3141           sin2=dsin(2*phi(i))
3142           cos2=dcos(2*phi(i))
3143           sintab2(i-2)=sin2
3144           costab2(i-2)=cos2
3145           obrot2(1,i-2)=cos2
3146           obrot2(2,i-2)=sin2
3147           Ug(1,1,i-2)=-cos1
3148           Ug(1,2,i-2)=-sin1
3149           Ug(2,1,i-2)=-sin1
3150           Ug(2,2,i-2)= cos1
3151           Ug2(1,1,i-2)=-cos2
3152           Ug2(1,2,i-2)=-sin2
3153           Ug2(2,1,i-2)=-sin2
3154           Ug2(2,2,i-2)= cos2
3155         else
3156           costab(i-2)=1.0d0
3157           sintab(i-2)=0.0d0
3158           obrot(1,i-2)=1.0d0
3159           obrot(2,i-2)=0.0d0
3160           obrot2(1,i-2)=0.0d0
3161           obrot2(2,i-2)=0.0d0
3162           Ug(1,1,i-2)=1.0d0
3163           Ug(1,2,i-2)=0.0d0
3164           Ug(2,1,i-2)=0.0d0
3165           Ug(2,2,i-2)=1.0d0
3166           Ug2(1,1,i-2)=0.0d0
3167           Ug2(1,2,i-2)=0.0d0
3168           Ug2(2,1,i-2)=0.0d0
3169           Ug2(2,2,i-2)=0.0d0
3170         endif
3171         if (i .gt. 3) then
3172           obrot_der(1,i-2)=-sin1
3173           obrot_der(2,i-2)= cos1
3174           Ugder(1,1,i-2)= sin1
3175           Ugder(1,2,i-2)=-cos1
3176           Ugder(2,1,i-2)=-cos1
3177           Ugder(2,2,i-2)=-sin1
3178           dwacos2=cos2+cos2
3179           dwasin2=sin2+sin2
3180           obrot2_der(1,i-2)=-dwasin2
3181           obrot2_der(2,i-2)= dwacos2
3182           Ug2der(1,1,i-2)= dwasin2
3183           Ug2der(1,2,i-2)=-dwacos2
3184           Ug2der(2,1,i-2)=-dwacos2
3185           Ug2der(2,2,i-2)=-dwasin2
3186         else
3187           obrot_der(1,i-2)=0.0d0
3188           obrot_der(2,i-2)=0.0d0
3189           Ugder(1,1,i-2)=0.0d0
3190           Ugder(1,2,i-2)=0.0d0
3191           Ugder(2,1,i-2)=0.0d0
3192           Ugder(2,2,i-2)=0.0d0
3193           obrot2_der(1,i-2)=0.0d0
3194           obrot2_der(2,i-2)=0.0d0
3195           Ug2der(1,1,i-2)=0.0d0
3196           Ug2der(1,2,i-2)=0.0d0
3197           Ug2der(2,1,i-2)=0.0d0
3198           Ug2der(2,2,i-2)=0.0d0
3199         endif
3200 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3201 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3202         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3203           iti = itype2loc(itype(i-2))
3204         else
3205           iti=nloctyp
3206         endif
3207 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3208         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3209           iti1 = itype2loc(itype(i-1))
3210         else
3211           iti1=nloctyp
3212         endif
3213 cd        write (iout,*) '*******i',i,' iti1',iti
3214 cd        write (iout,*) 'b1',b1(:,iti)
3215 cd        write (iout,*) 'b2',b2(:,iti)
3216 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3217 c        if (i .gt. iatel_s+2) then
3218         if (i .gt. nnt+2) then
3219           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3220 #ifdef NEWCORR
3221           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3222 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3223 #endif
3224 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3225 c     &    EE(1,2,iti),EE(2,2,i)
3226           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3227           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3228 c          write(iout,*) "Macierz EUG",
3229 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3230 c     &    eug(2,2,i-2)
3231 #ifdef FOURBODY
3232           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3233      &    then
3234           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3235           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3236           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3237           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3238           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3239           endif
3240 #endif
3241         else
3242           do k=1,2
3243             Ub2(k,i-2)=0.0d0
3244             Ctobr(k,i-2)=0.0d0
3245             Dtobr2(k,i-2)=0.0d0
3246             do l=1,2
3247               EUg(l,k,i-2)=0.0d0
3248               CUg(l,k,i-2)=0.0d0
3249               DUg(l,k,i-2)=0.0d0
3250               DtUg2(l,k,i-2)=0.0d0
3251             enddo
3252           enddo
3253         endif
3254         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3255         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3256         do k=1,2
3257           muder(k,i-2)=Ub2der(k,i-2)
3258         enddo
3259 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3260         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3261           if (itype(i-1).le.ntyp) then
3262             iti1 = itype2loc(itype(i-1))
3263           else
3264             iti1=nloctyp
3265           endif
3266         else
3267           iti1=nloctyp
3268         endif
3269         do k=1,2
3270           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3271 c          mu(k,i-2)=b1(k,i-1)
3272 c          mu(k,i-2)=Ub2(k,i-2)
3273         enddo
3274 #ifdef MUOUT
3275         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3276      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3277      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3278      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3279      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3280      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3281 #endif
3282 cd        write (iout,*) 'mu1',mu1(:,i-2)
3283 cd        write (iout,*) 'mu2',mu2(:,i-2)
3284 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3285 #ifdef FOURBODY
3286         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3287      &  then
3288         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3289         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3290         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3291         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3292         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3293 C Vectors and matrices dependent on a single virtual-bond dihedral.
3294         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3295         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3296         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3297         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3298         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3299         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3300         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3301         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3302         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3303         endif
3304 #endif
3305       enddo
3306 #ifdef FOURBODY
3307 C Matrices dependent on two consecutive virtual-bond dihedrals.
3308 C The order of matrices is from left to right.
3309       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3310      &then
3311 c      do i=max0(ivec_start,2),ivec_end
3312       do i=2,nres-1
3313         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3314         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3315         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3316         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3317         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3318         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3319         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3320         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3321       enddo
3322       endif
3323 #endif
3324 #if defined(MPI) && defined(PARMAT)
3325 #ifdef DEBUG
3326 c      if (fg_rank.eq.0) then
3327         write (iout,*) "Arrays UG and UGDER before GATHER"
3328         do i=1,nres-1
3329           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3330      &     ((ug(l,k,i),l=1,2),k=1,2),
3331      &     ((ugder(l,k,i),l=1,2),k=1,2)
3332         enddo
3333         write (iout,*) "Arrays UG2 and UG2DER"
3334         do i=1,nres-1
3335           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3336      &     ((ug2(l,k,i),l=1,2),k=1,2),
3337      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3338         enddo
3339         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3340         do i=1,nres-1
3341           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3342      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3343      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3344         enddo
3345         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3346         do i=1,nres-1
3347           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3348      &     costab(i),sintab(i),costab2(i),sintab2(i)
3349         enddo
3350         write (iout,*) "Array MUDER"
3351         do i=1,nres-1
3352           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3353         enddo
3354 c      endif
3355 #endif
3356       if (nfgtasks.gt.1) then
3357         time00=MPI_Wtime()
3358 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3359 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3360 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3361 #ifdef MATGATHER
3362         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3363      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3364      &   FG_COMM1,IERR)
3365         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3366      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3367      &   FG_COMM1,IERR)
3368         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3369      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3370      &   FG_COMM1,IERR)
3371         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3372      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3373      &   FG_COMM1,IERR)
3374         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3375      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3376      &   FG_COMM1,IERR)
3377         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3378      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3379      &   FG_COMM1,IERR)
3380         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3381      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3382      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3383         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3384      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3385      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3386         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3387      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3388      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3389         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3390      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3391      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3392 #ifdef FOURBODY
3393         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3394      &  then
3395         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3396      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3397      &   FG_COMM1,IERR)
3398         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3399      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3400      &   FG_COMM1,IERR)
3401         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3402      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3403      &   FG_COMM1,IERR)
3404        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3405      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3406      &   FG_COMM1,IERR)
3407         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3408      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3409      &   FG_COMM1,IERR)
3410         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3411      &   ivec_count(fg_rank1),
3412      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3413      &   FG_COMM1,IERR)
3414         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3415      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3416      &   FG_COMM1,IERR)
3417         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3418      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3419      &   FG_COMM1,IERR)
3420         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3421      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3422      &   FG_COMM1,IERR)
3423         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3424      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3425      &   FG_COMM1,IERR)
3426         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3427      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3428      &   FG_COMM1,IERR)
3429         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3430      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3431      &   FG_COMM1,IERR)
3432         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3433      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3434      &   FG_COMM1,IERR)
3435         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3436      &   ivec_count(fg_rank1),
3437      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3438      &   FG_COMM1,IERR)
3439         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3440      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3441      &   FG_COMM1,IERR)
3442        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3443      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3444      &   FG_COMM1,IERR)
3445         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3446      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3447      &   FG_COMM1,IERR)
3448        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3449      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3450      &   FG_COMM1,IERR)
3451         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3452      &   ivec_count(fg_rank1),
3453      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3454      &   FG_COMM1,IERR)
3455         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3456      &   ivec_count(fg_rank1),
3457      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3458      &   FG_COMM1,IERR)
3459         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3460      &   ivec_count(fg_rank1),
3461      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3462      &   MPI_MAT2,FG_COMM1,IERR)
3463         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3464      &   ivec_count(fg_rank1),
3465      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3466      &   MPI_MAT2,FG_COMM1,IERR)
3467         endif
3468 #endif
3469 #else
3470 c Passes matrix info through the ring
3471       isend=fg_rank1
3472       irecv=fg_rank1-1
3473       if (irecv.lt.0) irecv=nfgtasks1-1
3474       iprev=irecv
3475       inext=fg_rank1+1
3476       if (inext.ge.nfgtasks1) inext=0
3477       do i=1,nfgtasks1-1
3478 c        write (iout,*) "isend",isend," irecv",irecv
3479 c        call flush(iout)
3480         lensend=lentyp(isend)
3481         lenrecv=lentyp(irecv)
3482 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3483 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3484 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3485 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3486 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3487 c        write (iout,*) "Gather ROTAT1"
3488 c        call flush(iout)
3489 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3490 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3491 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3492 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3493 c        write (iout,*) "Gather ROTAT2"
3494 c        call flush(iout)
3495         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3496      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3497      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3498      &   iprev,4400+irecv,FG_COMM,status,IERR)
3499 c        write (iout,*) "Gather ROTAT_OLD"
3500 c        call flush(iout)
3501         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3502      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3503      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3504      &   iprev,5500+irecv,FG_COMM,status,IERR)
3505 c        write (iout,*) "Gather PRECOMP11"
3506 c        call flush(iout)
3507         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3508      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3509      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3510      &   iprev,6600+irecv,FG_COMM,status,IERR)
3511 c        write (iout,*) "Gather PRECOMP12"
3512 c        call flush(iout)
3513 #ifdef FOURBODY
3514         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3515      &  then
3516         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3517      &   MPI_ROTAT2(lensend),inext,7700+isend,
3518      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3519      &   iprev,7700+irecv,FG_COMM,status,IERR)
3520 c        write (iout,*) "Gather PRECOMP21"
3521 c        call flush(iout)
3522         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3523      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3524      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3525      &   iprev,8800+irecv,FG_COMM,status,IERR)
3526 c        write (iout,*) "Gather PRECOMP22"
3527 c        call flush(iout)
3528         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3529      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3530      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3531      &   MPI_PRECOMP23(lenrecv),
3532      &   iprev,9900+irecv,FG_COMM,status,IERR)
3533 #endif
3534 c        write (iout,*) "Gather PRECOMP23"
3535 c        call flush(iout)
3536         endif
3537         isend=irecv
3538         irecv=irecv-1
3539         if (irecv.lt.0) irecv=nfgtasks1-1
3540       enddo
3541 #endif
3542         time_gather=time_gather+MPI_Wtime()-time00
3543       endif
3544 #ifdef DEBUG
3545 c      if (fg_rank.eq.0) then
3546         write (iout,*) "Arrays UG and UGDER"
3547         do i=1,nres-1
3548           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3549      &     ((ug(l,k,i),l=1,2),k=1,2),
3550      &     ((ugder(l,k,i),l=1,2),k=1,2)
3551         enddo
3552         write (iout,*) "Arrays UG2 and UG2DER"
3553         do i=1,nres-1
3554           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3555      &     ((ug2(l,k,i),l=1,2),k=1,2),
3556      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3557         enddo
3558         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3559         do i=1,nres-1
3560           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3561      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3562      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3563         enddo
3564         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3565         do i=1,nres-1
3566           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3567      &     costab(i),sintab(i),costab2(i),sintab2(i)
3568         enddo
3569         write (iout,*) "Array MUDER"
3570         do i=1,nres-1
3571           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3572         enddo
3573 c      endif
3574 #endif
3575 #endif
3576 cd      do i=1,nres
3577 cd        iti = itype2loc(itype(i))
3578 cd        write (iout,*) i
3579 cd        do j=1,2
3580 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3581 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3582 cd        enddo
3583 cd      enddo
3584       return
3585       end
3586 C-----------------------------------------------------------------------------
3587       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3588 C
3589 C This subroutine calculates the average interaction energy and its gradient
3590 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3591 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3592 C The potential depends both on the distance of peptide-group centers and on
3593 C the orientation of the CA-CA virtual bonds.
3594 C
3595       implicit real*8 (a-h,o-z)
3596 #ifdef MPI
3597       include 'mpif.h'
3598 #endif
3599       include 'DIMENSIONS'
3600       include 'COMMON.CONTROL'
3601       include 'COMMON.SETUP'
3602       include 'COMMON.IOUNITS'
3603       include 'COMMON.GEO'
3604       include 'COMMON.VAR'
3605       include 'COMMON.LOCAL'
3606       include 'COMMON.CHAIN'
3607       include 'COMMON.DERIV'
3608       include 'COMMON.INTERACT'
3609 #ifdef FOURBODY
3610       include 'COMMON.CONTACTS'
3611       include 'COMMON.CONTMAT'
3612 #endif
3613       include 'COMMON.CORRMAT'
3614       include 'COMMON.TORSION'
3615       include 'COMMON.VECTORS'
3616       include 'COMMON.FFIELD'
3617       include 'COMMON.TIME1'
3618       include 'COMMON.SPLITELE'
3619       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3620      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3621       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3622      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3623       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3624      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3625      &    num_conti,j1,j2
3626 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3627 #ifdef MOMENT
3628       double precision scal_el /1.0d0/
3629 #else
3630       double precision scal_el /0.5d0/
3631 #endif
3632 C 12/13/98
3633 C 13-go grudnia roku pamietnego...
3634       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3635      &                   0.0d0,1.0d0,0.0d0,
3636      &                   0.0d0,0.0d0,1.0d0/
3637 cd      write(iout,*) 'In EELEC'
3638 cd      do i=1,nloctyp
3639 cd        write(iout,*) 'Type',i
3640 cd        write(iout,*) 'B1',B1(:,i)
3641 cd        write(iout,*) 'B2',B2(:,i)
3642 cd        write(iout,*) 'CC',CC(:,:,i)
3643 cd        write(iout,*) 'DD',DD(:,:,i)
3644 cd        write(iout,*) 'EE',EE(:,:,i)
3645 cd      enddo
3646 cd      call check_vecgrad
3647 cd      stop
3648       if (icheckgrad.eq.1) then
3649         do i=1,nres-1
3650           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3651           do k=1,3
3652             dc_norm(k,i)=dc(k,i)*fac
3653           enddo
3654 c          write (iout,*) 'i',i,' fac',fac
3655         enddo
3656       endif
3657       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3658      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3659      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3660 c        call vec_and_deriv
3661 #ifdef TIMING
3662         time01=MPI_Wtime()
3663 #endif
3664         call set_matrices
3665 #ifdef TIMING
3666         time_mat=time_mat+MPI_Wtime()-time01
3667 #endif
3668       endif
3669 cd      do i=1,nres-1
3670 cd        write (iout,*) 'i=',i
3671 cd        do k=1,3
3672 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3673 cd        enddo
3674 cd        do k=1,3
3675 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3676 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3677 cd        enddo
3678 cd      enddo
3679       t_eelecij=0.0d0
3680       ees=0.0D0
3681       evdw1=0.0D0
3682       eel_loc=0.0d0
3683       eello_turn3=0.0d0
3684       eello_turn4=0.0d0
3685       ind=0
3686 #ifdef FOURBODY
3687       do i=1,nres
3688         num_cont_hb(i)=0
3689       enddo
3690 #endif
3691 cd      print '(a)','Enter EELEC'
3692 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3693       do i=1,nres
3694         gel_loc_loc(i)=0.0d0
3695         gcorr_loc(i)=0.0d0
3696       enddo
3697 c
3698 c
3699 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3700 C
3701 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3702 C
3703 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3704       do i=iturn3_start,iturn3_end
3705 c        if (i.le.1) cycle
3706 C        write(iout,*) "tu jest i",i
3707         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3708 C changes suggested by Ana to avoid out of bounds
3709 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3710 c     & .or.((i+4).gt.nres)
3711 c     & .or.((i-1).le.0)
3712 C end of changes by Ana
3713      &  .or. itype(i+2).eq.ntyp1
3714      &  .or. itype(i+3).eq.ntyp1) cycle
3715 C Adam: Instructions below will switch off existing interactions
3716 c        if(i.gt.1)then
3717 c          if(itype(i-1).eq.ntyp1)cycle
3718 c        end if
3719 c        if(i.LT.nres-3)then
3720 c          if (itype(i+4).eq.ntyp1) cycle
3721 c        end if
3722         dxi=dc(1,i)
3723         dyi=dc(2,i)
3724         dzi=dc(3,i)
3725         dx_normi=dc_norm(1,i)
3726         dy_normi=dc_norm(2,i)
3727         dz_normi=dc_norm(3,i)
3728         xmedi=c(1,i)+0.5d0*dxi
3729         ymedi=c(2,i)+0.5d0*dyi
3730         zmedi=c(3,i)+0.5d0*dzi
3731           xmedi=mod(xmedi,boxxsize)
3732           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3733           ymedi=mod(ymedi,boxysize)
3734           if (ymedi.lt.0) ymedi=ymedi+boxysize
3735           zmedi=mod(zmedi,boxzsize)
3736           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3737         num_conti=0
3738         call eelecij(i,i+2,ees,evdw1,eel_loc)
3739         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3740 #ifdef FOURBODY
3741         num_cont_hb(i)=num_conti
3742 #endif
3743       enddo
3744       do i=iturn4_start,iturn4_end
3745         if (i.lt.1) cycle
3746         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3747 C changes suggested by Ana to avoid out of bounds
3748 c     & .or.((i+5).gt.nres)
3749 c     & .or.((i-1).le.0)
3750 C end of changes suggested by Ana
3751      &    .or. itype(i+3).eq.ntyp1
3752      &    .or. itype(i+4).eq.ntyp1
3753 c     &    .or. itype(i+5).eq.ntyp1
3754 c     &    .or. itype(i).eq.ntyp1
3755 c     &    .or. itype(i-1).eq.ntyp1
3756      &                             ) cycle
3757         dxi=dc(1,i)
3758         dyi=dc(2,i)
3759         dzi=dc(3,i)
3760         dx_normi=dc_norm(1,i)
3761         dy_normi=dc_norm(2,i)
3762         dz_normi=dc_norm(3,i)
3763         xmedi=c(1,i)+0.5d0*dxi
3764         ymedi=c(2,i)+0.5d0*dyi
3765         zmedi=c(3,i)+0.5d0*dzi
3766 C Return atom into box, boxxsize is size of box in x dimension
3767 c  194   continue
3768 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3769 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3770 C Condition for being inside the proper box
3771 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3772 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3773 c        go to 194
3774 c        endif
3775 c  195   continue
3776 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3777 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3778 C Condition for being inside the proper box
3779 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3780 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3781 c        go to 195
3782 c        endif
3783 c  196   continue
3784 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3785 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3786 C Condition for being inside the proper box
3787 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3788 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3789 c        go to 196
3790 c        endif
3791           xmedi=mod(xmedi,boxxsize)
3792           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3793           ymedi=mod(ymedi,boxysize)
3794           if (ymedi.lt.0) ymedi=ymedi+boxysize
3795           zmedi=mod(zmedi,boxzsize)
3796           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3797
3798 #ifdef FOURBODY
3799         num_conti=num_cont_hb(i)
3800 #endif
3801 c        write(iout,*) "JESTEM W PETLI"
3802         call eelecij(i,i+3,ees,evdw1,eel_loc)
3803         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3804      &   call eturn4(i,eello_turn4)
3805 #ifdef FOURBODY
3806         num_cont_hb(i)=num_conti
3807 #endif
3808       enddo   ! i
3809 C Loop over all neighbouring boxes
3810 C      do xshift=-1,1
3811 C      do yshift=-1,1
3812 C      do zshift=-1,1
3813 c
3814 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3815 c
3816 CTU KURWA
3817       do i=iatel_s,iatel_e
3818 C        do i=75,75
3819 c        if (i.le.1) cycle
3820         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3821 C changes suggested by Ana to avoid out of bounds
3822 c     & .or.((i+2).gt.nres)
3823 c     & .or.((i-1).le.0)
3824 C end of changes by Ana
3825 c     &  .or. itype(i+2).eq.ntyp1
3826 c     &  .or. itype(i-1).eq.ntyp1
3827      &                ) cycle
3828         dxi=dc(1,i)
3829         dyi=dc(2,i)
3830         dzi=dc(3,i)
3831         dx_normi=dc_norm(1,i)
3832         dy_normi=dc_norm(2,i)
3833         dz_normi=dc_norm(3,i)
3834         xmedi=c(1,i)+0.5d0*dxi
3835         ymedi=c(2,i)+0.5d0*dyi
3836         zmedi=c(3,i)+0.5d0*dzi
3837           xmedi=mod(xmedi,boxxsize)
3838           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3839           ymedi=mod(ymedi,boxysize)
3840           if (ymedi.lt.0) ymedi=ymedi+boxysize
3841           zmedi=mod(zmedi,boxzsize)
3842           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3843 C          xmedi=xmedi+xshift*boxxsize
3844 C          ymedi=ymedi+yshift*boxysize
3845 C          zmedi=zmedi+zshift*boxzsize
3846
3847 C Return tom into box, boxxsize is size of box in x dimension
3848 c  164   continue
3849 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3850 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3851 C Condition for being inside the proper box
3852 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3853 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3854 c        go to 164
3855 c        endif
3856 c  165   continue
3857 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3858 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3859 C Condition for being inside the proper box
3860 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3861 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3862 c        go to 165
3863 c        endif
3864 c  166   continue
3865 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3866 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3867 cC Condition for being inside the proper box
3868 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3869 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3870 c        go to 166
3871 c        endif
3872
3873 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3874 #ifdef FOURBODY
3875         num_conti=num_cont_hb(i)
3876 #endif
3877 C I TU KURWA
3878         do j=ielstart(i),ielend(i)
3879 C          do j=16,17
3880 C          write (iout,*) i,j
3881 C         if (j.le.1) cycle
3882           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3883 C changes suggested by Ana to avoid out of bounds
3884 c     & .or.((j+2).gt.nres)
3885 c     & .or.((j-1).le.0)
3886 C end of changes by Ana
3887 c     & .or.itype(j+2).eq.ntyp1
3888 c     & .or.itype(j-1).eq.ntyp1
3889      &) cycle
3890           call eelecij(i,j,ees,evdw1,eel_loc)
3891         enddo ! j
3892 #ifdef FOURBODY
3893         num_cont_hb(i)=num_conti
3894 #endif
3895       enddo   ! i
3896 C     enddo   ! zshift
3897 C      enddo   ! yshift
3898 C      enddo   ! xshift
3899
3900 c      write (iout,*) "Number of loop steps in EELEC:",ind
3901 cd      do i=1,nres
3902 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3903 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3904 cd      enddo
3905 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3906 ccc      eel_loc=eel_loc+eello_turn3
3907 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3908       return
3909       end
3910 C-------------------------------------------------------------------------------
3911       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3912       implicit real*8 (a-h,o-z)
3913       include 'DIMENSIONS'
3914 #ifdef MPI
3915       include "mpif.h"
3916 #endif
3917       include 'COMMON.CONTROL'
3918       include 'COMMON.IOUNITS'
3919       include 'COMMON.GEO'
3920       include 'COMMON.VAR'
3921       include 'COMMON.LOCAL'
3922       include 'COMMON.CHAIN'
3923       include 'COMMON.DERIV'
3924       include 'COMMON.INTERACT'
3925 #ifdef FOURBODY
3926       include 'COMMON.CONTACTS'
3927       include 'COMMON.CONTMAT'
3928 #endif
3929       include 'COMMON.CORRMAT'
3930       include 'COMMON.TORSION'
3931       include 'COMMON.VECTORS'
3932       include 'COMMON.FFIELD'
3933       include 'COMMON.TIME1'
3934       include 'COMMON.SPLITELE'
3935       include 'COMMON.SHIELD'
3936       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3937      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3938       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3939      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3940      &    gmuij2(4),gmuji2(4)
3941       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3942      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3943      &    num_conti,j1,j2
3944 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3945 #ifdef MOMENT
3946       double precision scal_el /1.0d0/
3947 #else
3948       double precision scal_el /0.5d0/
3949 #endif
3950 C 12/13/98
3951 C 13-go grudnia roku pamietnego...
3952       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3953      &                   0.0d0,1.0d0,0.0d0,
3954      &                   0.0d0,0.0d0,1.0d0/
3955        integer xshift,yshift,zshift
3956 c          time00=MPI_Wtime()
3957 cd      write (iout,*) "eelecij",i,j
3958 c          ind=ind+1
3959           iteli=itel(i)
3960           itelj=itel(j)
3961           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3962           aaa=app(iteli,itelj)
3963           bbb=bpp(iteli,itelj)
3964           ael6i=ael6(iteli,itelj)
3965           ael3i=ael3(iteli,itelj)
3966           dxj=dc(1,j)
3967           dyj=dc(2,j)
3968           dzj=dc(3,j)
3969           dx_normj=dc_norm(1,j)
3970           dy_normj=dc_norm(2,j)
3971           dz_normj=dc_norm(3,j)
3972 C          xj=c(1,j)+0.5D0*dxj-xmedi
3973 C          yj=c(2,j)+0.5D0*dyj-ymedi
3974 C          zj=c(3,j)+0.5D0*dzj-zmedi
3975           xj=c(1,j)+0.5D0*dxj
3976           yj=c(2,j)+0.5D0*dyj
3977           zj=c(3,j)+0.5D0*dzj
3978           xj=mod(xj,boxxsize)
3979           if (xj.lt.0) xj=xj+boxxsize
3980           yj=mod(yj,boxysize)
3981           if (yj.lt.0) yj=yj+boxysize
3982           zj=mod(zj,boxzsize)
3983           if (zj.lt.0) zj=zj+boxzsize
3984           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3985       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3986       xj_safe=xj
3987       yj_safe=yj
3988       zj_safe=zj
3989       isubchap=0
3990       do xshift=-1,1
3991       do yshift=-1,1
3992       do zshift=-1,1
3993           xj=xj_safe+xshift*boxxsize
3994           yj=yj_safe+yshift*boxysize
3995           zj=zj_safe+zshift*boxzsize
3996           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3997           if(dist_temp.lt.dist_init) then
3998             dist_init=dist_temp
3999             xj_temp=xj
4000             yj_temp=yj
4001             zj_temp=zj
4002             isubchap=1
4003           endif
4004        enddo
4005        enddo
4006        enddo
4007        if (isubchap.eq.1) then
4008           xj=xj_temp-xmedi
4009           yj=yj_temp-ymedi
4010           zj=zj_temp-zmedi
4011        else
4012           xj=xj_safe-xmedi
4013           yj=yj_safe-ymedi
4014           zj=zj_safe-zmedi
4015        endif
4016 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4017 c  174   continue
4018 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4019 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4020 C Condition for being inside the proper box
4021 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4022 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4023 c        go to 174
4024 c        endif
4025 c  175   continue
4026 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4027 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4028 C Condition for being inside the proper box
4029 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4030 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4031 c        go to 175
4032 c        endif
4033 c  176   continue
4034 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4035 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4036 C Condition for being inside the proper box
4037 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4038 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4039 c        go to 176
4040 c        endif
4041 C        endif !endPBC condintion
4042 C        xj=xj-xmedi
4043 C        yj=yj-ymedi
4044 C        zj=zj-zmedi
4045           rij=xj*xj+yj*yj+zj*zj
4046
4047             sss=sscale(sqrt(rij),r_cut_int)
4048             sssgrad=sscagrad(sqrt(rij),r_cut_int)
4049 c            if (sss.gt.0.0d0) then
4050           rrmij=1.0D0/rij
4051           rij=dsqrt(rij)
4052           rmij=1.0D0/rij
4053           r3ij=rrmij*rmij
4054           r6ij=r3ij*r3ij
4055           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4056           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4057           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4058           fac=cosa-3.0D0*cosb*cosg
4059           ev1=aaa*r6ij*r6ij
4060 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4061           if (j.eq.i+2) ev1=scal_el*ev1
4062           ev2=bbb*r6ij
4063           fac3=ael6i*r6ij
4064           fac4=ael3i*r3ij
4065           evdwij=(ev1+ev2)
4066           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4067           el2=fac4*fac
4068 C MARYSIA
4069 C          eesij=(el1+el2)
4070 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4071           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4072           if (shield_mode.gt.0) then
4073 C          fac_shield(i)=0.4
4074 C          fac_shield(j)=0.6
4075           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4076           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4077           eesij=(el1+el2)
4078           ees=ees+eesij
4079           else
4080           fac_shield(i)=1.0
4081           fac_shield(j)=1.0
4082           eesij=(el1+el2)
4083           ees=ees+eesij
4084           endif
4085           evdw1=evdw1+evdwij*sss
4086 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4087 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4088 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4089 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4090
4091           if (energy_dec) then
4092               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4093      &'evdw1',i,j,evdwij
4094      &,iteli,itelj,aaa,evdw1,sss
4095               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4096      &fac_shield(i),fac_shield(j)
4097           endif
4098
4099 C
4100 C Calculate contributions to the Cartesian gradient.
4101 C
4102 #ifdef SPLITELE
4103           facvdw=-6*rrmij*(ev1+evdwij)*sss
4104           facel=-3*rrmij*(el1+eesij)
4105           fac1=fac
4106           erij(1)=xj*rmij
4107           erij(2)=yj*rmij
4108           erij(3)=zj*rmij
4109
4110 *
4111 * Radial derivatives. First process both termini of the fragment (i,j)
4112 *
4113           ggg(1)=facel*xj
4114           ggg(2)=facel*yj
4115           ggg(3)=facel*zj
4116           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4117      &  (shield_mode.gt.0)) then
4118 C          print *,i,j
4119           do ilist=1,ishield_list(i)
4120            iresshield=shield_list(ilist,i)
4121            do k=1,3
4122            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4123      &      *2.0
4124            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4125      &              rlocshield
4126      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4127             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4128 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4129 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4130 C             if (iresshield.gt.i) then
4131 C               do ishi=i+1,iresshield-1
4132 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4133 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4134 C
4135 C              enddo
4136 C             else
4137 C               do ishi=iresshield,i
4138 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4139 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4140 C
4141 C               enddo
4142 C              endif
4143            enddo
4144           enddo
4145           do ilist=1,ishield_list(j)
4146            iresshield=shield_list(ilist,j)
4147            do k=1,3
4148            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4149      &     *2.0
4150            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4151      &              rlocshield
4152      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4153            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4154
4155 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4156 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4157 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4158 C             if (iresshield.gt.j) then
4159 C               do ishi=j+1,iresshield-1
4160 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4161 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4162 C
4163 C               enddo
4164 C            else
4165 C               do ishi=iresshield,j
4166 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4167 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4168 C               enddo
4169 C              endif
4170            enddo
4171           enddo
4172
4173           do k=1,3
4174             gshieldc(k,i)=gshieldc(k,i)+
4175      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4176             gshieldc(k,j)=gshieldc(k,j)+
4177      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4178             gshieldc(k,i-1)=gshieldc(k,i-1)+
4179      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4180             gshieldc(k,j-1)=gshieldc(k,j-1)+
4181      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4182
4183            enddo
4184            endif
4185 c          do k=1,3
4186 c            ghalf=0.5D0*ggg(k)
4187 c            gelc(k,i)=gelc(k,i)+ghalf
4188 c            gelc(k,j)=gelc(k,j)+ghalf
4189 c          enddo
4190 c 9/28/08 AL Gradient compotents will be summed only at the end
4191 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4192           do k=1,3
4193             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4194 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4195             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4196 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4197 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4198 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4199 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4200 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4201           enddo
4202 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4203
4204 *
4205 * Loop over residues i+1 thru j-1.
4206 *
4207 cgrad          do k=i+1,j-1
4208 cgrad            do l=1,3
4209 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4210 cgrad            enddo
4211 cgrad          enddo
4212           if (sss.gt.0.0) then
4213           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4214           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4215           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4216           else
4217           ggg(1)=0.0
4218           ggg(2)=0.0
4219           ggg(3)=0.0
4220           endif
4221 c          do k=1,3
4222 c            ghalf=0.5D0*ggg(k)
4223 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4224 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4225 c          enddo
4226 c 9/28/08 AL Gradient compotents will be summed only at the end
4227           do k=1,3
4228             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4229             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4230           enddo
4231 *
4232 * Loop over residues i+1 thru j-1.
4233 *
4234 cgrad          do k=i+1,j-1
4235 cgrad            do l=1,3
4236 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4237 cgrad            enddo
4238 cgrad          enddo
4239 #else
4240 C MARYSIA
4241           facvdw=(ev1+evdwij)*sss
4242           facel=(el1+eesij)
4243           fac1=fac
4244           fac=-3*rrmij*(facvdw+facvdw+facel)
4245           erij(1)=xj*rmij
4246           erij(2)=yj*rmij
4247           erij(3)=zj*rmij
4248 *
4249 * Radial derivatives. First process both termini of the fragment (i,j)
4250 *
4251           ggg(1)=fac*xj
4252 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4253           ggg(2)=fac*yj
4254 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4255           ggg(3)=fac*zj
4256 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4257 c          do k=1,3
4258 c            ghalf=0.5D0*ggg(k)
4259 c            gelc(k,i)=gelc(k,i)+ghalf
4260 c            gelc(k,j)=gelc(k,j)+ghalf
4261 c          enddo
4262 c 9/28/08 AL Gradient compotents will be summed only at the end
4263           do k=1,3
4264             gelc_long(k,j)=gelc(k,j)+ggg(k)
4265             gelc_long(k,i)=gelc(k,i)-ggg(k)
4266           enddo
4267 *
4268 * Loop over residues i+1 thru j-1.
4269 *
4270 cgrad          do k=i+1,j-1
4271 cgrad            do l=1,3
4272 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4273 cgrad            enddo
4274 cgrad          enddo
4275 c 9/28/08 AL Gradient compotents will be summed only at the end
4276           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4277           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4278           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4279           do k=1,3
4280             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4281             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4282           enddo
4283 #endif
4284 *
4285 * Angular part
4286 *
4287           ecosa=2.0D0*fac3*fac1+fac4
4288           fac4=-3.0D0*fac4
4289           fac3=-6.0D0*fac3
4290           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4291           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4292           do k=1,3
4293             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4294             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4295           enddo
4296 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4297 cd   &          (dcosg(k),k=1,3)
4298           do k=1,3
4299             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4300      &      fac_shield(i)**2*fac_shield(j)**2
4301           enddo
4302 c          do k=1,3
4303 c            ghalf=0.5D0*ggg(k)
4304 c            gelc(k,i)=gelc(k,i)+ghalf
4305 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4306 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4307 c            gelc(k,j)=gelc(k,j)+ghalf
4308 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4309 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4310 c          enddo
4311 cgrad          do k=i+1,j-1
4312 cgrad            do l=1,3
4313 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4314 cgrad            enddo
4315 cgrad          enddo
4316 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4317           do k=1,3
4318             gelc(k,i)=gelc(k,i)
4319      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4320      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4321      &           *fac_shield(i)**2*fac_shield(j)**2
4322             gelc(k,j)=gelc(k,j)
4323      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4324      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4325      &           *fac_shield(i)**2*fac_shield(j)**2
4326             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4327             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4328           enddo
4329 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4330
4331 C MARYSIA
4332 c          endif !sscale
4333           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4334      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4335      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4336 C
4337 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4338 C   energy of a peptide unit is assumed in the form of a second-order
4339 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4340 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4341 C   are computed for EVERY pair of non-contiguous peptide groups.
4342 C
4343
4344           if (j.lt.nres-1) then
4345             j1=j+1
4346             j2=j-1
4347           else
4348             j1=j-1
4349             j2=j-2
4350           endif
4351           kkk=0
4352           lll=0
4353           do k=1,2
4354             do l=1,2
4355               kkk=kkk+1
4356               muij(kkk)=mu(k,i)*mu(l,j)
4357 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4358 #ifdef NEWCORR
4359              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4360 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4361              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4362              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4363 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4364              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4365 #endif
4366             enddo
4367           enddo
4368 #ifdef DEBUG
4369           write (iout,*) 'EELEC: i',i,' j',j
4370           write (iout,*) 'j',j,' j1',j1,' j2',j2
4371           write(iout,*) 'muij',muij
4372 #endif
4373           ury=scalar(uy(1,i),erij)
4374           urz=scalar(uz(1,i),erij)
4375           vry=scalar(uy(1,j),erij)
4376           vrz=scalar(uz(1,j),erij)
4377           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4378           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4379           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4380           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4381           fac=dsqrt(-ael6i)*r3ij
4382 #ifdef DEBUG
4383           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4384           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4385      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4386      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4387      &      "uzvz",scalar(uz(1,i),uz(1,j))
4388           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4389           write (iout,*) "fac",fac
4390 #endif
4391           a22=a22*fac
4392           a23=a23*fac
4393           a32=a32*fac
4394           a33=a33*fac
4395 #ifdef DEBUG
4396           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4397 #endif
4398 #undef DEBUG
4399 cd          write (iout,'(4i5,4f10.5)')
4400 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4401 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4402 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4403 cd     &      uy(:,j),uz(:,j)
4404 cd          write (iout,'(4f10.5)')
4405 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4406 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4407 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4408 cd           write (iout,'(9f10.5/)')
4409 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4410 C Derivatives of the elements of A in virtual-bond vectors
4411           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4412           do k=1,3
4413             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4414             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4415             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4416             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4417             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4418             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4419             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4420             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4421             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4422             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4423             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4424             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4425           enddo
4426 C Compute radial contributions to the gradient
4427           facr=-3.0d0*rrmij
4428           a22der=a22*facr
4429           a23der=a23*facr
4430           a32der=a32*facr
4431           a33der=a33*facr
4432           agg(1,1)=a22der*xj
4433           agg(2,1)=a22der*yj
4434           agg(3,1)=a22der*zj
4435           agg(1,2)=a23der*xj
4436           agg(2,2)=a23der*yj
4437           agg(3,2)=a23der*zj
4438           agg(1,3)=a32der*xj
4439           agg(2,3)=a32der*yj
4440           agg(3,3)=a32der*zj
4441           agg(1,4)=a33der*xj
4442           agg(2,4)=a33der*yj
4443           agg(3,4)=a33der*zj
4444 C Add the contributions coming from er
4445           fac3=-3.0d0*fac
4446           do k=1,3
4447             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4448             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4449             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4450             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4451           enddo
4452           do k=1,3
4453 C Derivatives in DC(i)
4454 cgrad            ghalf1=0.5d0*agg(k,1)
4455 cgrad            ghalf2=0.5d0*agg(k,2)
4456 cgrad            ghalf3=0.5d0*agg(k,3)
4457 cgrad            ghalf4=0.5d0*agg(k,4)
4458             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4459      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4460             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4461      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4462             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4463      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4464             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4465      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4466 C Derivatives in DC(i+1)
4467             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4468      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4469             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4470      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4471             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4472      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4473             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4474      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4475 C Derivatives in DC(j)
4476             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4477      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4478             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4479      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4480             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4481      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4482             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4483      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4484 C Derivatives in DC(j+1) or DC(nres-1)
4485             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4486      &      -3.0d0*vryg(k,3)*ury)
4487             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4488      &      -3.0d0*vrzg(k,3)*ury)
4489             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4490      &      -3.0d0*vryg(k,3)*urz)
4491             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4492      &      -3.0d0*vrzg(k,3)*urz)
4493 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4494 cgrad              do l=1,4
4495 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4496 cgrad              enddo
4497 cgrad            endif
4498           enddo
4499           acipa(1,1)=a22
4500           acipa(1,2)=a23
4501           acipa(2,1)=a32
4502           acipa(2,2)=a33
4503           a22=-a22
4504           a23=-a23
4505           do l=1,2
4506             do k=1,3
4507               agg(k,l)=-agg(k,l)
4508               aggi(k,l)=-aggi(k,l)
4509               aggi1(k,l)=-aggi1(k,l)
4510               aggj(k,l)=-aggj(k,l)
4511               aggj1(k,l)=-aggj1(k,l)
4512             enddo
4513           enddo
4514           if (j.lt.nres-1) then
4515             a22=-a22
4516             a32=-a32
4517             do l=1,3,2
4518               do k=1,3
4519                 agg(k,l)=-agg(k,l)
4520                 aggi(k,l)=-aggi(k,l)
4521                 aggi1(k,l)=-aggi1(k,l)
4522                 aggj(k,l)=-aggj(k,l)
4523                 aggj1(k,l)=-aggj1(k,l)
4524               enddo
4525             enddo
4526           else
4527             a22=-a22
4528             a23=-a23
4529             a32=-a32
4530             a33=-a33
4531             do l=1,4
4532               do k=1,3
4533                 agg(k,l)=-agg(k,l)
4534                 aggi(k,l)=-aggi(k,l)
4535                 aggi1(k,l)=-aggi1(k,l)
4536                 aggj(k,l)=-aggj(k,l)
4537                 aggj1(k,l)=-aggj1(k,l)
4538               enddo
4539             enddo
4540           endif
4541           ENDIF ! WCORR
4542           IF (wel_loc.gt.0.0d0) THEN
4543 C Contribution to the local-electrostatic energy coming from the i-j pair
4544           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4545      &     +a33*muij(4)
4546 #ifdef DEBUG
4547           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4548      &     " a33",a33
4549           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4550      &     " wel_loc",wel_loc
4551 #endif
4552           if (shield_mode.eq.0) then
4553            fac_shield(i)=1.0
4554            fac_shield(j)=1.0
4555 C          else
4556 C           fac_shield(i)=0.4
4557 C           fac_shield(j)=0.6
4558           endif
4559           eel_loc_ij=eel_loc_ij
4560      &    *fac_shield(i)*fac_shield(j)
4561 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4562 c     &            'eelloc',i,j,eel_loc_ij
4563 C Now derivative over eel_loc
4564           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4565      &  (shield_mode.gt.0)) then
4566 C          print *,i,j
4567
4568           do ilist=1,ishield_list(i)
4569            iresshield=shield_list(ilist,i)
4570            do k=1,3
4571            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4572      &                                          /fac_shield(i)
4573 C     &      *2.0
4574            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4575      &              rlocshield
4576      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4577             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4578      &      +rlocshield
4579            enddo
4580           enddo
4581           do ilist=1,ishield_list(j)
4582            iresshield=shield_list(ilist,j)
4583            do k=1,3
4584            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4585      &                                       /fac_shield(j)
4586 C     &     *2.0
4587            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4588      &              rlocshield
4589      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4590            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4591      &             +rlocshield
4592
4593            enddo
4594           enddo
4595
4596           do k=1,3
4597             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4598      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4599             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4600      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4601             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4602      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4603             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4604      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4605            enddo
4606            endif
4607
4608
4609 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4610 c     &                     ' eel_loc_ij',eel_loc_ij
4611 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4612 C Calculate patrial derivative for theta angle
4613 #ifdef NEWCORR
4614          geel_loc_ij=(a22*gmuij1(1)
4615      &     +a23*gmuij1(2)
4616      &     +a32*gmuij1(3)
4617      &     +a33*gmuij1(4))
4618      &    *fac_shield(i)*fac_shield(j)
4619 c         write(iout,*) "derivative over thatai"
4620 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4621 c     &   a33*gmuij1(4)
4622          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4623      &      geel_loc_ij*wel_loc
4624 c         write(iout,*) "derivative over thatai-1"
4625 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4626 c     &   a33*gmuij2(4)
4627          geel_loc_ij=
4628      &     a22*gmuij2(1)
4629      &     +a23*gmuij2(2)
4630      &     +a32*gmuij2(3)
4631      &     +a33*gmuij2(4)
4632          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4633      &      geel_loc_ij*wel_loc
4634      &    *fac_shield(i)*fac_shield(j)
4635
4636 c  Derivative over j residue
4637          geel_loc_ji=a22*gmuji1(1)
4638      &     +a23*gmuji1(2)
4639      &     +a32*gmuji1(3)
4640      &     +a33*gmuji1(4)
4641 c         write(iout,*) "derivative over thataj"
4642 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4643 c     &   a33*gmuji1(4)
4644
4645         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4646      &      geel_loc_ji*wel_loc
4647      &    *fac_shield(i)*fac_shield(j)
4648
4649          geel_loc_ji=
4650      &     +a22*gmuji2(1)
4651      &     +a23*gmuji2(2)
4652      &     +a32*gmuji2(3)
4653      &     +a33*gmuji2(4)
4654 c         write(iout,*) "derivative over thataj-1"
4655 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4656 c     &   a33*gmuji2(4)
4657          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4658      &      geel_loc_ji*wel_loc
4659      &    *fac_shield(i)*fac_shield(j)
4660 #endif
4661 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4662
4663           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4664      &            'eelloc',i,j,eel_loc_ij
4665 c           if (eel_loc_ij.ne.0)
4666 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4667 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4668
4669           eel_loc=eel_loc+eel_loc_ij
4670 C Partial derivatives in virtual-bond dihedral angles gamma
4671           if (i.gt.1)
4672      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4673      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4674      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4675      &    *fac_shield(i)*fac_shield(j)
4676
4677           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4678      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4679      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4680      &    *fac_shield(i)*fac_shield(j)
4681 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4682           do l=1,3
4683             ggg(l)=(agg(l,1)*muij(1)+
4684      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4685      &    *fac_shield(i)*fac_shield(j)
4686             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4687             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4688 cgrad            ghalf=0.5d0*ggg(l)
4689 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4690 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4691           enddo
4692 cgrad          do k=i+1,j2
4693 cgrad            do l=1,3
4694 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4695 cgrad            enddo
4696 cgrad          enddo
4697 C Remaining derivatives of eello
4698           do l=1,3
4699             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4700      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4701      &    *fac_shield(i)*fac_shield(j)
4702
4703             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4704      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4705      &    *fac_shield(i)*fac_shield(j)
4706
4707             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4708      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4709      &    *fac_shield(i)*fac_shield(j)
4710
4711             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4712      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4713      &    *fac_shield(i)*fac_shield(j)
4714
4715           enddo
4716           ENDIF
4717 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4718 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4719 #ifdef FOURBODY
4720           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4721      &       .and. num_conti.le.maxconts) then
4722 c            write (iout,*) i,j," entered corr"
4723 C
4724 C Calculate the contact function. The ith column of the array JCONT will
4725 C contain the numbers of atoms that make contacts with the atom I (of numbers
4726 C greater than I). The arrays FACONT and GACONT will contain the values of
4727 C the contact function and its derivative.
4728 c           r0ij=1.02D0*rpp(iteli,itelj)
4729 c           r0ij=1.11D0*rpp(iteli,itelj)
4730             r0ij=2.20D0*rpp(iteli,itelj)
4731 c           r0ij=1.55D0*rpp(iteli,itelj)
4732             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4733             if (fcont.gt.0.0D0) then
4734               num_conti=num_conti+1
4735               if (num_conti.gt.maxconts) then
4736                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4737      &                         ' will skip next contacts for this conf.'
4738               else
4739                 jcont_hb(num_conti,i)=j
4740 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4741 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4742                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4743      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4744 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4745 C  terms.
4746                 d_cont(num_conti,i)=rij
4747 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4748 C     --- Electrostatic-interaction matrix ---
4749                 a_chuj(1,1,num_conti,i)=a22
4750                 a_chuj(1,2,num_conti,i)=a23
4751                 a_chuj(2,1,num_conti,i)=a32
4752                 a_chuj(2,2,num_conti,i)=a33
4753 C     --- Gradient of rij
4754                 do kkk=1,3
4755                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4756                 enddo
4757                 kkll=0
4758                 do k=1,2
4759                   do l=1,2
4760                     kkll=kkll+1
4761                     do m=1,3
4762                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4763                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4764                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4765                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4766                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4767                     enddo
4768                   enddo
4769                 enddo
4770                 ENDIF
4771                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4772 C Calculate contact energies
4773                 cosa4=4.0D0*cosa
4774                 wij=cosa-3.0D0*cosb*cosg
4775                 cosbg1=cosb+cosg
4776                 cosbg2=cosb-cosg
4777 c               fac3=dsqrt(-ael6i)/r0ij**3
4778                 fac3=dsqrt(-ael6i)*r3ij
4779 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4780                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4781                 if (ees0tmp.gt.0) then
4782                   ees0pij=dsqrt(ees0tmp)
4783                 else
4784                   ees0pij=0
4785                 endif
4786 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4787                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4788                 if (ees0tmp.gt.0) then
4789                   ees0mij=dsqrt(ees0tmp)
4790                 else
4791                   ees0mij=0
4792                 endif
4793 c               ees0mij=0.0D0
4794                 if (shield_mode.eq.0) then
4795                 fac_shield(i)=1.0d0
4796                 fac_shield(j)=1.0d0
4797                 else
4798                 ees0plist(num_conti,i)=j
4799 C                fac_shield(i)=0.4d0
4800 C                fac_shield(j)=0.6d0
4801                 endif
4802                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4803      &          *fac_shield(i)*fac_shield(j)
4804                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4805      &          *fac_shield(i)*fac_shield(j)
4806 C Diagnostics. Comment out or remove after debugging!
4807 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4808 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4809 c               ees0m(num_conti,i)=0.0D0
4810 C End diagnostics.
4811 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4812 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4813 C Angular derivatives of the contact function
4814                 ees0pij1=fac3/ees0pij
4815                 ees0mij1=fac3/ees0mij
4816                 fac3p=-3.0D0*fac3*rrmij
4817                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4818                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4819 c               ees0mij1=0.0D0
4820                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4821                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4822                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4823                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4824                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4825                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4826                 ecosap=ecosa1+ecosa2
4827                 ecosbp=ecosb1+ecosb2
4828                 ecosgp=ecosg1+ecosg2
4829                 ecosam=ecosa1-ecosa2
4830                 ecosbm=ecosb1-ecosb2
4831                 ecosgm=ecosg1-ecosg2
4832 C Diagnostics
4833 c               ecosap=ecosa1
4834 c               ecosbp=ecosb1
4835 c               ecosgp=ecosg1
4836 c               ecosam=0.0D0
4837 c               ecosbm=0.0D0
4838 c               ecosgm=0.0D0
4839 C End diagnostics
4840                 facont_hb(num_conti,i)=fcont
4841                 fprimcont=fprimcont/rij
4842 cd              facont_hb(num_conti,i)=1.0D0
4843 C Following line is for diagnostics.
4844 cd              fprimcont=0.0D0
4845                 do k=1,3
4846                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4847                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4848                 enddo
4849                 do k=1,3
4850                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4851                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4852                 enddo
4853                 gggp(1)=gggp(1)+ees0pijp*xj
4854                 gggp(2)=gggp(2)+ees0pijp*yj
4855                 gggp(3)=gggp(3)+ees0pijp*zj
4856                 gggm(1)=gggm(1)+ees0mijp*xj
4857                 gggm(2)=gggm(2)+ees0mijp*yj
4858                 gggm(3)=gggm(3)+ees0mijp*zj
4859 C Derivatives due to the contact function
4860                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4861                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4862                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4863                 do k=1,3
4864 c
4865 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4866 c          following the change of gradient-summation algorithm.
4867 c
4868 cgrad                  ghalfp=0.5D0*gggp(k)
4869 cgrad                  ghalfm=0.5D0*gggm(k)
4870                   gacontp_hb1(k,num_conti,i)=!ghalfp
4871      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4872      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4873      &          *fac_shield(i)*fac_shield(j)
4874
4875                   gacontp_hb2(k,num_conti,i)=!ghalfp
4876      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4877      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4878      &          *fac_shield(i)*fac_shield(j)
4879
4880                   gacontp_hb3(k,num_conti,i)=gggp(k)
4881      &          *fac_shield(i)*fac_shield(j)
4882
4883                   gacontm_hb1(k,num_conti,i)=!ghalfm
4884      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4885      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4886      &          *fac_shield(i)*fac_shield(j)
4887
4888                   gacontm_hb2(k,num_conti,i)=!ghalfm
4889      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4890      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4891      &          *fac_shield(i)*fac_shield(j)
4892
4893                   gacontm_hb3(k,num_conti,i)=gggm(k)
4894      &          *fac_shield(i)*fac_shield(j)
4895
4896                 enddo
4897 C Diagnostics. Comment out or remove after debugging!
4898 cdiag           do k=1,3
4899 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4900 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4901 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4902 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4903 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4904 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4905 cdiag           enddo
4906               ENDIF ! wcorr
4907               endif  ! num_conti.le.maxconts
4908             endif  ! fcont.gt.0
4909           endif    ! j.gt.i+1
4910 #endif
4911           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4912             do k=1,4
4913               do l=1,3
4914                 ghalf=0.5d0*agg(l,k)
4915                 aggi(l,k)=aggi(l,k)+ghalf
4916                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4917                 aggj(l,k)=aggj(l,k)+ghalf
4918               enddo
4919             enddo
4920             if (j.eq.nres-1 .and. i.lt.j-2) then
4921               do k=1,4
4922                 do l=1,3
4923                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4924                 enddo
4925               enddo
4926             endif
4927           endif
4928 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4929       return
4930       end
4931 C-----------------------------------------------------------------------------
4932       subroutine eturn3(i,eello_turn3)
4933 C Third- and fourth-order contributions from turns
4934       implicit real*8 (a-h,o-z)
4935       include 'DIMENSIONS'
4936       include 'COMMON.IOUNITS'
4937       include 'COMMON.GEO'
4938       include 'COMMON.VAR'
4939       include 'COMMON.LOCAL'
4940       include 'COMMON.CHAIN'
4941       include 'COMMON.DERIV'
4942       include 'COMMON.INTERACT'
4943       include 'COMMON.CORRMAT'
4944       include 'COMMON.TORSION'
4945       include 'COMMON.VECTORS'
4946       include 'COMMON.FFIELD'
4947       include 'COMMON.CONTROL'
4948       include 'COMMON.SHIELD'
4949       dimension ggg(3)
4950       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4951      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4952      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4953      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4954      &  auxgmat2(2,2),auxgmatt2(2,2)
4955       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4956      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4957       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4958      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4959      &    num_conti,j1,j2
4960       j=i+2
4961 c      write (iout,*) "eturn3",i,j,j1,j2
4962       a_temp(1,1)=a22
4963       a_temp(1,2)=a23
4964       a_temp(2,1)=a32
4965       a_temp(2,2)=a33
4966 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4967 C
4968 C               Third-order contributions
4969 C
4970 C                 (i+2)o----(i+3)
4971 C                      | |
4972 C                      | |
4973 C                 (i+1)o----i
4974 C
4975 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4976 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4977         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4978 c auxalary matices for theta gradient
4979 c auxalary matrix for i+1 and constant i+2
4980         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4981 c auxalary matrix for i+2 and constant i+1
4982         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4983         call transpose2(auxmat(1,1),auxmat1(1,1))
4984         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4985         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4986         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4987         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4988         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4989         if (shield_mode.eq.0) then
4990         fac_shield(i)=1.0
4991         fac_shield(j)=1.0
4992 C        else
4993 C        fac_shield(i)=0.4
4994 C        fac_shield(j)=0.6
4995         endif
4996         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4997      &  *fac_shield(i)*fac_shield(j)
4998         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4999      &  *fac_shield(i)*fac_shield(j)
5000         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5001      &    eello_t3
5002 C#ifdef NEWCORR
5003 C Derivatives in theta
5004         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5005      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5006      &   *fac_shield(i)*fac_shield(j)
5007         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5008      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5009      &   *fac_shield(i)*fac_shield(j)
5010 C#endif
5011
5012 C Derivatives in shield mode
5013           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5014      &  (shield_mode.gt.0)) then
5015 C          print *,i,j
5016
5017           do ilist=1,ishield_list(i)
5018            iresshield=shield_list(ilist,i)
5019            do k=1,3
5020            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5021 C     &      *2.0
5022            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5023      &              rlocshield
5024      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5025             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5026      &      +rlocshield
5027            enddo
5028           enddo
5029           do ilist=1,ishield_list(j)
5030            iresshield=shield_list(ilist,j)
5031            do k=1,3
5032            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5033 C     &     *2.0
5034            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5035      &              rlocshield
5036      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5037            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5038      &             +rlocshield
5039
5040            enddo
5041           enddo
5042
5043           do k=1,3
5044             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5045      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5046             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5047      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5048             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5049      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5050             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5051      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5052            enddo
5053            endif
5054
5055 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5056 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5057 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5058 cd     &    ' eello_turn3_num',4*eello_turn3_num
5059 C Derivatives in gamma(i)
5060         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5061         call transpose2(auxmat2(1,1),auxmat3(1,1))
5062         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5063         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5064      &   *fac_shield(i)*fac_shield(j)
5065 C Derivatives in gamma(i+1)
5066         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5067         call transpose2(auxmat2(1,1),auxmat3(1,1))
5068         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5069         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5070      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5071      &   *fac_shield(i)*fac_shield(j)
5072 C Cartesian derivatives
5073         do l=1,3
5074 c            ghalf1=0.5d0*agg(l,1)
5075 c            ghalf2=0.5d0*agg(l,2)
5076 c            ghalf3=0.5d0*agg(l,3)
5077 c            ghalf4=0.5d0*agg(l,4)
5078           a_temp(1,1)=aggi(l,1)!+ghalf1
5079           a_temp(1,2)=aggi(l,2)!+ghalf2
5080           a_temp(2,1)=aggi(l,3)!+ghalf3
5081           a_temp(2,2)=aggi(l,4)!+ghalf4
5082           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5083           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5084      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5085      &   *fac_shield(i)*fac_shield(j)
5086
5087           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5088           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5089           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5090           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5091           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5092           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5093      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5094      &   *fac_shield(i)*fac_shield(j)
5095           a_temp(1,1)=aggj(l,1)!+ghalf1
5096           a_temp(1,2)=aggj(l,2)!+ghalf2
5097           a_temp(2,1)=aggj(l,3)!+ghalf3
5098           a_temp(2,2)=aggj(l,4)!+ghalf4
5099           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5100           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5101      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5102      &   *fac_shield(i)*fac_shield(j)
5103           a_temp(1,1)=aggj1(l,1)
5104           a_temp(1,2)=aggj1(l,2)
5105           a_temp(2,1)=aggj1(l,3)
5106           a_temp(2,2)=aggj1(l,4)
5107           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5108           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5109      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5110      &   *fac_shield(i)*fac_shield(j)
5111         enddo
5112       return
5113       end
5114 C-------------------------------------------------------------------------------
5115       subroutine eturn4(i,eello_turn4)
5116 C Third- and fourth-order contributions from turns
5117       implicit real*8 (a-h,o-z)
5118       include 'DIMENSIONS'
5119       include 'COMMON.IOUNITS'
5120       include 'COMMON.GEO'
5121       include 'COMMON.VAR'
5122       include 'COMMON.LOCAL'
5123       include 'COMMON.CHAIN'
5124       include 'COMMON.DERIV'
5125       include 'COMMON.INTERACT'
5126       include 'COMMON.CORRMAT'
5127       include 'COMMON.TORSION'
5128       include 'COMMON.VECTORS'
5129       include 'COMMON.FFIELD'
5130       include 'COMMON.CONTROL'
5131       include 'COMMON.SHIELD'
5132       dimension ggg(3)
5133       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5134      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5135      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5136      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5137      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5138      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5139      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5140       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5141      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5142       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5143      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5144      &    num_conti,j1,j2
5145       j=i+3
5146 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5147 C
5148 C               Fourth-order contributions
5149 C
5150 C                 (i+3)o----(i+4)
5151 C                     /  |
5152 C               (i+2)o   |
5153 C                     \  |
5154 C                 (i+1)o----i
5155 C
5156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5157 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5158 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5159 c        write(iout,*)"WCHODZE W PROGRAM"
5160         a_temp(1,1)=a22
5161         a_temp(1,2)=a23
5162         a_temp(2,1)=a32
5163         a_temp(2,2)=a33
5164         iti1=itype2loc(itype(i+1))
5165         iti2=itype2loc(itype(i+2))
5166         iti3=itype2loc(itype(i+3))
5167 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5168         call transpose2(EUg(1,1,i+1),e1t(1,1))
5169         call transpose2(Eug(1,1,i+2),e2t(1,1))
5170         call transpose2(Eug(1,1,i+3),e3t(1,1))
5171 C Ematrix derivative in theta
5172         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5173         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5174         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5175         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5176 c       eta1 in derivative theta
5177         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5178         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5179 c       auxgvec is derivative of Ub2 so i+3 theta
5180         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5181 c       auxalary matrix of E i+1
5182         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5183 c        s1=0.0
5184 c        gs1=0.0
5185         s1=scalar2(b1(1,i+2),auxvec(1))
5186 c derivative of theta i+2 with constant i+3
5187         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5188 c derivative of theta i+2 with constant i+2
5189         gs32=scalar2(b1(1,i+2),auxgvec(1))
5190 c derivative of E matix in theta of i+1
5191         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5192
5193         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5194 c       ea31 in derivative theta
5195         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5196         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5197 c auxilary matrix auxgvec of Ub2 with constant E matirx
5198         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5199 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5200         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5201
5202 c        s2=0.0
5203 c        gs2=0.0
5204         s2=scalar2(b1(1,i+1),auxvec(1))
5205 c derivative of theta i+1 with constant i+3
5206         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5207 c derivative of theta i+2 with constant i+1
5208         gs21=scalar2(b1(1,i+1),auxgvec(1))
5209 c derivative of theta i+3 with constant i+1
5210         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5211 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5212 c     &  gtb1(1,i+1)
5213         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5214 c two derivatives over diffetent matrices
5215 c gtae3e2 is derivative over i+3
5216         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5217 c ae3gte2 is derivative over i+2
5218         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5219         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5220 c three possible derivative over theta E matices
5221 c i+1
5222         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5223 c i+2
5224         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5225 c i+3
5226         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5227         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5228
5229         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5230         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5231         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5232         if (shield_mode.eq.0) then
5233         fac_shield(i)=1.0
5234         fac_shield(j)=1.0
5235 C        else
5236 C        fac_shield(i)=0.6
5237 C        fac_shield(j)=0.4
5238         endif
5239         eello_turn4=eello_turn4-(s1+s2+s3)
5240      &  *fac_shield(i)*fac_shield(j)
5241         eello_t4=-(s1+s2+s3)
5242      &  *fac_shield(i)*fac_shield(j)
5243 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5244         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5245      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5246 C Now derivative over shield:
5247           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5248      &  (shield_mode.gt.0)) then
5249 C          print *,i,j
5250
5251           do ilist=1,ishield_list(i)
5252            iresshield=shield_list(ilist,i)
5253            do k=1,3
5254            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5255 C     &      *2.0
5256            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5257      &              rlocshield
5258      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5259             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5260      &      +rlocshield
5261            enddo
5262           enddo
5263           do ilist=1,ishield_list(j)
5264            iresshield=shield_list(ilist,j)
5265            do k=1,3
5266            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5267 C     &     *2.0
5268            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5269      &              rlocshield
5270      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5271            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5272      &             +rlocshield
5273
5274            enddo
5275           enddo
5276
5277           do k=1,3
5278             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5279      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5280             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5281      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5282             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5283      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5284             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5285      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5286            enddo
5287            endif
5288
5289
5290
5291
5292
5293
5294 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5295 cd     &    ' eello_turn4_num',8*eello_turn4_num
5296 #ifdef NEWCORR
5297         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5298      &                  -(gs13+gsE13+gsEE1)*wturn4
5299      &  *fac_shield(i)*fac_shield(j)
5300         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5301      &                    -(gs23+gs21+gsEE2)*wturn4
5302      &  *fac_shield(i)*fac_shield(j)
5303
5304         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5305      &                    -(gs32+gsE31+gsEE3)*wturn4
5306      &  *fac_shield(i)*fac_shield(j)
5307
5308 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5309 c     &   gs2
5310 #endif
5311         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5312      &      'eturn4',i,j,-(s1+s2+s3)
5313 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5314 c     &    ' eello_turn4_num',8*eello_turn4_num
5315 C Derivatives in gamma(i)
5316         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5317         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5318         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5319         s1=scalar2(b1(1,i+2),auxvec(1))
5320         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5321         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5322         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5323      &  *fac_shield(i)*fac_shield(j)
5324 C Derivatives in gamma(i+1)
5325         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5326         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5327         s2=scalar2(b1(1,i+1),auxvec(1))
5328         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5329         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5330         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5331         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5332      &  *fac_shield(i)*fac_shield(j)
5333 C Derivatives in gamma(i+2)
5334         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5335         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5336         s1=scalar2(b1(1,i+2),auxvec(1))
5337         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5338         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5339         s2=scalar2(b1(1,i+1),auxvec(1))
5340         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5341         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5342         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5343         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5344      &  *fac_shield(i)*fac_shield(j)
5345 C Cartesian derivatives
5346 C Derivatives of this turn contributions in DC(i+2)
5347         if (j.lt.nres-1) then
5348           do l=1,3
5349             a_temp(1,1)=agg(l,1)
5350             a_temp(1,2)=agg(l,2)
5351             a_temp(2,1)=agg(l,3)
5352             a_temp(2,2)=agg(l,4)
5353             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5354             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5355             s1=scalar2(b1(1,i+2),auxvec(1))
5356             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5357             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5358             s2=scalar2(b1(1,i+1),auxvec(1))
5359             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5360             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5361             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5362             ggg(l)=-(s1+s2+s3)
5363             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5364      &  *fac_shield(i)*fac_shield(j)
5365           enddo
5366         endif
5367 C Remaining derivatives of this turn contribution
5368         do l=1,3
5369           a_temp(1,1)=aggi(l,1)
5370           a_temp(1,2)=aggi(l,2)
5371           a_temp(2,1)=aggi(l,3)
5372           a_temp(2,2)=aggi(l,4)
5373           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5374           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5375           s1=scalar2(b1(1,i+2),auxvec(1))
5376           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5377           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5378           s2=scalar2(b1(1,i+1),auxvec(1))
5379           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5380           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5381           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5382           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5383      &  *fac_shield(i)*fac_shield(j)
5384           a_temp(1,1)=aggi1(l,1)
5385           a_temp(1,2)=aggi1(l,2)
5386           a_temp(2,1)=aggi1(l,3)
5387           a_temp(2,2)=aggi1(l,4)
5388           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5389           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5390           s1=scalar2(b1(1,i+2),auxvec(1))
5391           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5392           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5393           s2=scalar2(b1(1,i+1),auxvec(1))
5394           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5395           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5396           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5397           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5398      &  *fac_shield(i)*fac_shield(j)
5399           a_temp(1,1)=aggj(l,1)
5400           a_temp(1,2)=aggj(l,2)
5401           a_temp(2,1)=aggj(l,3)
5402           a_temp(2,2)=aggj(l,4)
5403           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5404           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5405           s1=scalar2(b1(1,i+2),auxvec(1))
5406           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5407           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5408           s2=scalar2(b1(1,i+1),auxvec(1))
5409           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5410           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5411           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5412           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5413      &  *fac_shield(i)*fac_shield(j)
5414           a_temp(1,1)=aggj1(l,1)
5415           a_temp(1,2)=aggj1(l,2)
5416           a_temp(2,1)=aggj1(l,3)
5417           a_temp(2,2)=aggj1(l,4)
5418           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5419           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5420           s1=scalar2(b1(1,i+2),auxvec(1))
5421           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5422           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5423           s2=scalar2(b1(1,i+1),auxvec(1))
5424           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5425           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5426           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5427 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5428           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5429      &  *fac_shield(i)*fac_shield(j)
5430         enddo
5431       return
5432       end
5433 C-----------------------------------------------------------------------------
5434       subroutine vecpr(u,v,w)
5435       implicit real*8(a-h,o-z)
5436       dimension u(3),v(3),w(3)
5437       w(1)=u(2)*v(3)-u(3)*v(2)
5438       w(2)=-u(1)*v(3)+u(3)*v(1)
5439       w(3)=u(1)*v(2)-u(2)*v(1)
5440       return
5441       end
5442 C-----------------------------------------------------------------------------
5443       subroutine unormderiv(u,ugrad,unorm,ungrad)
5444 C This subroutine computes the derivatives of a normalized vector u, given
5445 C the derivatives computed without normalization conditions, ugrad. Returns
5446 C ungrad.
5447       implicit none
5448       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5449       double precision vec(3)
5450       double precision scalar
5451       integer i,j
5452 c      write (2,*) 'ugrad',ugrad
5453 c      write (2,*) 'u',u
5454       do i=1,3
5455         vec(i)=scalar(ugrad(1,i),u(1))
5456       enddo
5457 c      write (2,*) 'vec',vec
5458       do i=1,3
5459         do j=1,3
5460           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5461         enddo
5462       enddo
5463 c      write (2,*) 'ungrad',ungrad
5464       return
5465       end
5466 C-----------------------------------------------------------------------------
5467       subroutine escp_soft_sphere(evdw2,evdw2_14)
5468 C
5469 C This subroutine calculates the excluded-volume interaction energy between
5470 C peptide-group centers and side chains and its gradient in virtual-bond and
5471 C side-chain vectors.
5472 C
5473       implicit real*8 (a-h,o-z)
5474       include 'DIMENSIONS'
5475       include 'COMMON.GEO'
5476       include 'COMMON.VAR'
5477       include 'COMMON.LOCAL'
5478       include 'COMMON.CHAIN'
5479       include 'COMMON.DERIV'
5480       include 'COMMON.INTERACT'
5481       include 'COMMON.FFIELD'
5482       include 'COMMON.IOUNITS'
5483       include 'COMMON.CONTROL'
5484       dimension ggg(3)
5485       integer xshift,yshift,zshift
5486       evdw2=0.0D0
5487       evdw2_14=0.0d0
5488       r0_scp=4.5d0
5489 cd    print '(a)','Enter ESCP'
5490 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5491 C      do xshift=-1,1
5492 C      do yshift=-1,1
5493 C      do zshift=-1,1
5494       do i=iatscp_s,iatscp_e
5495         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5496         iteli=itel(i)
5497         xi=0.5D0*(c(1,i)+c(1,i+1))
5498         yi=0.5D0*(c(2,i)+c(2,i+1))
5499         zi=0.5D0*(c(3,i)+c(3,i+1))
5500 C Return atom into box, boxxsize is size of box in x dimension
5501 c  134   continue
5502 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5503 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5504 C Condition for being inside the proper box
5505 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5506 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5507 c        go to 134
5508 c        endif
5509 c  135   continue
5510 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5511 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5512 C Condition for being inside the proper box
5513 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5514 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5515 c        go to 135
5516 c c       endif
5517 c  136   continue
5518 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5519 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5520 cC Condition for being inside the proper box
5521 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5522 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5523 c        go to 136
5524 c        endif
5525           xi=mod(xi,boxxsize)
5526           if (xi.lt.0) xi=xi+boxxsize
5527           yi=mod(yi,boxysize)
5528           if (yi.lt.0) yi=yi+boxysize
5529           zi=mod(zi,boxzsize)
5530           if (zi.lt.0) zi=zi+boxzsize
5531 C          xi=xi+xshift*boxxsize
5532 C          yi=yi+yshift*boxysize
5533 C          zi=zi+zshift*boxzsize
5534         do iint=1,nscp_gr(i)
5535
5536         do j=iscpstart(i,iint),iscpend(i,iint)
5537           if (itype(j).eq.ntyp1) cycle
5538           itypj=iabs(itype(j))
5539 C Uncomment following three lines for SC-p interactions
5540 c         xj=c(1,nres+j)-xi
5541 c         yj=c(2,nres+j)-yi
5542 c         zj=c(3,nres+j)-zi
5543 C Uncomment following three lines for Ca-p interactions
5544           xj=c(1,j)
5545           yj=c(2,j)
5546           zj=c(3,j)
5547 c  174   continue
5548 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5549 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5550 C Condition for being inside the proper box
5551 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5552 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5553 c        go to 174
5554 c        endif
5555 c  175   continue
5556 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5557 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5558 cC Condition for being inside the proper box
5559 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5560 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5561 c        go to 175
5562 c        endif
5563 c  176   continue
5564 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5565 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5566 C Condition for being inside the proper box
5567 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5568 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5569 c        go to 176
5570           xj=mod(xj,boxxsize)
5571           if (xj.lt.0) xj=xj+boxxsize
5572           yj=mod(yj,boxysize)
5573           if (yj.lt.0) yj=yj+boxysize
5574           zj=mod(zj,boxzsize)
5575           if (zj.lt.0) zj=zj+boxzsize
5576       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5577       xj_safe=xj
5578       yj_safe=yj
5579       zj_safe=zj
5580       subchap=0
5581       do xshift=-1,1
5582       do yshift=-1,1
5583       do zshift=-1,1
5584           xj=xj_safe+xshift*boxxsize
5585           yj=yj_safe+yshift*boxysize
5586           zj=zj_safe+zshift*boxzsize
5587           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5588           if(dist_temp.lt.dist_init) then
5589             dist_init=dist_temp
5590             xj_temp=xj
5591             yj_temp=yj
5592             zj_temp=zj
5593             subchap=1
5594           endif
5595        enddo
5596        enddo
5597        enddo
5598        if (subchap.eq.1) then
5599           xj=xj_temp-xi
5600           yj=yj_temp-yi
5601           zj=zj_temp-zi
5602        else
5603           xj=xj_safe-xi
5604           yj=yj_safe-yi
5605           zj=zj_safe-zi
5606        endif
5607 c c       endif
5608 C          xj=xj-xi
5609 C          yj=yj-yi
5610 C          zj=zj-zi
5611           rij=xj*xj+yj*yj+zj*zj
5612
5613           r0ij=r0_scp
5614           r0ijsq=r0ij*r0ij
5615           if (rij.lt.r0ijsq) then
5616             evdwij=0.25d0*(rij-r0ijsq)**2
5617             fac=rij-r0ijsq
5618           else
5619             evdwij=0.0d0
5620             fac=0.0d0
5621           endif
5622           evdw2=evdw2+evdwij
5623 C
5624 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5625 C
5626           ggg(1)=xj*fac
5627           ggg(2)=yj*fac
5628           ggg(3)=zj*fac
5629 cgrad          if (j.lt.i) then
5630 cd          write (iout,*) 'j<i'
5631 C Uncomment following three lines for SC-p interactions
5632 c           do k=1,3
5633 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5634 c           enddo
5635 cgrad          else
5636 cd          write (iout,*) 'j>i'
5637 cgrad            do k=1,3
5638 cgrad              ggg(k)=-ggg(k)
5639 C Uncomment following line for SC-p interactions
5640 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5641 cgrad            enddo
5642 cgrad          endif
5643 cgrad          do k=1,3
5644 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5645 cgrad          enddo
5646 cgrad          kstart=min0(i+1,j)
5647 cgrad          kend=max0(i-1,j-1)
5648 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5649 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5650 cgrad          do k=kstart,kend
5651 cgrad            do l=1,3
5652 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5653 cgrad            enddo
5654 cgrad          enddo
5655           do k=1,3
5656             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5657             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5658           enddo
5659         enddo
5660
5661         enddo ! iint
5662       enddo ! i
5663 C      enddo !zshift
5664 C      enddo !yshift
5665 C      enddo !xshift
5666       return
5667       end
5668 C-----------------------------------------------------------------------------
5669       subroutine escp(evdw2,evdw2_14)
5670 C
5671 C This subroutine calculates the excluded-volume interaction energy between
5672 C peptide-group centers and side chains and its gradient in virtual-bond and
5673 C side-chain vectors.
5674 C
5675       implicit real*8 (a-h,o-z)
5676       include 'DIMENSIONS'
5677       include 'COMMON.GEO'
5678       include 'COMMON.VAR'
5679       include 'COMMON.LOCAL'
5680       include 'COMMON.CHAIN'
5681       include 'COMMON.DERIV'
5682       include 'COMMON.INTERACT'
5683       include 'COMMON.FFIELD'
5684       include 'COMMON.IOUNITS'
5685       include 'COMMON.CONTROL'
5686       include 'COMMON.SPLITELE'
5687       integer xshift,yshift,zshift
5688       dimension ggg(3)
5689       evdw2=0.0D0
5690       evdw2_14=0.0d0
5691 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5692 cd    print '(a)','Enter ESCP'
5693 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5694 C      do xshift=-1,1
5695 C      do yshift=-1,1
5696 C      do zshift=-1,1
5697       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5698       do i=iatscp_s,iatscp_e
5699         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5700         iteli=itel(i)
5701         xi=0.5D0*(c(1,i)+c(1,i+1))
5702         yi=0.5D0*(c(2,i)+c(2,i+1))
5703         zi=0.5D0*(c(3,i)+c(3,i+1))
5704           xi=mod(xi,boxxsize)
5705           if (xi.lt.0) xi=xi+boxxsize
5706           yi=mod(yi,boxysize)
5707           if (yi.lt.0) yi=yi+boxysize
5708           zi=mod(zi,boxzsize)
5709           if (zi.lt.0) zi=zi+boxzsize
5710 c          xi=xi+xshift*boxxsize
5711 c          yi=yi+yshift*boxysize
5712 c          zi=zi+zshift*boxzsize
5713 c        print *,xi,yi,zi,'polozenie i'
5714 C Return atom into box, boxxsize is size of box in x dimension
5715 c  134   continue
5716 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5717 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5718 C Condition for being inside the proper box
5719 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5720 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5721 c        go to 134
5722 c        endif
5723 c  135   continue
5724 c          print *,xi,boxxsize,"pierwszy"
5725
5726 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5727 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5728 C Condition for being inside the proper box
5729 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5730 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5731 c        go to 135
5732 c        endif
5733 c  136   continue
5734 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5735 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5736 C Condition for being inside the proper box
5737 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5738 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5739 c        go to 136
5740 c        endif
5741         do iint=1,nscp_gr(i)
5742
5743         do j=iscpstart(i,iint),iscpend(i,iint)
5744           itypj=iabs(itype(j))
5745           if (itypj.eq.ntyp1) cycle
5746 C Uncomment following three lines for SC-p interactions
5747 c         xj=c(1,nres+j)-xi
5748 c         yj=c(2,nres+j)-yi
5749 c         zj=c(3,nres+j)-zi
5750 C Uncomment following three lines for Ca-p interactions
5751           xj=c(1,j)
5752           yj=c(2,j)
5753           zj=c(3,j)
5754           xj=mod(xj,boxxsize)
5755           if (xj.lt.0) xj=xj+boxxsize
5756           yj=mod(yj,boxysize)
5757           if (yj.lt.0) yj=yj+boxysize
5758           zj=mod(zj,boxzsize)
5759           if (zj.lt.0) zj=zj+boxzsize
5760 c  174   continue
5761 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5762 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5763 C Condition for being inside the proper box
5764 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5765 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5766 c        go to 174
5767 c        endif
5768 c  175   continue
5769 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5770 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5771 cC Condition for being inside the proper box
5772 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5773 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5774 c        go to 175
5775 c        endif
5776 c  176   continue
5777 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5778 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5779 C Condition for being inside the proper box
5780 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5781 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5782 c        go to 176
5783 c        endif
5784 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5785       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5786       xj_safe=xj
5787       yj_safe=yj
5788       zj_safe=zj
5789       subchap=0
5790       do xshift=-1,1
5791       do yshift=-1,1
5792       do zshift=-1,1
5793           xj=xj_safe+xshift*boxxsize
5794           yj=yj_safe+yshift*boxysize
5795           zj=zj_safe+zshift*boxzsize
5796           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5797           if(dist_temp.lt.dist_init) then
5798             dist_init=dist_temp
5799             xj_temp=xj
5800             yj_temp=yj
5801             zj_temp=zj
5802             subchap=1
5803           endif
5804        enddo
5805        enddo
5806        enddo
5807        if (subchap.eq.1) then
5808           xj=xj_temp-xi
5809           yj=yj_temp-yi
5810           zj=zj_temp-zi
5811        else
5812           xj=xj_safe-xi
5813           yj=yj_safe-yi
5814           zj=zj_safe-zi
5815        endif
5816 c          print *,xj,yj,zj,'polozenie j'
5817           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5818 c          print *,rrij
5819           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5820 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5821 c          if (sss.eq.0) print *,'czasem jest OK'
5822           if (sss.le.0.0d0) cycle
5823           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5824           fac=rrij**expon2
5825           e1=fac*fac*aad(itypj,iteli)
5826           e2=fac*bad(itypj,iteli)
5827           if (iabs(j-i) .le. 2) then
5828             e1=scal14*e1
5829             e2=scal14*e2
5830             evdw2_14=evdw2_14+(e1+e2)*sss
5831           endif
5832           evdwij=e1+e2
5833           evdw2=evdw2+evdwij*sss
5834           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5835      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5836      &       bad(itypj,iteli)
5837 C
5838 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5839 C
5840           fac=-(evdwij+e1)*rrij*sss
5841           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5842           ggg(1)=xj*fac
5843           ggg(2)=yj*fac
5844           ggg(3)=zj*fac
5845 cgrad          if (j.lt.i) then
5846 cd          write (iout,*) 'j<i'
5847 C Uncomment following three lines for SC-p interactions
5848 c           do k=1,3
5849 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5850 c           enddo
5851 cgrad          else
5852 cd          write (iout,*) 'j>i'
5853 cgrad            do k=1,3
5854 cgrad              ggg(k)=-ggg(k)
5855 C Uncomment following line for SC-p interactions
5856 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5857 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5858 cgrad            enddo
5859 cgrad          endif
5860 cgrad          do k=1,3
5861 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5862 cgrad          enddo
5863 cgrad          kstart=min0(i+1,j)
5864 cgrad          kend=max0(i-1,j-1)
5865 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5866 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5867 cgrad          do k=kstart,kend
5868 cgrad            do l=1,3
5869 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5870 cgrad            enddo
5871 cgrad          enddo
5872           do k=1,3
5873             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5874             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5875           enddo
5876 c        endif !endif for sscale cutoff
5877         enddo ! j
5878
5879         enddo ! iint
5880       enddo ! i
5881 c      enddo !zshift
5882 c      enddo !yshift
5883 c      enddo !xshift
5884       do i=1,nct
5885         do j=1,3
5886           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5887           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5888           gradx_scp(j,i)=expon*gradx_scp(j,i)
5889         enddo
5890       enddo
5891 C******************************************************************************
5892 C
5893 C                              N O T E !!!
5894 C
5895 C To save time the factor EXPON has been extracted from ALL components
5896 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5897 C use!
5898 C
5899 C******************************************************************************
5900       return
5901       end
5902 C--------------------------------------------------------------------------
5903       subroutine edis(ehpb)
5904 C
5905 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5906 C
5907       implicit real*8 (a-h,o-z)
5908       include 'DIMENSIONS'
5909       include 'COMMON.SBRIDGE'
5910       include 'COMMON.CHAIN'
5911       include 'COMMON.DERIV'
5912       include 'COMMON.VAR'
5913       include 'COMMON.INTERACT'
5914       include 'COMMON.IOUNITS'
5915       include 'COMMON.CONTROL'
5916       dimension ggg(3),ggg_peak(3,1000)
5917       ehpb=0.0D0
5918       do i=1,3
5919        ggg(i)=0.0d0
5920       enddo
5921 c 8/21/18 AL: added explicit restraints on reference coords
5922 c      write (iout,*) "restr_on_coord",restr_on_coord
5923       if (restr_on_coord) then
5924
5925       do i=nnt,nct
5926         ecoor=0.0d0
5927         if (itype(i).eq.ntyp1) cycle
5928         do j=1,3
5929           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5930           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5931         enddo
5932         if (itype(i).ne.10) then
5933           do j=1,3
5934             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5935             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5936           enddo
5937         endif
5938         if (energy_dec) write (iout,*)
5939      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5940         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5941       enddo
5942
5943       endif
5944 C      write (iout,*) ,"link_end",link_end,constr_dist
5945 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5946 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5947 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5948 c     &  " link_end_peak",link_end_peak
5949       if (link_end.eq.0.and.link_end_peak.eq.0) return
5950       do i=link_start_peak,link_end_peak
5951         ehpb_peak=0.0d0
5952 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5953 c     &   ipeak(1,i),ipeak(2,i)
5954         do ip=ipeak(1,i),ipeak(2,i)
5955           ii=ihpb_peak(ip)
5956           jj=jhpb_peak(ip)
5957           dd=dist(ii,jj)
5958           iip=ip-ipeak(1,i)+1
5959 C iii and jjj point to the residues for which the distance is assigned.
5960 c          if (ii.gt.nres) then
5961 c            iii=ii-nres
5962 c            jjj=jj-nres
5963 c          else
5964 c            iii=ii
5965 c            jjj=jj
5966 c          endif
5967           if (ii.gt.nres) then
5968             iii=ii-nres
5969           else
5970             iii=ii
5971           endif
5972           if (jj.gt.nres) then
5973             jjj=jj-nres
5974           else
5975             jjj=jj
5976           endif
5977           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5978           aux=dexp(-scal_peak*aux)
5979           ehpb_peak=ehpb_peak+aux
5980           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5981      &      forcon_peak(ip))*aux/dd
5982           do j=1,3
5983             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5984           enddo
5985           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5986      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5987      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5988         enddo
5989 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5990         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5991         do ip=ipeak(1,i),ipeak(2,i)
5992           iip=ip-ipeak(1,i)+1
5993           do j=1,3
5994             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5995           enddo
5996           ii=ihpb_peak(ip)
5997           jj=jhpb_peak(ip)
5998 C iii and jjj point to the residues for which the distance is assigned.
5999 c          if (ii.gt.nres) then
6000 c            iii=ii-nres
6001 c            jjj=jj-nres
6002 c          else
6003 c            iii=ii
6004 c            jjj=jj
6005 c          endif
6006           if (ii.gt.nres) then
6007             iii=ii-nres
6008           else
6009             iii=ii
6010           endif
6011           if (jj.gt.nres) then
6012             jjj=jj-nres
6013           else
6014             jjj=jj
6015           endif
6016           if (iii.lt.ii) then
6017             do j=1,3
6018               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6019             enddo
6020           endif
6021           if (jjj.lt.jj) then
6022             do j=1,3
6023               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6024             enddo
6025           endif
6026           do k=1,3
6027             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6028             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6029           enddo
6030         enddo
6031       enddo
6032       do i=link_start,link_end
6033 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6034 C CA-CA distance used in regularization of structure.
6035         ii=ihpb(i)
6036         jj=jhpb(i)
6037 C iii and jjj point to the residues for which the distance is assigned.
6038         if (ii.gt.nres) then
6039           iii=ii-nres
6040         else
6041           iii=ii
6042         endif
6043         if (jj.gt.nres) then
6044           jjj=jj-nres
6045         else
6046           jjj=jj
6047         endif
6048 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6049 c     &    dhpb(i),dhpb1(i),forcon(i)
6050 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6051 C    distance and angle dependent SS bond potential.
6052 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6053 C     & iabs(itype(jjj)).eq.1) then
6054 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6055 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6056         if (.not.dyn_ss .and. i.le.nss) then
6057 C 15/02/13 CC dynamic SSbond - additional check
6058           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6059      &        iabs(itype(jjj)).eq.1) then
6060            call ssbond_ene(iii,jjj,eij)
6061            ehpb=ehpb+2*eij
6062          endif
6063 cd          write (iout,*) "eij",eij
6064 cd   &   ' waga=',waga,' fac=',fac
6065 !        else if (ii.gt.nres .and. jj.gt.nres) then
6066         else
6067 C Calculate the distance between the two points and its difference from the
6068 C target distance.
6069           dd=dist(ii,jj)
6070           if (irestr_type(i).eq.11) then
6071             ehpb=ehpb+fordepth(i)!**4.0d0
6072      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6073             fac=fordepth(i)!**4.0d0
6074      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6075             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6076      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6077      &        ehpb,irestr_type(i)
6078           else if (irestr_type(i).eq.10) then
6079 c AL 6//19/2018 cross-link restraints
6080             xdis = 0.5d0*(dd/forcon(i))**2
6081             expdis = dexp(-xdis)
6082 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6083             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6084 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6085 c     &          " wboltzd",wboltzd
6086             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6087 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6088             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6089      &           *expdis/(aux*forcon(i)**2)
6090             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6091      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6092      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6093           else if (irestr_type(i).eq.2) then
6094 c Quartic restraints
6095             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6096             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6097      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6098      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6099             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6100           else
6101 c Quadratic restraints
6102             rdis=dd-dhpb(i)
6103 C Get the force constant corresponding to this distance.
6104             waga=forcon(i)
6105 C Calculate the contribution to energy.
6106             ehpb=ehpb+0.5d0*waga*rdis*rdis
6107             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6108      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6109      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6110 C
6111 C Evaluate gradient.
6112 C
6113             fac=waga*rdis/dd
6114           endif
6115 c Calculate Cartesian gradient
6116           do j=1,3
6117             ggg(j)=fac*(c(j,jj)-c(j,ii))
6118           enddo
6119 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6120 C If this is a SC-SC distance, we need to calculate the contributions to the
6121 C Cartesian gradient in the SC vectors (ghpbx).
6122           if (iii.lt.ii) then
6123             do j=1,3
6124               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6125             enddo
6126           endif
6127           if (jjj.lt.jj) then
6128             do j=1,3
6129               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6130             enddo
6131           endif
6132           do k=1,3
6133             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6134             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6135           enddo
6136         endif
6137       enddo
6138       return
6139       end
6140 C--------------------------------------------------------------------------
6141       subroutine ssbond_ene(i,j,eij)
6142 C
6143 C Calculate the distance and angle dependent SS-bond potential energy
6144 C using a free-energy function derived based on RHF/6-31G** ab initio
6145 C calculations of diethyl disulfide.
6146 C
6147 C A. Liwo and U. Kozlowska, 11/24/03
6148 C
6149       implicit real*8 (a-h,o-z)
6150       include 'DIMENSIONS'
6151       include 'COMMON.SBRIDGE'
6152       include 'COMMON.CHAIN'
6153       include 'COMMON.DERIV'
6154       include 'COMMON.LOCAL'
6155       include 'COMMON.INTERACT'
6156       include 'COMMON.VAR'
6157       include 'COMMON.IOUNITS'
6158       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6159       itypi=iabs(itype(i))
6160       xi=c(1,nres+i)
6161       yi=c(2,nres+i)
6162       zi=c(3,nres+i)
6163       dxi=dc_norm(1,nres+i)
6164       dyi=dc_norm(2,nres+i)
6165       dzi=dc_norm(3,nres+i)
6166 c      dsci_inv=dsc_inv(itypi)
6167       dsci_inv=vbld_inv(nres+i)
6168       itypj=iabs(itype(j))
6169 c      dscj_inv=dsc_inv(itypj)
6170       dscj_inv=vbld_inv(nres+j)
6171       xj=c(1,nres+j)-xi
6172       yj=c(2,nres+j)-yi
6173       zj=c(3,nres+j)-zi
6174       dxj=dc_norm(1,nres+j)
6175       dyj=dc_norm(2,nres+j)
6176       dzj=dc_norm(3,nres+j)
6177       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6178       rij=dsqrt(rrij)
6179       erij(1)=xj*rij
6180       erij(2)=yj*rij
6181       erij(3)=zj*rij
6182       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6183       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6184       om12=dxi*dxj+dyi*dyj+dzi*dzj
6185       do k=1,3
6186         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6187         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6188       enddo
6189       rij=1.0d0/rij
6190       deltad=rij-d0cm
6191       deltat1=1.0d0-om1
6192       deltat2=1.0d0+om2
6193       deltat12=om2-om1+2.0d0
6194       cosphi=om12-om1*om2
6195       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6196      &  +akct*deltad*deltat12
6197      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6198 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6199 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6200 c     &  " deltat12",deltat12," eij",eij
6201       ed=2*akcm*deltad+akct*deltat12
6202       pom1=akct*deltad
6203       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6204       eom1=-2*akth*deltat1-pom1-om2*pom2
6205       eom2= 2*akth*deltat2+pom1-om1*pom2
6206       eom12=pom2
6207       do k=1,3
6208         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6209         ghpbx(k,i)=ghpbx(k,i)-ggk
6210      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6211      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6212         ghpbx(k,j)=ghpbx(k,j)+ggk
6213      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6214      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6215         ghpbc(k,i)=ghpbc(k,i)-ggk
6216         ghpbc(k,j)=ghpbc(k,j)+ggk
6217       enddo
6218 C
6219 C Calculate the components of the gradient in DC and X
6220 C
6221 cgrad      do k=i,j-1
6222 cgrad        do l=1,3
6223 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6224 cgrad        enddo
6225 cgrad      enddo
6226       return
6227       end
6228 C--------------------------------------------------------------------------
6229       subroutine ebond(estr)
6230 c
6231 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6232 c
6233       implicit real*8 (a-h,o-z)
6234       include 'DIMENSIONS'
6235       include 'COMMON.LOCAL'
6236       include 'COMMON.GEO'
6237       include 'COMMON.INTERACT'
6238       include 'COMMON.DERIV'
6239       include 'COMMON.VAR'
6240       include 'COMMON.CHAIN'
6241       include 'COMMON.IOUNITS'
6242       include 'COMMON.NAMES'
6243       include 'COMMON.FFIELD'
6244       include 'COMMON.CONTROL'
6245       include 'COMMON.SETUP'
6246       double precision u(3),ud(3)
6247       estr=0.0d0
6248       estr1=0.0d0
6249       do i=ibondp_start,ibondp_end
6250 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6251 c      used
6252 #ifdef FIVEDIAG
6253         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6254         diff = vbld(i)-vbldp0
6255 #else
6256         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6257 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6258 c          do j=1,3
6259 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6260 c     &      *dc(j,i-1)/vbld(i)
6261 c          enddo
6262 c          if (energy_dec) write(iout,*)
6263 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6264 c        else
6265 C       Checking if it involves dummy (NH3+ or COO-) group
6266         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6267 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6268           diff = vbld(i)-vbldpDUM
6269           if (energy_dec) write(iout,*) "dum_bond",i,diff
6270         else
6271 C NO    vbldp0 is the equlibrium length of spring for peptide group
6272           diff = vbld(i)-vbldp0
6273         endif
6274 #endif
6275         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6276      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6277         estr=estr+diff*diff
6278         do j=1,3
6279           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6280         enddo
6281 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6282 c        endif
6283       enddo
6284
6285       estr=0.5d0*AKP*estr+estr1
6286 c
6287 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6288 c
6289       do i=ibond_start,ibond_end
6290         iti=iabs(itype(i))
6291         if (iti.ne.10 .and. iti.ne.ntyp1) then
6292           nbi=nbondterm(iti)
6293           if (nbi.eq.1) then
6294             diff=vbld(i+nres)-vbldsc0(1,iti)
6295             if (energy_dec)  write (iout,*)
6296      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6297      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6298             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6299             do j=1,3
6300               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6301             enddo
6302           else
6303             do j=1,nbi
6304               diff=vbld(i+nres)-vbldsc0(j,iti)
6305               ud(j)=aksc(j,iti)*diff
6306               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6307             enddo
6308             uprod=u(1)
6309             do j=2,nbi
6310               uprod=uprod*u(j)
6311             enddo
6312             usum=0.0d0
6313             usumsqder=0.0d0
6314             do j=1,nbi
6315               uprod1=1.0d0
6316               uprod2=1.0d0
6317               do k=1,nbi
6318                 if (k.ne.j) then
6319                   uprod1=uprod1*u(k)
6320                   uprod2=uprod2*u(k)*u(k)
6321                 endif
6322               enddo
6323               usum=usum+uprod1
6324               usumsqder=usumsqder+ud(j)*uprod2
6325             enddo
6326             estr=estr+uprod/usum
6327             do j=1,3
6328              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6329             enddo
6330           endif
6331         endif
6332       enddo
6333       return
6334       end
6335 #ifdef CRYST_THETA
6336 C--------------------------------------------------------------------------
6337       subroutine ebend(etheta)
6338 C
6339 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6340 C angles gamma and its derivatives in consecutive thetas and gammas.
6341 C
6342       implicit real*8 (a-h,o-z)
6343       include 'DIMENSIONS'
6344       include 'COMMON.LOCAL'
6345       include 'COMMON.GEO'
6346       include 'COMMON.INTERACT'
6347       include 'COMMON.DERIV'
6348       include 'COMMON.VAR'
6349       include 'COMMON.CHAIN'
6350       include 'COMMON.IOUNITS'
6351       include 'COMMON.NAMES'
6352       include 'COMMON.FFIELD'
6353       include 'COMMON.CONTROL'
6354       include 'COMMON.TORCNSTR'
6355       common /calcthet/ term1,term2,termm,diffak,ratak,
6356      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6357      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6358       double precision y(2),z(2)
6359       delta=0.02d0*pi
6360 c      time11=dexp(-2*time)
6361 c      time12=1.0d0
6362       etheta=0.0D0
6363 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6364       do i=ithet_start,ithet_end
6365         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6366      &  .or.itype(i).eq.ntyp1) cycle
6367 C Zero the energy function and its derivative at 0 or pi.
6368         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6369         it=itype(i-1)
6370         ichir1=isign(1,itype(i-2))
6371         ichir2=isign(1,itype(i))
6372          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6373          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6374          if (itype(i-1).eq.10) then
6375           itype1=isign(10,itype(i-2))
6376           ichir11=isign(1,itype(i-2))
6377           ichir12=isign(1,itype(i-2))
6378           itype2=isign(10,itype(i))
6379           ichir21=isign(1,itype(i))
6380           ichir22=isign(1,itype(i))
6381          endif
6382
6383         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6384 #ifdef OSF
6385           phii=phi(i)
6386           if (phii.ne.phii) phii=150.0
6387 #else
6388           phii=phi(i)
6389 #endif
6390           y(1)=dcos(phii)
6391           y(2)=dsin(phii)
6392         else
6393           y(1)=0.0D0
6394           y(2)=0.0D0
6395         endif
6396         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6397 #ifdef OSF
6398           phii1=phi(i+1)
6399           if (phii1.ne.phii1) phii1=150.0
6400           phii1=pinorm(phii1)
6401           z(1)=cos(phii1)
6402 #else
6403           phii1=phi(i+1)
6404 #endif
6405           z(1)=dcos(phii1)
6406           z(2)=dsin(phii1)
6407         else
6408           z(1)=0.0D0
6409           z(2)=0.0D0
6410         endif
6411 C Calculate the "mean" value of theta from the part of the distribution
6412 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6413 C In following comments this theta will be referred to as t_c.
6414         thet_pred_mean=0.0d0
6415         do k=1,2
6416             athetk=athet(k,it,ichir1,ichir2)
6417             bthetk=bthet(k,it,ichir1,ichir2)
6418           if (it.eq.10) then
6419              athetk=athet(k,itype1,ichir11,ichir12)
6420              bthetk=bthet(k,itype2,ichir21,ichir22)
6421           endif
6422          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6423 c         write(iout,*) 'chuj tu', y(k),z(k)
6424         enddo
6425         dthett=thet_pred_mean*ssd
6426         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6427 C Derivatives of the "mean" values in gamma1 and gamma2.
6428         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6429      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6430          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6431      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6432          if (it.eq.10) then
6433       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6434      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6435         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6436      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6437          endif
6438         if (theta(i).gt.pi-delta) then
6439           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6440      &         E_tc0)
6441           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6442           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6443           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6444      &        E_theta)
6445           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6446      &        E_tc)
6447         else if (theta(i).lt.delta) then
6448           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6449           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6450           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6451      &        E_theta)
6452           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6453           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6454      &        E_tc)
6455         else
6456           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6457      &        E_theta,E_tc)
6458         endif
6459         etheta=etheta+ethetai
6460         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6461      &      'ebend',i,ethetai,theta(i),itype(i)
6462         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6463         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6464         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6465       enddo
6466
6467 C Ufff.... We've done all this!!!
6468       return
6469       end
6470 C---------------------------------------------------------------------------
6471       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6472      &     E_tc)
6473       implicit real*8 (a-h,o-z)
6474       include 'DIMENSIONS'
6475       include 'COMMON.LOCAL'
6476       include 'COMMON.IOUNITS'
6477       common /calcthet/ term1,term2,termm,diffak,ratak,
6478      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6479      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6480 C Calculate the contributions to both Gaussian lobes.
6481 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6482 C The "polynomial part" of the "standard deviation" of this part of
6483 C the distributioni.
6484 ccc        write (iout,*) thetai,thet_pred_mean
6485         sig=polthet(3,it)
6486         do j=2,0,-1
6487           sig=sig*thet_pred_mean+polthet(j,it)
6488         enddo
6489 C Derivative of the "interior part" of the "standard deviation of the"
6490 C gamma-dependent Gaussian lobe in t_c.
6491         sigtc=3*polthet(3,it)
6492         do j=2,1,-1
6493           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6494         enddo
6495         sigtc=sig*sigtc
6496 C Set the parameters of both Gaussian lobes of the distribution.
6497 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6498         fac=sig*sig+sigc0(it)
6499         sigcsq=fac+fac
6500         sigc=1.0D0/sigcsq
6501 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6502         sigsqtc=-4.0D0*sigcsq*sigtc
6503 c       print *,i,sig,sigtc,sigsqtc
6504 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6505         sigtc=-sigtc/(fac*fac)
6506 C Following variable is sigma(t_c)**(-2)
6507         sigcsq=sigcsq*sigcsq
6508         sig0i=sig0(it)
6509         sig0inv=1.0D0/sig0i**2
6510         delthec=thetai-thet_pred_mean
6511         delthe0=thetai-theta0i
6512         term1=-0.5D0*sigcsq*delthec*delthec
6513         term2=-0.5D0*sig0inv*delthe0*delthe0
6514 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6515 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6516 C NaNs in taking the logarithm. We extract the largest exponent which is added
6517 C to the energy (this being the log of the distribution) at the end of energy
6518 C term evaluation for this virtual-bond angle.
6519         if (term1.gt.term2) then
6520           termm=term1
6521           term2=dexp(term2-termm)
6522           term1=1.0d0
6523         else
6524           termm=term2
6525           term1=dexp(term1-termm)
6526           term2=1.0d0
6527         endif
6528 C The ratio between the gamma-independent and gamma-dependent lobes of
6529 C the distribution is a Gaussian function of thet_pred_mean too.
6530         diffak=gthet(2,it)-thet_pred_mean
6531         ratak=diffak/gthet(3,it)**2
6532         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6533 C Let's differentiate it in thet_pred_mean NOW.
6534         aktc=ak*ratak
6535 C Now put together the distribution terms to make complete distribution.
6536         termexp=term1+ak*term2
6537         termpre=sigc+ak*sig0i
6538 C Contribution of the bending energy from this theta is just the -log of
6539 C the sum of the contributions from the two lobes and the pre-exponential
6540 C factor. Simple enough, isn't it?
6541         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6542 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6543 C NOW the derivatives!!!
6544 C 6/6/97 Take into account the deformation.
6545         E_theta=(delthec*sigcsq*term1
6546      &       +ak*delthe0*sig0inv*term2)/termexp
6547         E_tc=((sigtc+aktc*sig0i)/termpre
6548      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6549      &       aktc*term2)/termexp)
6550       return
6551       end
6552 c-----------------------------------------------------------------------------
6553       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6554       implicit real*8 (a-h,o-z)
6555       include 'DIMENSIONS'
6556       include 'COMMON.LOCAL'
6557       include 'COMMON.IOUNITS'
6558       common /calcthet/ term1,term2,termm,diffak,ratak,
6559      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6560      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6561       delthec=thetai-thet_pred_mean
6562       delthe0=thetai-theta0i
6563 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6564       t3 = thetai-thet_pred_mean
6565       t6 = t3**2
6566       t9 = term1
6567       t12 = t3*sigcsq
6568       t14 = t12+t6*sigsqtc
6569       t16 = 1.0d0
6570       t21 = thetai-theta0i
6571       t23 = t21**2
6572       t26 = term2
6573       t27 = t21*t26
6574       t32 = termexp
6575       t40 = t32**2
6576       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6577      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6578      & *(-t12*t9-ak*sig0inv*t27)
6579       return
6580       end
6581 #else
6582 C--------------------------------------------------------------------------
6583       subroutine ebend(etheta)
6584 C
6585 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6586 C angles gamma and its derivatives in consecutive thetas and gammas.
6587 C ab initio-derived potentials from
6588 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6589 C
6590       implicit real*8 (a-h,o-z)
6591       include 'DIMENSIONS'
6592       include 'COMMON.LOCAL'
6593       include 'COMMON.GEO'
6594       include 'COMMON.INTERACT'
6595       include 'COMMON.DERIV'
6596       include 'COMMON.VAR'
6597       include 'COMMON.CHAIN'
6598       include 'COMMON.IOUNITS'
6599       include 'COMMON.NAMES'
6600       include 'COMMON.FFIELD'
6601       include 'COMMON.CONTROL'
6602       include 'COMMON.TORCNSTR'
6603       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6604      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6605      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6606      & sinph1ph2(maxdouble,maxdouble)
6607       logical lprn /.false./, lprn1 /.false./
6608       etheta=0.0D0
6609       do i=ithet_start,ithet_end
6610 c        print *,i,itype(i-1),itype(i),itype(i-2)
6611         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6612      &  .or.itype(i).eq.ntyp1) cycle
6613 C        print *,i,theta(i)
6614         if (iabs(itype(i+1)).eq.20) iblock=2
6615         if (iabs(itype(i+1)).ne.20) iblock=1
6616         dethetai=0.0d0
6617         dephii=0.0d0
6618         dephii1=0.0d0
6619         theti2=0.5d0*theta(i)
6620         ityp2=ithetyp((itype(i-1)))
6621         do k=1,nntheterm
6622           coskt(k)=dcos(k*theti2)
6623           sinkt(k)=dsin(k*theti2)
6624         enddo
6625 C        print *,ethetai
6626         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6627 #ifdef OSF
6628           phii=phi(i)
6629           if (phii.ne.phii) phii=150.0
6630 #else
6631           phii=phi(i)
6632 #endif
6633           ityp1=ithetyp((itype(i-2)))
6634 C propagation of chirality for glycine type
6635           do k=1,nsingle
6636             cosph1(k)=dcos(k*phii)
6637             sinph1(k)=dsin(k*phii)
6638           enddo
6639         else
6640           phii=0.0d0
6641           do k=1,nsingle
6642           ityp1=ithetyp((itype(i-2)))
6643             cosph1(k)=0.0d0
6644             sinph1(k)=0.0d0
6645           enddo
6646         endif
6647         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6648 #ifdef OSF
6649           phii1=phi(i+1)
6650           if (phii1.ne.phii1) phii1=150.0
6651           phii1=pinorm(phii1)
6652 #else
6653           phii1=phi(i+1)
6654 #endif
6655           ityp3=ithetyp((itype(i)))
6656           do k=1,nsingle
6657             cosph2(k)=dcos(k*phii1)
6658             sinph2(k)=dsin(k*phii1)
6659           enddo
6660         else
6661           phii1=0.0d0
6662           ityp3=ithetyp((itype(i)))
6663           do k=1,nsingle
6664             cosph2(k)=0.0d0
6665             sinph2(k)=0.0d0
6666           enddo
6667         endif
6668         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6669         do k=1,ndouble
6670           do l=1,k-1
6671             ccl=cosph1(l)*cosph2(k-l)
6672             ssl=sinph1(l)*sinph2(k-l)
6673             scl=sinph1(l)*cosph2(k-l)
6674             csl=cosph1(l)*sinph2(k-l)
6675             cosph1ph2(l,k)=ccl-ssl
6676             cosph1ph2(k,l)=ccl+ssl
6677             sinph1ph2(l,k)=scl+csl
6678             sinph1ph2(k,l)=scl-csl
6679           enddo
6680         enddo
6681         if (lprn) then
6682         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6683      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6684         write (iout,*) "coskt and sinkt"
6685         do k=1,nntheterm
6686           write (iout,*) k,coskt(k),sinkt(k)
6687         enddo
6688         endif
6689         do k=1,ntheterm
6690           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6691           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6692      &      *coskt(k)
6693           if (lprn)
6694      &    write (iout,*) "k",k,"
6695      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6696      &     " ethetai",ethetai
6697         enddo
6698         if (lprn) then
6699         write (iout,*) "cosph and sinph"
6700         do k=1,nsingle
6701           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6702         enddo
6703         write (iout,*) "cosph1ph2 and sinph2ph2"
6704         do k=2,ndouble
6705           do l=1,k-1
6706             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6707      &         sinph1ph2(l,k),sinph1ph2(k,l)
6708           enddo
6709         enddo
6710         write(iout,*) "ethetai",ethetai
6711         endif
6712 C       print *,ethetai
6713         do m=1,ntheterm2
6714           do k=1,nsingle
6715             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6716      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6717      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6718      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6719             ethetai=ethetai+sinkt(m)*aux
6720             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6721             dephii=dephii+k*sinkt(m)*(
6722      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6723      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6724             dephii1=dephii1+k*sinkt(m)*(
6725      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6726      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6727             if (lprn)
6728      &      write (iout,*) "m",m," k",k," bbthet",
6729      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6730      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6731      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6732      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6733 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6734           enddo
6735         enddo
6736 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6737 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6738 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6739 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6740         if (lprn)
6741      &  write(iout,*) "ethetai",ethetai
6742 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6743         do m=1,ntheterm3
6744           do k=2,ndouble
6745             do l=1,k-1
6746               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6747      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6748      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6749      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6750               ethetai=ethetai+sinkt(m)*aux
6751               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6752               dephii=dephii+l*sinkt(m)*(
6753      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6754      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6755      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6756      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6757               dephii1=dephii1+(k-l)*sinkt(m)*(
6758      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6759      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6760      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6761      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6762               if (lprn) then
6763               write (iout,*) "m",m," k",k," l",l," ffthet",
6764      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6765      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6766      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6767      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6768      &            " ethetai",ethetai
6769               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6770      &            cosph1ph2(k,l)*sinkt(m),
6771      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6772               endif
6773             enddo
6774           enddo
6775         enddo
6776 10      continue
6777 c        lprn1=.true.
6778 C        print *,ethetai
6779         if (lprn1)
6780      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6781      &   i,theta(i)*rad2deg,phii*rad2deg,
6782      &   phii1*rad2deg,ethetai
6783 c        lprn1=.false.
6784         etheta=etheta+ethetai
6785         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6786         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6787         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6788       enddo
6789
6790       return
6791       end
6792 #endif
6793 #ifdef CRYST_SC
6794 c-----------------------------------------------------------------------------
6795       subroutine esc(escloc)
6796 C Calculate the local energy of a side chain and its derivatives in the
6797 C corresponding virtual-bond valence angles THETA and the spherical angles
6798 C ALPHA and OMEGA.
6799       implicit real*8 (a-h,o-z)
6800       include 'DIMENSIONS'
6801       include 'COMMON.GEO'
6802       include 'COMMON.LOCAL'
6803       include 'COMMON.VAR'
6804       include 'COMMON.INTERACT'
6805       include 'COMMON.DERIV'
6806       include 'COMMON.CHAIN'
6807       include 'COMMON.IOUNITS'
6808       include 'COMMON.NAMES'
6809       include 'COMMON.FFIELD'
6810       include 'COMMON.CONTROL'
6811       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6812      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6813       common /sccalc/ time11,time12,time112,theti,it,nlobit
6814       delta=0.02d0*pi
6815       escloc=0.0D0
6816 c     write (iout,'(a)') 'ESC'
6817       do i=loc_start,loc_end
6818         it=itype(i)
6819         if (it.eq.ntyp1) cycle
6820         if (it.eq.10) goto 1
6821         nlobit=nlob(iabs(it))
6822 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6823 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6824         theti=theta(i+1)-pipol
6825         x(1)=dtan(theti)
6826         x(2)=alph(i)
6827         x(3)=omeg(i)
6828
6829         if (x(2).gt.pi-delta) then
6830           xtemp(1)=x(1)
6831           xtemp(2)=pi-delta
6832           xtemp(3)=x(3)
6833           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6834           xtemp(2)=pi
6835           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6836           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6837      &        escloci,dersc(2))
6838           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6839      &        ddersc0(1),dersc(1))
6840           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6841      &        ddersc0(3),dersc(3))
6842           xtemp(2)=pi-delta
6843           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6844           xtemp(2)=pi
6845           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6846           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6847      &            dersc0(2),esclocbi,dersc02)
6848           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6849      &            dersc12,dersc01)
6850           call splinthet(x(2),0.5d0*delta,ss,ssd)
6851           dersc0(1)=dersc01
6852           dersc0(2)=dersc02
6853           dersc0(3)=0.0d0
6854           do k=1,3
6855             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6856           enddo
6857           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6858 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6859 c    &             esclocbi,ss,ssd
6860           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6861 c         escloci=esclocbi
6862 c         write (iout,*) escloci
6863         else if (x(2).lt.delta) then
6864           xtemp(1)=x(1)
6865           xtemp(2)=delta
6866           xtemp(3)=x(3)
6867           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6868           xtemp(2)=0.0d0
6869           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6870           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6871      &        escloci,dersc(2))
6872           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6873      &        ddersc0(1),dersc(1))
6874           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6875      &        ddersc0(3),dersc(3))
6876           xtemp(2)=delta
6877           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6878           xtemp(2)=0.0d0
6879           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6880           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6881      &            dersc0(2),esclocbi,dersc02)
6882           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6883      &            dersc12,dersc01)
6884           dersc0(1)=dersc01
6885           dersc0(2)=dersc02
6886           dersc0(3)=0.0d0
6887           call splinthet(x(2),0.5d0*delta,ss,ssd)
6888           do k=1,3
6889             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6890           enddo
6891           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6892 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6893 c    &             esclocbi,ss,ssd
6894           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6895 c         write (iout,*) escloci
6896         else
6897           call enesc(x,escloci,dersc,ddummy,.false.)
6898         endif
6899
6900         escloc=escloc+escloci
6901         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6902      &     'escloc',i,escloci
6903 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6904
6905         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6906      &   wscloc*dersc(1)
6907         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6908         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6909     1   continue
6910       enddo
6911       return
6912       end
6913 C---------------------------------------------------------------------------
6914       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6915       implicit real*8 (a-h,o-z)
6916       include 'DIMENSIONS'
6917       include 'COMMON.GEO'
6918       include 'COMMON.LOCAL'
6919       include 'COMMON.IOUNITS'
6920       common /sccalc/ time11,time12,time112,theti,it,nlobit
6921       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6922       double precision contr(maxlob,-1:1)
6923       logical mixed
6924 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6925         escloc_i=0.0D0
6926         do j=1,3
6927           dersc(j)=0.0D0
6928           if (mixed) ddersc(j)=0.0d0
6929         enddo
6930         x3=x(3)
6931
6932 C Because of periodicity of the dependence of the SC energy in omega we have
6933 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6934 C To avoid underflows, first compute & store the exponents.
6935
6936         do iii=-1,1
6937
6938           x(3)=x3+iii*dwapi
6939
6940           do j=1,nlobit
6941             do k=1,3
6942               z(k)=x(k)-censc(k,j,it)
6943             enddo
6944             do k=1,3
6945               Axk=0.0D0
6946               do l=1,3
6947                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6948               enddo
6949               Ax(k,j,iii)=Axk
6950             enddo
6951             expfac=0.0D0
6952             do k=1,3
6953               expfac=expfac+Ax(k,j,iii)*z(k)
6954             enddo
6955             contr(j,iii)=expfac
6956           enddo ! j
6957
6958         enddo ! iii
6959
6960         x(3)=x3
6961 C As in the case of ebend, we want to avoid underflows in exponentiation and
6962 C subsequent NaNs and INFs in energy calculation.
6963 C Find the largest exponent
6964         emin=contr(1,-1)
6965         do iii=-1,1
6966           do j=1,nlobit
6967             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6968           enddo
6969         enddo
6970         emin=0.5D0*emin
6971 cd      print *,'it=',it,' emin=',emin
6972
6973 C Compute the contribution to SC energy and derivatives
6974         do iii=-1,1
6975
6976           do j=1,nlobit
6977 #ifdef OSF
6978             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6979             if(adexp.ne.adexp) adexp=1.0
6980             expfac=dexp(adexp)
6981 #else
6982             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6983 #endif
6984 cd          print *,'j=',j,' expfac=',expfac
6985             escloc_i=escloc_i+expfac
6986             do k=1,3
6987               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6988             enddo
6989             if (mixed) then
6990               do k=1,3,2
6991                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6992      &            +gaussc(k,2,j,it))*expfac
6993               enddo
6994             endif
6995           enddo
6996
6997         enddo ! iii
6998
6999         dersc(1)=dersc(1)/cos(theti)**2
7000         ddersc(1)=ddersc(1)/cos(theti)**2
7001         ddersc(3)=ddersc(3)
7002
7003         escloci=-(dlog(escloc_i)-emin)
7004         do j=1,3
7005           dersc(j)=dersc(j)/escloc_i
7006         enddo
7007         if (mixed) then
7008           do j=1,3,2
7009             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7010           enddo
7011         endif
7012       return
7013       end
7014 C------------------------------------------------------------------------------
7015       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7016       implicit real*8 (a-h,o-z)
7017       include 'DIMENSIONS'
7018       include 'COMMON.GEO'
7019       include 'COMMON.LOCAL'
7020       include 'COMMON.IOUNITS'
7021       common /sccalc/ time11,time12,time112,theti,it,nlobit
7022       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7023       double precision contr(maxlob)
7024       logical mixed
7025
7026       escloc_i=0.0D0
7027
7028       do j=1,3
7029         dersc(j)=0.0D0
7030       enddo
7031
7032       do j=1,nlobit
7033         do k=1,2
7034           z(k)=x(k)-censc(k,j,it)
7035         enddo
7036         z(3)=dwapi
7037         do k=1,3
7038           Axk=0.0D0
7039           do l=1,3
7040             Axk=Axk+gaussc(l,k,j,it)*z(l)
7041           enddo
7042           Ax(k,j)=Axk
7043         enddo
7044         expfac=0.0D0
7045         do k=1,3
7046           expfac=expfac+Ax(k,j)*z(k)
7047         enddo
7048         contr(j)=expfac
7049       enddo ! j
7050
7051 C As in the case of ebend, we want to avoid underflows in exponentiation and
7052 C subsequent NaNs and INFs in energy calculation.
7053 C Find the largest exponent
7054       emin=contr(1)
7055       do j=1,nlobit
7056         if (emin.gt.contr(j)) emin=contr(j)
7057       enddo
7058       emin=0.5D0*emin
7059
7060 C Compute the contribution to SC energy and derivatives
7061
7062       dersc12=0.0d0
7063       do j=1,nlobit
7064         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7065         escloc_i=escloc_i+expfac
7066         do k=1,2
7067           dersc(k)=dersc(k)+Ax(k,j)*expfac
7068         enddo
7069         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7070      &            +gaussc(1,2,j,it))*expfac
7071         dersc(3)=0.0d0
7072       enddo
7073
7074       dersc(1)=dersc(1)/cos(theti)**2
7075       dersc12=dersc12/cos(theti)**2
7076       escloci=-(dlog(escloc_i)-emin)
7077       do j=1,2
7078         dersc(j)=dersc(j)/escloc_i
7079       enddo
7080       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7081       return
7082       end
7083 #else
7084 c----------------------------------------------------------------------------------
7085       subroutine esc(escloc)
7086 C Calculate the local energy of a side chain and its derivatives in the
7087 C corresponding virtual-bond valence angles THETA and the spherical angles
7088 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7089 C added by Urszula Kozlowska. 07/11/2007
7090 C
7091       implicit real*8 (a-h,o-z)
7092       include 'DIMENSIONS'
7093       include 'COMMON.GEO'
7094       include 'COMMON.LOCAL'
7095       include 'COMMON.VAR'
7096       include 'COMMON.SCROT'
7097       include 'COMMON.INTERACT'
7098       include 'COMMON.DERIV'
7099       include 'COMMON.CHAIN'
7100       include 'COMMON.IOUNITS'
7101       include 'COMMON.NAMES'
7102       include 'COMMON.FFIELD'
7103       include 'COMMON.CONTROL'
7104       include 'COMMON.VECTORS'
7105       double precision x_prime(3),y_prime(3),z_prime(3)
7106      &    , sumene,dsc_i,dp2_i,x(65),
7107      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7108      &    de_dxx,de_dyy,de_dzz,de_dt
7109       double precision s1_t,s1_6_t,s2_t,s2_6_t
7110       double precision
7111      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7112      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7113      & dt_dCi(3),dt_dCi1(3)
7114       common /sccalc/ time11,time12,time112,theti,it,nlobit
7115       delta=0.02d0*pi
7116       escloc=0.0D0
7117       do i=loc_start,loc_end
7118         if (itype(i).eq.ntyp1) cycle
7119         costtab(i+1) =dcos(theta(i+1))
7120         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7121         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7122         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7123         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7124         cosfac=dsqrt(cosfac2)
7125         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7126         sinfac=dsqrt(sinfac2)
7127         it=iabs(itype(i))
7128         if (it.eq.10) goto 1
7129 c
7130 C  Compute the axes of tghe local cartesian coordinates system; store in
7131 c   x_prime, y_prime and z_prime
7132 c
7133         do j=1,3
7134           x_prime(j) = 0.00
7135           y_prime(j) = 0.00
7136           z_prime(j) = 0.00
7137         enddo
7138 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7139 C     &   dc_norm(3,i+nres)
7140         do j = 1,3
7141           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7142           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7143         enddo
7144         do j = 1,3
7145           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7146         enddo
7147 c       write (2,*) "i",i
7148 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7149 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7150 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7151 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7152 c      & " xy",scalar(x_prime(1),y_prime(1)),
7153 c      & " xz",scalar(x_prime(1),z_prime(1)),
7154 c      & " yy",scalar(y_prime(1),y_prime(1)),
7155 c      & " yz",scalar(y_prime(1),z_prime(1)),
7156 c      & " zz",scalar(z_prime(1),z_prime(1))
7157 c
7158 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7159 C to local coordinate system. Store in xx, yy, zz.
7160 c
7161         xx=0.0d0
7162         yy=0.0d0
7163         zz=0.0d0
7164         do j = 1,3
7165           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7166           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7167           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7168         enddo
7169
7170         xxtab(i)=xx
7171         yytab(i)=yy
7172         zztab(i)=zz
7173 C
7174 C Compute the energy of the ith side cbain
7175 C
7176 c        write (2,*) "xx",xx," yy",yy," zz",zz
7177         it=iabs(itype(i))
7178         do j = 1,65
7179           x(j) = sc_parmin(j,it)
7180         enddo
7181 #ifdef CHECK_COORD
7182 Cc diagnostics - remove later
7183         xx1 = dcos(alph(2))
7184         yy1 = dsin(alph(2))*dcos(omeg(2))
7185         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7186         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7187      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7188      &    xx1,yy1,zz1
7189 C,"  --- ", xx_w,yy_w,zz_w
7190 c end diagnostics
7191 #endif
7192         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7193      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7194      &   + x(10)*yy*zz
7195         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7196      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7197      & + x(20)*yy*zz
7198         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7199      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7200      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7201      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7202      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7203      &  +x(40)*xx*yy*zz
7204         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7205      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7206      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7207      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7208      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7209      &  +x(60)*xx*yy*zz
7210         dsc_i   = 0.743d0+x(61)
7211         dp2_i   = 1.9d0+x(62)
7212         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7213      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7214         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7215      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7216         s1=(1+x(63))/(0.1d0 + dscp1)
7217         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7218         s2=(1+x(65))/(0.1d0 + dscp2)
7219         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7220         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7221      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7222 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7223 c     &   sumene4,
7224 c     &   dscp1,dscp2,sumene
7225 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7226         escloc = escloc + sumene
7227         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7228      &   " escloc",sumene,escloc,it,itype(i)
7229 c     & ,zz,xx,yy
7230 c#define DEBUG
7231 #ifdef DEBUG
7232 C
7233 C This section to check the numerical derivatives of the energy of ith side
7234 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7235 C #define DEBUG in the code to turn it on.
7236 C
7237         write (2,*) "sumene               =",sumene
7238         aincr=1.0d-7
7239         xxsave=xx
7240         xx=xx+aincr
7241         write (2,*) xx,yy,zz
7242         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7243         de_dxx_num=(sumenep-sumene)/aincr
7244         xx=xxsave
7245         write (2,*) "xx+ sumene from enesc=",sumenep
7246         yysave=yy
7247         yy=yy+aincr
7248         write (2,*) xx,yy,zz
7249         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7250         de_dyy_num=(sumenep-sumene)/aincr
7251         yy=yysave
7252         write (2,*) "yy+ sumene from enesc=",sumenep
7253         zzsave=zz
7254         zz=zz+aincr
7255         write (2,*) xx,yy,zz
7256         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7257         de_dzz_num=(sumenep-sumene)/aincr
7258         zz=zzsave
7259         write (2,*) "zz+ sumene from enesc=",sumenep
7260         costsave=cost2tab(i+1)
7261         sintsave=sint2tab(i+1)
7262         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7263         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7264         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7265         de_dt_num=(sumenep-sumene)/aincr
7266         write (2,*) " t+ sumene from enesc=",sumenep
7267         cost2tab(i+1)=costsave
7268         sint2tab(i+1)=sintsave
7269 C End of diagnostics section.
7270 #endif
7271 C
7272 C Compute the gradient of esc
7273 C
7274 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7275         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7276         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7277         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7278         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7279         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7280         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7281         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7282         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7283         pom1=(sumene3*sint2tab(i+1)+sumene1)
7284      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7285         pom2=(sumene4*cost2tab(i+1)+sumene2)
7286      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7287         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7288         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7289      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7290      &  +x(40)*yy*zz
7291         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7292         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7293      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7294      &  +x(60)*yy*zz
7295         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7296      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7297      &        +(pom1+pom2)*pom_dx
7298 #ifdef DEBUG
7299         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7300 #endif
7301 C
7302         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7303         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7304      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7305      &  +x(40)*xx*zz
7306         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7307         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7308      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7309      &  +x(59)*zz**2 +x(60)*xx*zz
7310         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7311      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7312      &        +(pom1-pom2)*pom_dy
7313 #ifdef DEBUG
7314         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7315 #endif
7316 C
7317         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7318      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7319      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7320      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7321      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7322      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7323      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7324      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7325 #ifdef DEBUG
7326         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7327 #endif
7328 C
7329         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7330      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7331      &  +pom1*pom_dt1+pom2*pom_dt2
7332 #ifdef DEBUG
7333         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7334 #endif
7335 c#undef DEBUG
7336 c
7337 C
7338        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7339        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7340        cosfac2xx=cosfac2*xx
7341        sinfac2yy=sinfac2*yy
7342        do k = 1,3
7343          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7344      &      vbld_inv(i+1)
7345          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7346      &      vbld_inv(i)
7347          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7348          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7349 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7350 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7351 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7352 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7353          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7354          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7355          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7356          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7357          dZZ_Ci1(k)=0.0d0
7358          dZZ_Ci(k)=0.0d0
7359          do j=1,3
7360            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7361      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7362            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7363      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7364          enddo
7365
7366          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7367          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7368          dZZ_XYZ(k)=vbld_inv(i+nres)*
7369      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7370 c
7371          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7372          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7373        enddo
7374
7375        do k=1,3
7376          dXX_Ctab(k,i)=dXX_Ci(k)
7377          dXX_C1tab(k,i)=dXX_Ci1(k)
7378          dYY_Ctab(k,i)=dYY_Ci(k)
7379          dYY_C1tab(k,i)=dYY_Ci1(k)
7380          dZZ_Ctab(k,i)=dZZ_Ci(k)
7381          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7382          dXX_XYZtab(k,i)=dXX_XYZ(k)
7383          dYY_XYZtab(k,i)=dYY_XYZ(k)
7384          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7385        enddo
7386
7387        do k = 1,3
7388 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7389 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7390 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7391 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7392 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7393 c     &    dt_dci(k)
7394 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7395 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7396          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7397      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7398          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7399      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7400          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7401      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7402        enddo
7403 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7404 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7405
7406 C to check gradient call subroutine check_grad
7407
7408     1 continue
7409       enddo
7410       return
7411       end
7412 c------------------------------------------------------------------------------
7413       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7414       implicit none
7415       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7416      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7417       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7418      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7419      &   + x(10)*yy*zz
7420       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7421      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7422      & + x(20)*yy*zz
7423       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7424      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7425      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7426      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7427      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7428      &  +x(40)*xx*yy*zz
7429       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7430      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7431      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7432      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7433      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7434      &  +x(60)*xx*yy*zz
7435       dsc_i   = 0.743d0+x(61)
7436       dp2_i   = 1.9d0+x(62)
7437       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7438      &          *(xx*cost2+yy*sint2))
7439       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7440      &          *(xx*cost2-yy*sint2))
7441       s1=(1+x(63))/(0.1d0 + dscp1)
7442       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7443       s2=(1+x(65))/(0.1d0 + dscp2)
7444       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7445       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7446      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7447       enesc=sumene
7448       return
7449       end
7450 #endif
7451 c------------------------------------------------------------------------------
7452       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7453 C
7454 C This procedure calculates two-body contact function g(rij) and its derivative:
7455 C
7456 C           eps0ij                                     !       x < -1
7457 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7458 C            0                                         !       x > 1
7459 C
7460 C where x=(rij-r0ij)/delta
7461 C
7462 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7463 C
7464       implicit none
7465       double precision rij,r0ij,eps0ij,fcont,fprimcont
7466       double precision x,x2,x4,delta
7467 c     delta=0.02D0*r0ij
7468 c      delta=0.2D0*r0ij
7469       x=(rij-r0ij)/delta
7470       if (x.lt.-1.0D0) then
7471         fcont=eps0ij
7472         fprimcont=0.0D0
7473       else if (x.le.1.0D0) then
7474         x2=x*x
7475         x4=x2*x2
7476         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7477         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7478       else
7479         fcont=0.0D0
7480         fprimcont=0.0D0
7481       endif
7482       return
7483       end
7484 c------------------------------------------------------------------------------
7485       subroutine splinthet(theti,delta,ss,ssder)
7486       implicit real*8 (a-h,o-z)
7487       include 'DIMENSIONS'
7488       include 'COMMON.VAR'
7489       include 'COMMON.GEO'
7490       thetup=pi-delta
7491       thetlow=delta
7492       if (theti.gt.pipol) then
7493         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7494       else
7495         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7496         ssder=-ssder
7497       endif
7498       return
7499       end
7500 c------------------------------------------------------------------------------
7501       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7502       implicit none
7503       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7504       double precision ksi,ksi2,ksi3,a1,a2,a3
7505       a1=fprim0*delta/(f1-f0)
7506       a2=3.0d0-2.0d0*a1
7507       a3=a1-2.0d0
7508       ksi=(x-x0)/delta
7509       ksi2=ksi*ksi
7510       ksi3=ksi2*ksi
7511       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7512       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7513       return
7514       end
7515 c------------------------------------------------------------------------------
7516       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7517       implicit none
7518       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7519       double precision ksi,ksi2,ksi3,a1,a2,a3
7520       ksi=(x-x0)/delta
7521       ksi2=ksi*ksi
7522       ksi3=ksi2*ksi
7523       a1=fprim0x*delta
7524       a2=3*(f1x-f0x)-2*fprim0x*delta
7525       a3=fprim0x*delta-2*(f1x-f0x)
7526       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7527       return
7528       end
7529 C-----------------------------------------------------------------------------
7530 #ifdef CRYST_TOR
7531 C-----------------------------------------------------------------------------
7532       subroutine etor(etors)
7533       implicit real*8 (a-h,o-z)
7534       include 'DIMENSIONS'
7535       include 'COMMON.VAR'
7536       include 'COMMON.GEO'
7537       include 'COMMON.LOCAL'
7538       include 'COMMON.TORSION'
7539       include 'COMMON.INTERACT'
7540       include 'COMMON.DERIV'
7541       include 'COMMON.CHAIN'
7542       include 'COMMON.NAMES'
7543       include 'COMMON.IOUNITS'
7544       include 'COMMON.FFIELD'
7545       include 'COMMON.TORCNSTR'
7546       include 'COMMON.CONTROL'
7547       logical lprn
7548 C Set lprn=.true. for debugging
7549       lprn=.false.
7550 c      lprn=.true.
7551       etors=0.0D0
7552       do i=iphi_start,iphi_end
7553       etors_ii=0.0D0
7554         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7555      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7556         itori=itortyp(itype(i-2))
7557         itori1=itortyp(itype(i-1))
7558         phii=phi(i)
7559         gloci=0.0D0
7560 C Proline-Proline pair is a special case...
7561         if (itori.eq.3 .and. itori1.eq.3) then
7562           if (phii.gt.-dwapi3) then
7563             cosphi=dcos(3*phii)
7564             fac=1.0D0/(1.0D0-cosphi)
7565             etorsi=v1(1,3,3)*fac
7566             etorsi=etorsi+etorsi
7567             etors=etors+etorsi-v1(1,3,3)
7568             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7569             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7570           endif
7571           do j=1,3
7572             v1ij=v1(j+1,itori,itori1)
7573             v2ij=v2(j+1,itori,itori1)
7574             cosphi=dcos(j*phii)
7575             sinphi=dsin(j*phii)
7576             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7577             if (energy_dec) etors_ii=etors_ii+
7578      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7579             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7580           enddo
7581         else
7582           do j=1,nterm_old
7583             v1ij=v1(j,itori,itori1)
7584             v2ij=v2(j,itori,itori1)
7585             cosphi=dcos(j*phii)
7586             sinphi=dsin(j*phii)
7587             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7588             if (energy_dec) etors_ii=etors_ii+
7589      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7590             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7591           enddo
7592         endif
7593         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7594              'etor',i,etors_ii
7595         if (lprn)
7596      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7597      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7598      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7599         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7600 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7601       enddo
7602       return
7603       end
7604 c------------------------------------------------------------------------------
7605       subroutine etor_d(etors_d)
7606       etors_d=0.0d0
7607       return
7608       end
7609 c----------------------------------------------------------------------------
7610 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7611       subroutine e_modeller(ehomology_constr)
7612       ehomology_constr=0.0d0
7613       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7614       return
7615       end
7616 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7617
7618 c------------------------------------------------------------------------------
7619       subroutine etor_d(etors_d)
7620       etors_d=0.0d0
7621       return
7622       end
7623 c----------------------------------------------------------------------------
7624 #else
7625       subroutine etor(etors)
7626       implicit real*8 (a-h,o-z)
7627       include 'DIMENSIONS'
7628       include 'COMMON.VAR'
7629       include 'COMMON.GEO'
7630       include 'COMMON.LOCAL'
7631       include 'COMMON.TORSION'
7632       include 'COMMON.INTERACT'
7633       include 'COMMON.DERIV'
7634       include 'COMMON.CHAIN'
7635       include 'COMMON.NAMES'
7636       include 'COMMON.IOUNITS'
7637       include 'COMMON.FFIELD'
7638       include 'COMMON.TORCNSTR'
7639       include 'COMMON.CONTROL'
7640       logical lprn
7641 C Set lprn=.true. for debugging
7642       lprn=.false.
7643 c     lprn=.true.
7644       etors=0.0D0
7645       do i=iphi_start,iphi_end
7646 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7647 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7648 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7649 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7650         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7651      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7652 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7653 C For introducing the NH3+ and COO- group please check the etor_d for reference
7654 C and guidance
7655         etors_ii=0.0D0
7656          if (iabs(itype(i)).eq.20) then
7657          iblock=2
7658          else
7659          iblock=1
7660          endif
7661         itori=itortyp(itype(i-2))
7662         itori1=itortyp(itype(i-1))
7663         phii=phi(i)
7664         gloci=0.0D0
7665 C Regular cosine and sine terms
7666         do j=1,nterm(itori,itori1,iblock)
7667           v1ij=v1(j,itori,itori1,iblock)
7668           v2ij=v2(j,itori,itori1,iblock)
7669           cosphi=dcos(j*phii)
7670           sinphi=dsin(j*phii)
7671           etors=etors+v1ij*cosphi+v2ij*sinphi
7672           if (energy_dec) etors_ii=etors_ii+
7673      &                v1ij*cosphi+v2ij*sinphi
7674           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7675         enddo
7676 C Lorentz terms
7677 C                         v1
7678 C  E = SUM ----------------------------------- - v1
7679 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7680 C
7681         cosphi=dcos(0.5d0*phii)
7682         sinphi=dsin(0.5d0*phii)
7683         do j=1,nlor(itori,itori1,iblock)
7684           vl1ij=vlor1(j,itori,itori1)
7685           vl2ij=vlor2(j,itori,itori1)
7686           vl3ij=vlor3(j,itori,itori1)
7687           pom=vl2ij*cosphi+vl3ij*sinphi
7688           pom1=1.0d0/(pom*pom+1.0d0)
7689           etors=etors+vl1ij*pom1
7690           if (energy_dec) etors_ii=etors_ii+
7691      &                vl1ij*pom1
7692           pom=-pom*pom1*pom1
7693           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7694         enddo
7695 C Subtract the constant term
7696         etors=etors-v0(itori,itori1,iblock)
7697           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7698      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7699         if (lprn)
7700      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7701      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7702      &  (v1(j,itori,itori1,iblock),j=1,6),
7703      &  (v2(j,itori,itori1,iblock),j=1,6)
7704         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7705 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7706       enddo
7707       return
7708       end
7709 c----------------------------------------------------------------------------
7710       subroutine etor_d(etors_d)
7711 C 6/23/01 Compute double torsional energy
7712       implicit real*8 (a-h,o-z)
7713       include 'DIMENSIONS'
7714       include 'COMMON.VAR'
7715       include 'COMMON.GEO'
7716       include 'COMMON.LOCAL'
7717       include 'COMMON.TORSION'
7718       include 'COMMON.INTERACT'
7719       include 'COMMON.DERIV'
7720       include 'COMMON.CHAIN'
7721       include 'COMMON.NAMES'
7722       include 'COMMON.IOUNITS'
7723       include 'COMMON.FFIELD'
7724       include 'COMMON.TORCNSTR'
7725       logical lprn
7726 C Set lprn=.true. for debugging
7727       lprn=.false.
7728 c     lprn=.true.
7729       etors_d=0.0D0
7730 c      write(iout,*) "a tu??"
7731       do i=iphid_start,iphid_end
7732 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7733 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7734 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7735 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7736 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7737          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7738      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7739      &  (itype(i+1).eq.ntyp1)) cycle
7740 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7741         itori=itortyp(itype(i-2))
7742         itori1=itortyp(itype(i-1))
7743         itori2=itortyp(itype(i))
7744         phii=phi(i)
7745         phii1=phi(i+1)
7746         gloci1=0.0D0
7747         gloci2=0.0D0
7748         iblock=1
7749         if (iabs(itype(i+1)).eq.20) iblock=2
7750 C Iblock=2 Proline type
7751 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7752 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7753 C        if (itype(i+1).eq.ntyp1) iblock=3
7754 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7755 C IS or IS NOT need for this
7756 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7757 C        is (itype(i-3).eq.ntyp1) ntblock=2
7758 C        ntblock is N-terminal blocking group
7759
7760 C Regular cosine and sine terms
7761         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7762 C Example of changes for NH3+ blocking group
7763 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7764 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7765           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7766           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7767           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7768           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7769           cosphi1=dcos(j*phii)
7770           sinphi1=dsin(j*phii)
7771           cosphi2=dcos(j*phii1)
7772           sinphi2=dsin(j*phii1)
7773           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7774      &     v2cij*cosphi2+v2sij*sinphi2
7775           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7776           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7777         enddo
7778         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7779           do l=1,k-1
7780             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7781             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7782             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7783             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7784             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7785             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7786             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7787             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7788             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7789      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7790             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7791      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7792             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7793      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7794           enddo
7795         enddo
7796         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7797         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7798       enddo
7799       return
7800       end
7801 #endif
7802 C----------------------------------------------------------------------------------
7803 C The rigorous attempt to derive energy function
7804       subroutine etor_kcc(etors)
7805       implicit real*8 (a-h,o-z)
7806       include 'DIMENSIONS'
7807       include 'COMMON.VAR'
7808       include 'COMMON.GEO'
7809       include 'COMMON.LOCAL'
7810       include 'COMMON.TORSION'
7811       include 'COMMON.INTERACT'
7812       include 'COMMON.DERIV'
7813       include 'COMMON.CHAIN'
7814       include 'COMMON.NAMES'
7815       include 'COMMON.IOUNITS'
7816       include 'COMMON.FFIELD'
7817       include 'COMMON.TORCNSTR'
7818       include 'COMMON.CONTROL'
7819       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7820       logical lprn
7821 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7822 C Set lprn=.true. for debugging
7823       lprn=energy_dec
7824 c     lprn=.true.
7825 C      print *,"wchodze kcc"
7826       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7827       etors=0.0D0
7828       do i=iphi_start,iphi_end
7829 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7830 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7831 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7832 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7833         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7834      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7835         itori=itortyp(itype(i-2))
7836         itori1=itortyp(itype(i-1))
7837         phii=phi(i)
7838         glocig=0.0D0
7839         glocit1=0.0d0
7840         glocit2=0.0d0
7841 C to avoid multiple devision by 2
7842 c        theti22=0.5d0*theta(i)
7843 C theta 12 is the theta_1 /2
7844 C theta 22 is theta_2 /2
7845 c        theti12=0.5d0*theta(i-1)
7846 C and appropriate sinus function
7847         sinthet1=dsin(theta(i-1))
7848         sinthet2=dsin(theta(i))
7849         costhet1=dcos(theta(i-1))
7850         costhet2=dcos(theta(i))
7851 C to speed up lets store its mutliplication
7852         sint1t2=sinthet2*sinthet1
7853         sint1t2n=1.0d0
7854 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7855 C +d_n*sin(n*gamma)) *
7856 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7857 C we have two sum 1) Non-Chebyshev which is with n and gamma
7858         nval=nterm_kcc_Tb(itori,itori1)
7859         c1(0)=0.0d0
7860         c2(0)=0.0d0
7861         c1(1)=1.0d0
7862         c2(1)=1.0d0
7863         do j=2,nval
7864           c1(j)=c1(j-1)*costhet1
7865           c2(j)=c2(j-1)*costhet2
7866         enddo
7867         etori=0.0d0
7868         do j=1,nterm_kcc(itori,itori1)
7869           cosphi=dcos(j*phii)
7870           sinphi=dsin(j*phii)
7871           sint1t2n1=sint1t2n
7872           sint1t2n=sint1t2n*sint1t2
7873           sumvalc=0.0d0
7874           gradvalct1=0.0d0
7875           gradvalct2=0.0d0
7876           do k=1,nval
7877             do l=1,nval
7878               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7879               gradvalct1=gradvalct1+
7880      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7881               gradvalct2=gradvalct2+
7882      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7883             enddo
7884           enddo
7885           gradvalct1=-gradvalct1*sinthet1
7886           gradvalct2=-gradvalct2*sinthet2
7887           sumvals=0.0d0
7888           gradvalst1=0.0d0
7889           gradvalst2=0.0d0
7890           do k=1,nval
7891             do l=1,nval
7892               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7893               gradvalst1=gradvalst1+
7894      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7895               gradvalst2=gradvalst2+
7896      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7897             enddo
7898           enddo
7899           gradvalst1=-gradvalst1*sinthet1
7900           gradvalst2=-gradvalst2*sinthet2
7901           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7902           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7903 C glocig is the gradient local i site in gamma
7904           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7905 C now gradient over theta_1
7906           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7907      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7908           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7909      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7910         enddo ! j
7911         etors=etors+etori
7912 C derivative over gamma
7913         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7914 C derivative over theta1
7915         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7916 C now derivative over theta2
7917         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7918         if (lprn) then
7919           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7920      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7921           write (iout,*) "c1",(c1(k),k=0,nval),
7922      &    " c2",(c2(k),k=0,nval)
7923         endif
7924       enddo
7925       return
7926       end
7927 c---------------------------------------------------------------------------------------------
7928       subroutine etor_constr(edihcnstr)
7929       implicit real*8 (a-h,o-z)
7930       include 'DIMENSIONS'
7931       include 'COMMON.VAR'
7932       include 'COMMON.GEO'
7933       include 'COMMON.LOCAL'
7934       include 'COMMON.TORSION'
7935       include 'COMMON.INTERACT'
7936       include 'COMMON.DERIV'
7937       include 'COMMON.CHAIN'
7938       include 'COMMON.NAMES'
7939       include 'COMMON.IOUNITS'
7940       include 'COMMON.FFIELD'
7941       include 'COMMON.TORCNSTR'
7942       include 'COMMON.BOUNDS'
7943       include 'COMMON.CONTROL'
7944 ! 6/20/98 - dihedral angle constraints
7945       edihcnstr=0.0d0
7946 c      do i=1,ndih_constr
7947       if (raw_psipred) then
7948         do i=idihconstr_start,idihconstr_end
7949           itori=idih_constr(i)
7950           phii=phi(itori)
7951           gaudih_i=vpsipred(1,i)
7952           gauder_i=0.0d0
7953           do j=1,2
7954             s = sdihed(j,i)
7955             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7956             dexpcos_i=dexp(-cos_i*cos_i)
7957             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7958             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7959      &            *cos_i*dexpcos_i/s**2
7960           enddo
7961           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7962           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7963           if (energy_dec)
7964      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7965      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7966      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7967      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7968      &     -wdihc*dlog(gaudih_i)
7969         enddo
7970       else
7971
7972       do i=idihconstr_start,idihconstr_end
7973         itori=idih_constr(i)
7974         phii=phi(itori)
7975         difi=pinorm(phii-phi0(i))
7976         if (difi.gt.drange(i)) then
7977           difi=difi-drange(i)
7978           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7979           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7980         else if (difi.lt.-drange(i)) then
7981           difi=difi+drange(i)
7982           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7983           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7984         else
7985           difi=0.0
7986         endif
7987       enddo
7988
7989       endif
7990
7991       return
7992       end
7993 c----------------------------------------------------------------------------
7994 c MODELLER restraint function
7995       subroutine e_modeller(ehomology_constr)
7996       implicit none
7997       include 'DIMENSIONS'
7998
7999       double precision ehomology_constr
8000       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8001       integer katy, odleglosci, test7
8002       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8003       real*8 Eval,Erot
8004       real*8 distance(max_template),distancek(max_template),
8005      &    min_odl,godl(max_template),dih_diff(max_template)
8006
8007 c
8008 c     FP - 30/10/2014 Temporary specifications for homology restraints
8009 c
8010       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8011      &                 sgtheta
8012       double precision, dimension (maxres) :: guscdiff,usc_diff
8013       double precision, dimension (max_template) ::
8014      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8015      &           theta_diff
8016       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8017      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8018      & betai,sum_sgodl,dij
8019       double precision dist,pinorm
8020 c
8021       include 'COMMON.SBRIDGE'
8022       include 'COMMON.CHAIN'
8023       include 'COMMON.GEO'
8024       include 'COMMON.DERIV'
8025       include 'COMMON.LOCAL'
8026       include 'COMMON.INTERACT'
8027       include 'COMMON.VAR'
8028       include 'COMMON.IOUNITS'
8029 c      include 'COMMON.MD'
8030       include 'COMMON.CONTROL'
8031       include 'COMMON.HOMOLOGY'
8032       include 'COMMON.QRESTR'
8033 c
8034 c     From subroutine Econstr_back
8035 c
8036       include 'COMMON.NAMES'
8037       include 'COMMON.TIME1'
8038 c
8039
8040
8041       do i=1,max_template
8042         distancek(i)=9999999.9
8043       enddo
8044
8045
8046       odleg=0.0d0
8047
8048 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8049 c function)
8050 C AL 5/2/14 - Introduce list of restraints
8051 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8052 #ifdef DEBUG
8053       write(iout,*) "------- dist restrs start -------"
8054 #endif
8055       do ii = link_start_homo,link_end_homo
8056          i = ires_homo(ii)
8057          j = jres_homo(ii)
8058          dij=dist(i,j)
8059 c        write (iout,*) "dij(",i,j,") =",dij
8060          nexl=0
8061          do k=1,constr_homology
8062 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8063            if(.not.l_homo(k,ii)) then
8064              nexl=nexl+1
8065              cycle
8066            endif
8067            distance(k)=odl(k,ii)-dij
8068 c          write (iout,*) "distance(",k,") =",distance(k)
8069 c
8070 c          For Gaussian-type Urestr
8071 c
8072            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8073 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8074 c          write (iout,*) "distancek(",k,") =",distancek(k)
8075 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8076 c
8077 c          For Lorentzian-type Urestr
8078 c
8079            if (waga_dist.lt.0.0d0) then
8080               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8081               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8082      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8083            endif
8084          enddo
8085
8086 c         min_odl=minval(distancek)
8087          do kk=1,constr_homology
8088           if(l_homo(kk,ii)) then
8089             min_odl=distancek(kk)
8090             exit
8091           endif
8092          enddo
8093          do kk=1,constr_homology
8094           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8095      &              min_odl=distancek(kk)
8096          enddo
8097
8098 c        write (iout,* )"min_odl",min_odl
8099 #ifdef DEBUG
8100          write (iout,*) "ij dij",i,j,dij
8101          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8102          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8103          write (iout,* )"min_odl",min_odl
8104 #endif
8105 #ifdef OLDRESTR
8106          odleg2=0.0d0
8107 #else
8108          if (waga_dist.ge.0.0d0) then
8109            odleg2=nexl
8110          else
8111            odleg2=0.0d0
8112          endif
8113 #endif
8114          do k=1,constr_homology
8115 c Nie wiem po co to liczycie jeszcze raz!
8116 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8117 c     &              (2*(sigma_odl(i,j,k))**2))
8118            if(.not.l_homo(k,ii)) cycle
8119            if (waga_dist.ge.0.0d0) then
8120 c
8121 c          For Gaussian-type Urestr
8122 c
8123             godl(k)=dexp(-distancek(k)+min_odl)
8124             odleg2=odleg2+godl(k)
8125 c
8126 c          For Lorentzian-type Urestr
8127 c
8128            else
8129             odleg2=odleg2+distancek(k)
8130            endif
8131
8132 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8133 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8134 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8135 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8136
8137          enddo
8138 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8139 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8140 #ifdef DEBUG
8141          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8142          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8143 #endif
8144            if (waga_dist.ge.0.0d0) then
8145 c
8146 c          For Gaussian-type Urestr
8147 c
8148               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8149 c
8150 c          For Lorentzian-type Urestr
8151 c
8152            else
8153               odleg=odleg+odleg2/constr_homology
8154            endif
8155 c
8156 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8157 c Gradient
8158 c
8159 c          For Gaussian-type Urestr
8160 c
8161          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8162          sum_sgodl=0.0d0
8163          do k=1,constr_homology
8164 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8165 c     &           *waga_dist)+min_odl
8166 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8167 c
8168          if(.not.l_homo(k,ii)) cycle
8169          if (waga_dist.ge.0.0d0) then
8170 c          For Gaussian-type Urestr
8171 c
8172            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8173 c
8174 c          For Lorentzian-type Urestr
8175 c
8176          else
8177            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8178      &           sigma_odlir(k,ii)**2)**2)
8179          endif
8180            sum_sgodl=sum_sgodl+sgodl
8181
8182 c            sgodl2=sgodl2+sgodl
8183 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8184 c      write(iout,*) "constr_homology=",constr_homology
8185 c      write(iout,*) i, j, k, "TEST K"
8186          enddo
8187          if (waga_dist.ge.0.0d0) then
8188 c
8189 c          For Gaussian-type Urestr
8190 c
8191             grad_odl3=waga_homology(iset)*waga_dist
8192      &                *sum_sgodl/(sum_godl*dij)
8193 c
8194 c          For Lorentzian-type Urestr
8195 c
8196          else
8197 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8198 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8199             grad_odl3=-waga_homology(iset)*waga_dist*
8200      &                sum_sgodl/(constr_homology*dij)
8201          endif
8202 c
8203 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8204
8205
8206 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8207 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8208 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8209
8210 ccc      write(iout,*) godl, sgodl, grad_odl3
8211
8212 c          grad_odl=grad_odl+grad_odl3
8213
8214          do jik=1,3
8215             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8216 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8217 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8218 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8219             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8220             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8221 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8222 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8223 c         if (i.eq.25.and.j.eq.27) then
8224 c         write(iout,*) "jik",jik,"i",i,"j",j
8225 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8226 c         write(iout,*) "grad_odl3",grad_odl3
8227 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8228 c         write(iout,*) "ggodl",ggodl
8229 c         write(iout,*) "ghpbc(",jik,i,")",
8230 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8231 c     &                 ghpbc(jik,j)
8232 c         endif
8233          enddo
8234 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8235 ccc     & dLOG(odleg2),"-odleg=", -odleg
8236
8237       enddo ! ii-loop for dist
8238 #ifdef DEBUG
8239       write(iout,*) "------- dist restrs end -------"
8240 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8241 c    &     waga_d.eq.1.0d0) call sum_gradient
8242 #endif
8243 c Pseudo-energy and gradient from dihedral-angle restraints from
8244 c homology templates
8245 c      write (iout,*) "End of distance loop"
8246 c      call flush(iout)
8247       kat=0.0d0
8248 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8249 #ifdef DEBUG
8250       write(iout,*) "------- dih restrs start -------"
8251       do i=idihconstr_start_homo,idihconstr_end_homo
8252         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8253       enddo
8254 #endif
8255       do i=idihconstr_start_homo,idihconstr_end_homo
8256         kat2=0.0d0
8257 c        betai=beta(i,i+1,i+2,i+3)
8258         betai = phi(i)
8259 c       write (iout,*) "betai =",betai
8260         do k=1,constr_homology
8261           dih_diff(k)=pinorm(dih(k,i)-betai)
8262 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8263 cd     &                  ,sigma_dih(k,i)
8264 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8265 c     &                                   -(6.28318-dih_diff(i,k))
8266 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8267 c     &                                   6.28318+dih_diff(i,k)
8268 #ifdef OLD_DIHED
8269           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8270 #else
8271           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8272 #endif
8273 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8274           gdih(k)=dexp(kat3)
8275           kat2=kat2+gdih(k)
8276 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8277 c          write(*,*)""
8278         enddo
8279 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8280 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8281 #ifdef DEBUG
8282         write (iout,*) "i",i," betai",betai," kat2",kat2
8283         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8284 #endif
8285         if (kat2.le.1.0d-14) cycle
8286         kat=kat-dLOG(kat2/constr_homology)
8287 c       write (iout,*) "kat",kat ! sum of -ln-s
8288
8289 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8290 ccc     & dLOG(kat2), "-kat=", -kat
8291
8292 c ----------------------------------------------------------------------
8293 c Gradient
8294 c ----------------------------------------------------------------------
8295
8296         sum_gdih=kat2
8297         sum_sgdih=0.0d0
8298         do k=1,constr_homology
8299 #ifdef OLD_DIHED
8300           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8301 #else
8302           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8303 #endif
8304 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8305           sum_sgdih=sum_sgdih+sgdih
8306         enddo
8307 c       grad_dih3=sum_sgdih/sum_gdih
8308         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8309
8310 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8311 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8312 ccc     & gloc(nphi+i-3,icg)
8313         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8314 c        if (i.eq.25) then
8315 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8316 c        endif
8317 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8318 ccc     & gloc(nphi+i-3,icg)
8319
8320       enddo ! i-loop for dih
8321 #ifdef DEBUG
8322       write(iout,*) "------- dih restrs end -------"
8323 #endif
8324
8325 c Pseudo-energy and gradient for theta angle restraints from
8326 c homology templates
8327 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8328 c adapted
8329
8330 c
8331 c     For constr_homology reference structures (FP)
8332 c
8333 c     Uconst_back_tot=0.0d0
8334       Eval=0.0d0
8335       Erot=0.0d0
8336 c     Econstr_back legacy
8337       do i=1,nres
8338 c     do i=ithet_start,ithet_end
8339        dutheta(i)=0.0d0
8340 c     enddo
8341 c     do i=loc_start,loc_end
8342         do j=1,3
8343           duscdiff(j,i)=0.0d0
8344           duscdiffx(j,i)=0.0d0
8345         enddo
8346       enddo
8347 c
8348 c     do iref=1,nref
8349 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8350 c     write (iout,*) "waga_theta",waga_theta
8351       if (waga_theta.gt.0.0d0) then
8352 #ifdef DEBUG
8353       write (iout,*) "usampl",usampl
8354       write(iout,*) "------- theta restrs start -------"
8355 c     do i=ithet_start,ithet_end
8356 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8357 c     enddo
8358 #endif
8359 c     write (iout,*) "maxres",maxres,"nres",nres
8360
8361       do i=ithet_start,ithet_end
8362 c
8363 c     do i=1,nfrag_back
8364 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8365 c
8366 c Deviation of theta angles wrt constr_homology ref structures
8367 c
8368         utheta_i=0.0d0 ! argument of Gaussian for single k
8369         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8370 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8371 c       over residues in a fragment
8372 c       write (iout,*) "theta(",i,")=",theta(i)
8373         do k=1,constr_homology
8374 c
8375 c         dtheta_i=theta(j)-thetaref(j,iref)
8376 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8377           theta_diff(k)=thetatpl(k,i)-theta(i)
8378 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8379 cd     &                  ,sigma_theta(k,i)
8380
8381 c
8382           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8383 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8384           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8385           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8386 c         Gradient for single Gaussian restraint in subr Econstr_back
8387 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8388 c
8389         enddo
8390 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8391 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8392
8393 c
8394 c         Gradient for multiple Gaussian restraint
8395         sum_gtheta=gutheta_i
8396         sum_sgtheta=0.0d0
8397         do k=1,constr_homology
8398 c        New generalized expr for multiple Gaussian from Econstr_back
8399          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8400 c
8401 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8402           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8403         enddo
8404 c       Final value of gradient using same var as in Econstr_back
8405         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8406      &      +sum_sgtheta/sum_gtheta*waga_theta
8407      &               *waga_homology(iset)
8408 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8409 c     &               *waga_homology(iset)
8410 c       dutheta(i)=sum_sgtheta/sum_gtheta
8411 c
8412 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8413         Eval=Eval-dLOG(gutheta_i/constr_homology)
8414 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8415 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8416 c       Uconst_back=Uconst_back+utheta(i)
8417       enddo ! (i-loop for theta)
8418 #ifdef DEBUG
8419       write(iout,*) "------- theta restrs end -------"
8420 #endif
8421       endif
8422 c
8423 c Deviation of local SC geometry
8424 c
8425 c Separation of two i-loops (instructed by AL - 11/3/2014)
8426 c
8427 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8428 c     write (iout,*) "waga_d",waga_d
8429
8430 #ifdef DEBUG
8431       write(iout,*) "------- SC restrs start -------"
8432       write (iout,*) "Initial duscdiff,duscdiffx"
8433       do i=loc_start,loc_end
8434         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8435      &                 (duscdiffx(jik,i),jik=1,3)
8436       enddo
8437 #endif
8438       do i=loc_start,loc_end
8439         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8440         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8441 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8442 c       write(iout,*) "xxtab, yytab, zztab"
8443 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8444         do k=1,constr_homology
8445 c
8446           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8447 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8448           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8449           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8450 c         write(iout,*) "dxx, dyy, dzz"
8451 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8452 c
8453           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8454 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8455 c         uscdiffk(k)=usc_diff(i)
8456           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8457 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8458 c     &       " guscdiff2",guscdiff2(k)
8459           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8460 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8461 c     &      xxref(j),yyref(j),zzref(j)
8462         enddo
8463 c
8464 c       Gradient
8465 c
8466 c       Generalized expression for multiple Gaussian acc to that for a single
8467 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8468 c
8469 c       Original implementation
8470 c       sum_guscdiff=guscdiff(i)
8471 c
8472 c       sum_sguscdiff=0.0d0
8473 c       do k=1,constr_homology
8474 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8475 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8476 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8477 c       enddo
8478 c
8479 c       Implementation of new expressions for gradient (Jan. 2015)
8480 c
8481 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8482         do k=1,constr_homology
8483 c
8484 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8485 c       before. Now the drivatives should be correct
8486 c
8487           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8488 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8489           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8490           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8491 c
8492 c         New implementation
8493 c
8494           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8495      &                 sigma_d(k,i) ! for the grad wrt r'
8496 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8497 c
8498 c
8499 c        New implementation
8500          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8501          do jik=1,3
8502             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8503      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8504      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8505             duscdiff(jik,i)=duscdiff(jik,i)+
8506      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8507      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8508             duscdiffx(jik,i)=duscdiffx(jik,i)+
8509      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8510      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8511 c
8512 #ifdef DEBUG
8513              write(iout,*) "jik",jik,"i",i
8514              write(iout,*) "dxx, dyy, dzz"
8515              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8516              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8517 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8518 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8519 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8520 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8521 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8522 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8523 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8524 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8525 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8526 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8527 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8528 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8529 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8530 c            endif
8531 #endif
8532          enddo
8533         enddo
8534 c
8535 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8536 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8537 c
8538 c        write (iout,*) i," uscdiff",uscdiff(i)
8539 c
8540 c Put together deviations from local geometry
8541
8542 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8543 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8544         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8545 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8546 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8547 c       Uconst_back=Uconst_back+usc_diff(i)
8548 c
8549 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8550 c
8551 c     New implment: multiplied by sum_sguscdiff
8552 c
8553
8554       enddo ! (i-loop for dscdiff)
8555
8556 c      endif
8557
8558 #ifdef DEBUG
8559       write(iout,*) "------- SC restrs end -------"
8560         write (iout,*) "------ After SC loop in e_modeller ------"
8561         do i=loc_start,loc_end
8562          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8563          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8564         enddo
8565       if (waga_theta.eq.1.0d0) then
8566       write (iout,*) "in e_modeller after SC restr end: dutheta"
8567       do i=ithet_start,ithet_end
8568         write (iout,*) i,dutheta(i)
8569       enddo
8570       endif
8571       if (waga_d.eq.1.0d0) then
8572       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8573       do i=1,nres
8574         write (iout,*) i,(duscdiff(j,i),j=1,3)
8575         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8576       enddo
8577       endif
8578 #endif
8579
8580 c Total energy from homology restraints
8581 #ifdef DEBUG
8582       write (iout,*) "odleg",odleg," kat",kat
8583 #endif
8584 c
8585 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8586 c
8587 c     ehomology_constr=odleg+kat
8588 c
8589 c     For Lorentzian-type Urestr
8590 c
8591
8592       if (waga_dist.ge.0.0d0) then
8593 c
8594 c          For Gaussian-type Urestr
8595 c
8596         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8597      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8598 c     write (iout,*) "ehomology_constr=",ehomology_constr
8599       else
8600 c
8601 c          For Lorentzian-type Urestr
8602 c
8603         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8604      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8605 c     write (iout,*) "ehomology_constr=",ehomology_constr
8606       endif
8607 #ifdef DEBUG
8608       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8609      & "Eval",waga_theta,eval,
8610      &   "Erot",waga_d,Erot
8611       write (iout,*) "ehomology_constr",ehomology_constr
8612 #endif
8613       return
8614 c
8615 c FP 01/15 end
8616 c
8617   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8618   747 format(a12,i4,i4,i4,f8.3,f8.3)
8619   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8620   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8621   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8622      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8623       end
8624 c----------------------------------------------------------------------------
8625 C The rigorous attempt to derive energy function
8626       subroutine ebend_kcc(etheta)
8627
8628       implicit real*8 (a-h,o-z)
8629       include 'DIMENSIONS'
8630       include 'COMMON.VAR'
8631       include 'COMMON.GEO'
8632       include 'COMMON.LOCAL'
8633       include 'COMMON.TORSION'
8634       include 'COMMON.INTERACT'
8635       include 'COMMON.DERIV'
8636       include 'COMMON.CHAIN'
8637       include 'COMMON.NAMES'
8638       include 'COMMON.IOUNITS'
8639       include 'COMMON.FFIELD'
8640       include 'COMMON.TORCNSTR'
8641       include 'COMMON.CONTROL'
8642       logical lprn
8643       double precision thybt1(maxang_kcc)
8644 C Set lprn=.true. for debugging
8645       lprn=energy_dec
8646 c     lprn=.true.
8647 C      print *,"wchodze kcc"
8648       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8649       etheta=0.0D0
8650       do i=ithet_start,ithet_end
8651 c        print *,i,itype(i-1),itype(i),itype(i-2)
8652         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8653      &  .or.itype(i).eq.ntyp1) cycle
8654         iti=iabs(itortyp(itype(i-1)))
8655         sinthet=dsin(theta(i))
8656         costhet=dcos(theta(i))
8657         do j=1,nbend_kcc_Tb(iti)
8658           thybt1(j)=v1bend_chyb(j,iti)
8659         enddo
8660         sumth1thyb=v1bend_chyb(0,iti)+
8661      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8662         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8663      &    sumth1thyb
8664         ihelp=nbend_kcc_Tb(iti)-1
8665         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8666         etheta=etheta+sumth1thyb
8667 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8668         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8669       enddo
8670       return
8671       end
8672 c-------------------------------------------------------------------------------------
8673       subroutine etheta_constr(ethetacnstr)
8674
8675       implicit real*8 (a-h,o-z)
8676       include 'DIMENSIONS'
8677       include 'COMMON.VAR'
8678       include 'COMMON.GEO'
8679       include 'COMMON.LOCAL'
8680       include 'COMMON.TORSION'
8681       include 'COMMON.INTERACT'
8682       include 'COMMON.DERIV'
8683       include 'COMMON.CHAIN'
8684       include 'COMMON.NAMES'
8685       include 'COMMON.IOUNITS'
8686       include 'COMMON.FFIELD'
8687       include 'COMMON.TORCNSTR'
8688       include 'COMMON.CONTROL'
8689       ethetacnstr=0.0d0
8690 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8691       do i=ithetaconstr_start,ithetaconstr_end
8692         itheta=itheta_constr(i)
8693         thetiii=theta(itheta)
8694         difi=pinorm(thetiii-theta_constr0(i))
8695         if (difi.gt.theta_drange(i)) then
8696           difi=difi-theta_drange(i)
8697           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8698           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8699      &    +for_thet_constr(i)*difi**3
8700         else if (difi.lt.-drange(i)) then
8701           difi=difi+drange(i)
8702           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8703           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8704      &    +for_thet_constr(i)*difi**3
8705         else
8706           difi=0.0
8707         endif
8708        if (energy_dec) then
8709         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8710      &    i,itheta,rad2deg*thetiii,
8711      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8712      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8713      &    gloc(itheta+nphi-2,icg)
8714         endif
8715       enddo
8716       return
8717       end
8718 c------------------------------------------------------------------------------
8719       subroutine eback_sc_corr(esccor)
8720 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8721 c        conformational states; temporarily implemented as differences
8722 c        between UNRES torsional potentials (dependent on three types of
8723 c        residues) and the torsional potentials dependent on all 20 types
8724 c        of residues computed from AM1  energy surfaces of terminally-blocked
8725 c        amino-acid residues.
8726       implicit real*8 (a-h,o-z)
8727       include 'DIMENSIONS'
8728       include 'COMMON.VAR'
8729       include 'COMMON.GEO'
8730       include 'COMMON.LOCAL'
8731       include 'COMMON.TORSION'
8732       include 'COMMON.SCCOR'
8733       include 'COMMON.INTERACT'
8734       include 'COMMON.DERIV'
8735       include 'COMMON.CHAIN'
8736       include 'COMMON.NAMES'
8737       include 'COMMON.IOUNITS'
8738       include 'COMMON.FFIELD'
8739       include 'COMMON.CONTROL'
8740       logical lprn
8741 C Set lprn=.true. for debugging
8742       lprn=.false.
8743 c      lprn=.true.
8744 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8745       esccor=0.0D0
8746       do i=itau_start,itau_end
8747         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8748         esccor_ii=0.0D0
8749         isccori=isccortyp(itype(i-2))
8750         isccori1=isccortyp(itype(i-1))
8751 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8752         phii=phi(i)
8753         do intertyp=1,3 !intertyp
8754 cc Added 09 May 2012 (Adasko)
8755 cc  Intertyp means interaction type of backbone mainchain correlation:
8756 c   1 = SC...Ca...Ca...Ca
8757 c   2 = Ca...Ca...Ca...SC
8758 c   3 = SC...Ca...Ca...SCi
8759         gloci=0.0D0
8760         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8761      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8762      &      (itype(i-1).eq.ntyp1)))
8763      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8764      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8765      &     .or.(itype(i).eq.ntyp1)))
8766      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8767      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8768      &      (itype(i-3).eq.ntyp1)))) cycle
8769         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8770         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8771      & cycle
8772        do j=1,nterm_sccor(isccori,isccori1)
8773           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8774           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8775           cosphi=dcos(j*tauangle(intertyp,i))
8776           sinphi=dsin(j*tauangle(intertyp,i))
8777           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8778           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8779         enddo
8780 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8781         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8782         if (lprn)
8783      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8784      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8785      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8786      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8787         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8788        enddo !intertyp
8789       enddo
8790
8791       return
8792       end
8793 #ifdef FOURBODY
8794 c----------------------------------------------------------------------------
8795       subroutine multibody(ecorr)
8796 C This subroutine calculates multi-body contributions to energy following
8797 C the idea of Skolnick et al. If side chains I and J make a contact and
8798 C at the same time side chains I+1 and J+1 make a contact, an extra
8799 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8800       implicit real*8 (a-h,o-z)
8801       include 'DIMENSIONS'
8802       include 'COMMON.IOUNITS'
8803       include 'COMMON.DERIV'
8804       include 'COMMON.INTERACT'
8805       include 'COMMON.CONTACTS'
8806       include 'COMMON.CONTMAT'
8807       include 'COMMON.CORRMAT'
8808       double precision gx(3),gx1(3)
8809       logical lprn
8810
8811 C Set lprn=.true. for debugging
8812       lprn=.false.
8813
8814       if (lprn) then
8815         write (iout,'(a)') 'Contact function values:'
8816         do i=nnt,nct-2
8817           write (iout,'(i2,20(1x,i2,f10.5))')
8818      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8819         enddo
8820       endif
8821       ecorr=0.0D0
8822       do i=nnt,nct
8823         do j=1,3
8824           gradcorr(j,i)=0.0D0
8825           gradxorr(j,i)=0.0D0
8826         enddo
8827       enddo
8828       do i=nnt,nct-2
8829
8830         DO ISHIFT = 3,4
8831
8832         i1=i+ishift
8833         num_conti=num_cont(i)
8834         num_conti1=num_cont(i1)
8835         do jj=1,num_conti
8836           j=jcont(jj,i)
8837           do kk=1,num_conti1
8838             j1=jcont(kk,i1)
8839             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8840 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8841 cd   &                   ' ishift=',ishift
8842 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8843 C The system gains extra energy.
8844               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8845             endif   ! j1==j+-ishift
8846           enddo     ! kk
8847         enddo       ! jj
8848
8849         ENDDO ! ISHIFT
8850
8851       enddo         ! i
8852       return
8853       end
8854 c------------------------------------------------------------------------------
8855       double precision function esccorr(i,j,k,l,jj,kk)
8856       implicit real*8 (a-h,o-z)
8857       include 'DIMENSIONS'
8858       include 'COMMON.IOUNITS'
8859       include 'COMMON.DERIV'
8860       include 'COMMON.INTERACT'
8861       include 'COMMON.CONTACTS'
8862       include 'COMMON.CONTMAT'
8863       include 'COMMON.CORRMAT'
8864       include 'COMMON.SHIELD'
8865       double precision gx(3),gx1(3)
8866       logical lprn
8867       lprn=.false.
8868       eij=facont(jj,i)
8869       ekl=facont(kk,k)
8870 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8871 C Calculate the multi-body contribution to energy.
8872 C Calculate multi-body contributions to the gradient.
8873 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8874 cd   & k,l,(gacont(m,kk,k),m=1,3)
8875       do m=1,3
8876         gx(m) =ekl*gacont(m,jj,i)
8877         gx1(m)=eij*gacont(m,kk,k)
8878         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8879         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8880         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8881         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8882       enddo
8883       do m=i,j-1
8884         do ll=1,3
8885           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8886         enddo
8887       enddo
8888       do m=k,l-1
8889         do ll=1,3
8890           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8891         enddo
8892       enddo
8893       esccorr=-eij*ekl
8894       return
8895       end
8896 c------------------------------------------------------------------------------
8897       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8898 C This subroutine calculates multi-body contributions to hydrogen-bonding
8899       implicit real*8 (a-h,o-z)
8900       include 'DIMENSIONS'
8901       include 'COMMON.IOUNITS'
8902 #ifdef MPI
8903       include "mpif.h"
8904       parameter (max_cont=maxconts)
8905       parameter (max_dim=26)
8906       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8907       double precision zapas(max_dim,maxconts,max_fg_procs),
8908      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8909       common /przechowalnia/ zapas
8910       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8911      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8912 #endif
8913       include 'COMMON.SETUP'
8914       include 'COMMON.FFIELD'
8915       include 'COMMON.DERIV'
8916       include 'COMMON.INTERACT'
8917       include 'COMMON.CONTACTS'
8918       include 'COMMON.CONTMAT'
8919       include 'COMMON.CORRMAT'
8920       include 'COMMON.CONTROL'
8921       include 'COMMON.LOCAL'
8922       double precision gx(3),gx1(3),time00
8923       logical lprn,ldone
8924
8925 C Set lprn=.true. for debugging
8926       lprn=.false.
8927 #ifdef MPI
8928       n_corr=0
8929       n_corr1=0
8930       if (nfgtasks.le.1) goto 30
8931       if (lprn) then
8932         write (iout,'(a)') 'Contact function values before RECEIVE:'
8933         do i=nnt,nct-2
8934           write (iout,'(2i3,50(1x,i2,f5.2))')
8935      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8936      &    j=1,num_cont_hb(i))
8937         enddo
8938         call flush(iout)
8939       endif
8940       do i=1,ntask_cont_from
8941         ncont_recv(i)=0
8942       enddo
8943       do i=1,ntask_cont_to
8944         ncont_sent(i)=0
8945       enddo
8946 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8947 c     & ntask_cont_to
8948 C Make the list of contacts to send to send to other procesors
8949 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8950 c      call flush(iout)
8951       do i=iturn3_start,iturn3_end
8952 c        write (iout,*) "make contact list turn3",i," num_cont",
8953 c     &    num_cont_hb(i)
8954         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8955       enddo
8956       do i=iturn4_start,iturn4_end
8957 c        write (iout,*) "make contact list turn4",i," num_cont",
8958 c     &   num_cont_hb(i)
8959         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8960       enddo
8961       do ii=1,nat_sent
8962         i=iat_sent(ii)
8963 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8964 c     &    num_cont_hb(i)
8965         do j=1,num_cont_hb(i)
8966         do k=1,4
8967           jjc=jcont_hb(j,i)
8968           iproc=iint_sent_local(k,jjc,ii)
8969 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8970           if (iproc.gt.0) then
8971             ncont_sent(iproc)=ncont_sent(iproc)+1
8972             nn=ncont_sent(iproc)
8973             zapas(1,nn,iproc)=i
8974             zapas(2,nn,iproc)=jjc
8975             zapas(3,nn,iproc)=facont_hb(j,i)
8976             zapas(4,nn,iproc)=ees0p(j,i)
8977             zapas(5,nn,iproc)=ees0m(j,i)
8978             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8979             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8980             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8981             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8982             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8983             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8984             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8985             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8986             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8987             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8988             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8989             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8990             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8991             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8992             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8993             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8994             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8995             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8996             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8997             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8998             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8999           endif
9000         enddo
9001         enddo
9002       enddo
9003       if (lprn) then
9004       write (iout,*)
9005      &  "Numbers of contacts to be sent to other processors",
9006      &  (ncont_sent(i),i=1,ntask_cont_to)
9007       write (iout,*) "Contacts sent"
9008       do ii=1,ntask_cont_to
9009         nn=ncont_sent(ii)
9010         iproc=itask_cont_to(ii)
9011         write (iout,*) nn," contacts to processor",iproc,
9012      &   " of CONT_TO_COMM group"
9013         do i=1,nn
9014           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9015         enddo
9016       enddo
9017       call flush(iout)
9018       endif
9019       CorrelType=477
9020       CorrelID=fg_rank+1
9021       CorrelType1=478
9022       CorrelID1=nfgtasks+fg_rank+1
9023       ireq=0
9024 C Receive the numbers of needed contacts from other processors
9025       do ii=1,ntask_cont_from
9026         iproc=itask_cont_from(ii)
9027         ireq=ireq+1
9028         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9029      &    FG_COMM,req(ireq),IERR)
9030       enddo
9031 c      write (iout,*) "IRECV ended"
9032 c      call flush(iout)
9033 C Send the number of contacts needed by other processors
9034       do ii=1,ntask_cont_to
9035         iproc=itask_cont_to(ii)
9036         ireq=ireq+1
9037         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9038      &    FG_COMM,req(ireq),IERR)
9039       enddo
9040 c      write (iout,*) "ISEND ended"
9041 c      write (iout,*) "number of requests (nn)",ireq
9042 c      call flush(iout)
9043       if (ireq.gt.0)
9044      &  call MPI_Waitall(ireq,req,status_array,ierr)
9045 c      write (iout,*)
9046 c     &  "Numbers of contacts to be received from other processors",
9047 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9048 c      call flush(iout)
9049 C Receive contacts
9050       ireq=0
9051       do ii=1,ntask_cont_from
9052         iproc=itask_cont_from(ii)
9053         nn=ncont_recv(ii)
9054 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9055 c     &   " of CONT_TO_COMM group"
9056 c        call flush(iout)
9057         if (nn.gt.0) then
9058           ireq=ireq+1
9059           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9060      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9061 c          write (iout,*) "ireq,req",ireq,req(ireq)
9062         endif
9063       enddo
9064 C Send the contacts to processors that need them
9065       do ii=1,ntask_cont_to
9066         iproc=itask_cont_to(ii)
9067         nn=ncont_sent(ii)
9068 c        write (iout,*) nn," contacts to processor",iproc,
9069 c     &   " of CONT_TO_COMM group"
9070         if (nn.gt.0) then
9071           ireq=ireq+1
9072           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9073      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9074 c          write (iout,*) "ireq,req",ireq,req(ireq)
9075 c          do i=1,nn
9076 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9077 c          enddo
9078         endif
9079       enddo
9080 c      write (iout,*) "number of requests (contacts)",ireq
9081 c      write (iout,*) "req",(req(i),i=1,4)
9082 c      call flush(iout)
9083       if (ireq.gt.0)
9084      & call MPI_Waitall(ireq,req,status_array,ierr)
9085       do iii=1,ntask_cont_from
9086         iproc=itask_cont_from(iii)
9087         nn=ncont_recv(iii)
9088         if (lprn) then
9089         write (iout,*) "Received",nn," contacts from processor",iproc,
9090      &   " of CONT_FROM_COMM group"
9091         call flush(iout)
9092         do i=1,nn
9093           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9094         enddo
9095         call flush(iout)
9096         endif
9097         do i=1,nn
9098           ii=zapas_recv(1,i,iii)
9099 c Flag the received contacts to prevent double-counting
9100           jj=-zapas_recv(2,i,iii)
9101 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9102 c          call flush(iout)
9103           nnn=num_cont_hb(ii)+1
9104           num_cont_hb(ii)=nnn
9105           jcont_hb(nnn,ii)=jj
9106           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9107           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9108           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9109           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9110           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9111           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9112           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9113           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9114           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9115           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9116           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9117           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9118           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9119           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9120           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9121           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9122           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9123           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9124           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9125           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9126           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9127           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9128           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9129           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9130         enddo
9131       enddo
9132       if (lprn) then
9133         write (iout,'(a)') 'Contact function values after receive:'
9134         do i=nnt,nct-2
9135           write (iout,'(2i3,50(1x,i3,f5.2))')
9136      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9137      &    j=1,num_cont_hb(i))
9138         enddo
9139         call flush(iout)
9140       endif
9141    30 continue
9142 #endif
9143       if (lprn) then
9144         write (iout,'(a)') 'Contact function values:'
9145         do i=nnt,nct-2
9146           write (iout,'(2i3,50(1x,i3,f5.2))')
9147      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9148      &    j=1,num_cont_hb(i))
9149         enddo
9150         call flush(iout)
9151       endif
9152       ecorr=0.0D0
9153 C Remove the loop below after debugging !!!
9154       do i=nnt,nct
9155         do j=1,3
9156           gradcorr(j,i)=0.0D0
9157           gradxorr(j,i)=0.0D0
9158         enddo
9159       enddo
9160 C Calculate the local-electrostatic correlation terms
9161       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9162         i1=i+1
9163         num_conti=num_cont_hb(i)
9164         num_conti1=num_cont_hb(i+1)
9165         do jj=1,num_conti
9166           j=jcont_hb(jj,i)
9167           jp=iabs(j)
9168           do kk=1,num_conti1
9169             j1=jcont_hb(kk,i1)
9170             jp1=iabs(j1)
9171 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9172 c     &         ' jj=',jj,' kk=',kk
9173 c            call flush(iout)
9174             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9175      &          .or. j.lt.0 .and. j1.gt.0) .and.
9176      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9177 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9178 C The system gains extra energy.
9179               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9180               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9181      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9182               n_corr=n_corr+1
9183             else if (j1.eq.j) then
9184 C Contacts I-J and I-(J+1) occur simultaneously.
9185 C The system loses extra energy.
9186 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9187             endif
9188           enddo ! kk
9189           do kk=1,num_conti
9190             j1=jcont_hb(kk,i)
9191 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9192 c    &         ' jj=',jj,' kk=',kk
9193             if (j1.eq.j+1) then
9194 C Contacts I-J and (I+1)-J occur simultaneously.
9195 C The system loses extra energy.
9196 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9197             endif ! j1==j+1
9198           enddo ! kk
9199         enddo ! jj
9200       enddo ! i
9201       return
9202       end
9203 c------------------------------------------------------------------------------
9204       subroutine add_hb_contact(ii,jj,itask)
9205       implicit real*8 (a-h,o-z)
9206       include "DIMENSIONS"
9207       include "COMMON.IOUNITS"
9208       integer max_cont
9209       integer max_dim
9210       parameter (max_cont=maxconts)
9211       parameter (max_dim=26)
9212       include "COMMON.CONTACTS"
9213       include 'COMMON.CONTMAT'
9214       include 'COMMON.CORRMAT'
9215       double precision zapas(max_dim,maxconts,max_fg_procs),
9216      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9217       common /przechowalnia/ zapas
9218       integer i,j,ii,jj,iproc,itask(4),nn
9219 c      write (iout,*) "itask",itask
9220       do i=1,2
9221         iproc=itask(i)
9222         if (iproc.gt.0) then
9223           do j=1,num_cont_hb(ii)
9224             jjc=jcont_hb(j,ii)
9225 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9226             if (jjc.eq.jj) then
9227               ncont_sent(iproc)=ncont_sent(iproc)+1
9228               nn=ncont_sent(iproc)
9229               zapas(1,nn,iproc)=ii
9230               zapas(2,nn,iproc)=jjc
9231               zapas(3,nn,iproc)=facont_hb(j,ii)
9232               zapas(4,nn,iproc)=ees0p(j,ii)
9233               zapas(5,nn,iproc)=ees0m(j,ii)
9234               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9235               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9236               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9237               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9238               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9239               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9240               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9241               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9242               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9243               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9244               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9245               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9246               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9247               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9248               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9249               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9250               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9251               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9252               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9253               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9254               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9255               exit
9256             endif
9257           enddo
9258         endif
9259       enddo
9260       return
9261       end
9262 c------------------------------------------------------------------------------
9263       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9264      &  n_corr1)
9265 C This subroutine calculates multi-body contributions to hydrogen-bonding
9266       implicit real*8 (a-h,o-z)
9267       include 'DIMENSIONS'
9268       include 'COMMON.IOUNITS'
9269 #ifdef MPI
9270       include "mpif.h"
9271       parameter (max_cont=maxconts)
9272       parameter (max_dim=70)
9273       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9274       double precision zapas(max_dim,maxconts,max_fg_procs),
9275      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9276       common /przechowalnia/ zapas
9277       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9278      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9279 #endif
9280       include 'COMMON.SETUP'
9281       include 'COMMON.FFIELD'
9282       include 'COMMON.DERIV'
9283       include 'COMMON.LOCAL'
9284       include 'COMMON.INTERACT'
9285       include 'COMMON.CONTACTS'
9286       include 'COMMON.CONTMAT'
9287       include 'COMMON.CORRMAT'
9288       include 'COMMON.CHAIN'
9289       include 'COMMON.CONTROL'
9290       include 'COMMON.SHIELD'
9291       double precision gx(3),gx1(3)
9292       integer num_cont_hb_old(maxres)
9293       logical lprn,ldone
9294       double precision eello4,eello5,eelo6,eello_turn6
9295       external eello4,eello5,eello6,eello_turn6
9296 C Set lprn=.true. for debugging
9297       lprn=.false.
9298       eturn6=0.0d0
9299 #ifdef MPI
9300       do i=1,nres
9301         num_cont_hb_old(i)=num_cont_hb(i)
9302       enddo
9303       n_corr=0
9304       n_corr1=0
9305       if (nfgtasks.le.1) goto 30
9306       if (lprn) then
9307         write (iout,'(a)') 'Contact function values before RECEIVE:'
9308         do i=nnt,nct-2
9309           write (iout,'(2i3,50(1x,i2,f5.2))')
9310      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9311      &    j=1,num_cont_hb(i))
9312         enddo
9313       endif
9314       do i=1,ntask_cont_from
9315         ncont_recv(i)=0
9316       enddo
9317       do i=1,ntask_cont_to
9318         ncont_sent(i)=0
9319       enddo
9320 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9321 c     & ntask_cont_to
9322 C Make the list of contacts to send to send to other procesors
9323       do i=iturn3_start,iturn3_end
9324 c        write (iout,*) "make contact list turn3",i," num_cont",
9325 c     &    num_cont_hb(i)
9326         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9327       enddo
9328       do i=iturn4_start,iturn4_end
9329 c        write (iout,*) "make contact list turn4",i," num_cont",
9330 c     &   num_cont_hb(i)
9331         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9332       enddo
9333       do ii=1,nat_sent
9334         i=iat_sent(ii)
9335 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9336 c     &    num_cont_hb(i)
9337         do j=1,num_cont_hb(i)
9338         do k=1,4
9339           jjc=jcont_hb(j,i)
9340           iproc=iint_sent_local(k,jjc,ii)
9341 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9342           if (iproc.ne.0) then
9343             ncont_sent(iproc)=ncont_sent(iproc)+1
9344             nn=ncont_sent(iproc)
9345             zapas(1,nn,iproc)=i
9346             zapas(2,nn,iproc)=jjc
9347             zapas(3,nn,iproc)=d_cont(j,i)
9348             ind=3
9349             do kk=1,3
9350               ind=ind+1
9351               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9352             enddo
9353             do kk=1,2
9354               do ll=1,2
9355                 ind=ind+1
9356                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9357               enddo
9358             enddo
9359             do jj=1,5
9360               do kk=1,3
9361                 do ll=1,2
9362                   do mm=1,2
9363                     ind=ind+1
9364                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9365                   enddo
9366                 enddo
9367               enddo
9368             enddo
9369           endif
9370         enddo
9371         enddo
9372       enddo
9373       if (lprn) then
9374       write (iout,*)
9375      &  "Numbers of contacts to be sent to other processors",
9376      &  (ncont_sent(i),i=1,ntask_cont_to)
9377       write (iout,*) "Contacts sent"
9378       do ii=1,ntask_cont_to
9379         nn=ncont_sent(ii)
9380         iproc=itask_cont_to(ii)
9381         write (iout,*) nn," contacts to processor",iproc,
9382      &   " of CONT_TO_COMM group"
9383         do i=1,nn
9384           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9385         enddo
9386       enddo
9387       call flush(iout)
9388       endif
9389       CorrelType=477
9390       CorrelID=fg_rank+1
9391       CorrelType1=478
9392       CorrelID1=nfgtasks+fg_rank+1
9393       ireq=0
9394 C Receive the numbers of needed contacts from other processors
9395       do ii=1,ntask_cont_from
9396         iproc=itask_cont_from(ii)
9397         ireq=ireq+1
9398         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9399      &    FG_COMM,req(ireq),IERR)
9400       enddo
9401 c      write (iout,*) "IRECV ended"
9402 c      call flush(iout)
9403 C Send the number of contacts needed by other processors
9404       do ii=1,ntask_cont_to
9405         iproc=itask_cont_to(ii)
9406         ireq=ireq+1
9407         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9408      &    FG_COMM,req(ireq),IERR)
9409       enddo
9410 c      write (iout,*) "ISEND ended"
9411 c      write (iout,*) "number of requests (nn)",ireq
9412 c      call flush(iout)
9413       if (ireq.gt.0)
9414      &  call MPI_Waitall(ireq,req,status_array,ierr)
9415 c      write (iout,*)
9416 c     &  "Numbers of contacts to be received from other processors",
9417 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9418 c      call flush(iout)
9419 C Receive contacts
9420       ireq=0
9421       do ii=1,ntask_cont_from
9422         iproc=itask_cont_from(ii)
9423         nn=ncont_recv(ii)
9424 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9425 c     &   " of CONT_TO_COMM group"
9426 c        call flush(iout)
9427         if (nn.gt.0) then
9428           ireq=ireq+1
9429           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9430      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9431 c          write (iout,*) "ireq,req",ireq,req(ireq)
9432         endif
9433       enddo
9434 C Send the contacts to processors that need them
9435       do ii=1,ntask_cont_to
9436         iproc=itask_cont_to(ii)
9437         nn=ncont_sent(ii)
9438 c        write (iout,*) nn," contacts to processor",iproc,
9439 c     &   " of CONT_TO_COMM group"
9440         if (nn.gt.0) then
9441           ireq=ireq+1
9442           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9443      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9444 c          write (iout,*) "ireq,req",ireq,req(ireq)
9445 c          do i=1,nn
9446 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9447 c          enddo
9448         endif
9449       enddo
9450 c      write (iout,*) "number of requests (contacts)",ireq
9451 c      write (iout,*) "req",(req(i),i=1,4)
9452 c      call flush(iout)
9453       if (ireq.gt.0)
9454      & call MPI_Waitall(ireq,req,status_array,ierr)
9455       do iii=1,ntask_cont_from
9456         iproc=itask_cont_from(iii)
9457         nn=ncont_recv(iii)
9458         if (lprn) then
9459         write (iout,*) "Received",nn," contacts from processor",iproc,
9460      &   " of CONT_FROM_COMM group"
9461         call flush(iout)
9462         do i=1,nn
9463           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9464         enddo
9465         call flush(iout)
9466         endif
9467         do i=1,nn
9468           ii=zapas_recv(1,i,iii)
9469 c Flag the received contacts to prevent double-counting
9470           jj=-zapas_recv(2,i,iii)
9471 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9472 c          call flush(iout)
9473           nnn=num_cont_hb(ii)+1
9474           num_cont_hb(ii)=nnn
9475           jcont_hb(nnn,ii)=jj
9476           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9477           ind=3
9478           do kk=1,3
9479             ind=ind+1
9480             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9481           enddo
9482           do kk=1,2
9483             do ll=1,2
9484               ind=ind+1
9485               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9486             enddo
9487           enddo
9488           do jj=1,5
9489             do kk=1,3
9490               do ll=1,2
9491                 do mm=1,2
9492                   ind=ind+1
9493                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9494                 enddo
9495               enddo
9496             enddo
9497           enddo
9498         enddo
9499       enddo
9500       if (lprn) then
9501         write (iout,'(a)') 'Contact function values after receive:'
9502         do i=nnt,nct-2
9503           write (iout,'(2i3,50(1x,i3,5f6.3))')
9504      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9505      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9506         enddo
9507         call flush(iout)
9508       endif
9509    30 continue
9510 #endif
9511       if (lprn) then
9512         write (iout,'(a)') 'Contact function values:'
9513         do i=nnt,nct-2
9514           write (iout,'(2i3,50(1x,i2,5f6.3))')
9515      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9516      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9517         enddo
9518       endif
9519       ecorr=0.0D0
9520       ecorr5=0.0d0
9521       ecorr6=0.0d0
9522 C Remove the loop below after debugging !!!
9523       do i=nnt,nct
9524         do j=1,3
9525           gradcorr(j,i)=0.0D0
9526           gradxorr(j,i)=0.0D0
9527         enddo
9528       enddo
9529 C Calculate the dipole-dipole interaction energies
9530       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9531       do i=iatel_s,iatel_e+1
9532         num_conti=num_cont_hb(i)
9533         do jj=1,num_conti
9534           j=jcont_hb(jj,i)
9535 #ifdef MOMENT
9536           call dipole(i,j,jj)
9537 #endif
9538         enddo
9539       enddo
9540       endif
9541 C Calculate the local-electrostatic correlation terms
9542 c                write (iout,*) "gradcorr5 in eello5 before loop"
9543 c                do iii=1,nres
9544 c                  write (iout,'(i5,3f10.5)')
9545 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9546 c                enddo
9547       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9548 c        write (iout,*) "corr loop i",i
9549         i1=i+1
9550         num_conti=num_cont_hb(i)
9551         num_conti1=num_cont_hb(i+1)
9552         do jj=1,num_conti
9553           j=jcont_hb(jj,i)
9554           jp=iabs(j)
9555           do kk=1,num_conti1
9556             j1=jcont_hb(kk,i1)
9557             jp1=iabs(j1)
9558 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9559 c     &         ' jj=',jj,' kk=',kk
9560 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9561             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9562      &          .or. j.lt.0 .and. j1.gt.0) .and.
9563      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9564 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9565 C The system gains extra energy.
9566               n_corr=n_corr+1
9567               sqd1=dsqrt(d_cont(jj,i))
9568               sqd2=dsqrt(d_cont(kk,i1))
9569               sred_geom = sqd1*sqd2
9570               IF (sred_geom.lt.cutoff_corr) THEN
9571                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9572      &            ekont,fprimcont)
9573 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9574 cd     &         ' jj=',jj,' kk=',kk
9575                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9576                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9577                 do l=1,3
9578                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9579                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9580                 enddo
9581                 n_corr1=n_corr1+1
9582 cd               write (iout,*) 'sred_geom=',sred_geom,
9583 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9584 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9585 cd               write (iout,*) "g_contij",g_contij
9586 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9587 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9588                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9589                 if (wcorr4.gt.0.0d0)
9590      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9591 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9592                   if (energy_dec.and.wcorr4.gt.0.0d0)
9593      1                 write (iout,'(a6,4i5,0pf7.3)')
9594      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9595 c                write (iout,*) "gradcorr5 before eello5"
9596 c                do iii=1,nres
9597 c                  write (iout,'(i5,3f10.5)')
9598 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9599 c                enddo
9600                 if (wcorr5.gt.0.0d0)
9601      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9602 c                write (iout,*) "gradcorr5 after eello5"
9603 c                do iii=1,nres
9604 c                  write (iout,'(i5,3f10.5)')
9605 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9606 c                enddo
9607                   if (energy_dec.and.wcorr5.gt.0.0d0)
9608      1                 write (iout,'(a6,4i5,0pf7.3)')
9609      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9610 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9611 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9612                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9613      &               .or. wturn6.eq.0.0d0))then
9614 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9615                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9616                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9617      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9618 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9619 cd     &            'ecorr6=',ecorr6
9620 cd                write (iout,'(4e15.5)') sred_geom,
9621 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9622 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9623 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9624                 else if (wturn6.gt.0.0d0
9625      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9626 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9627                   eturn6=eturn6+eello_turn6(i,jj,kk)
9628                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9629      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9630 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9631                 endif
9632               ENDIF
9633 1111          continue
9634             endif
9635           enddo ! kk
9636         enddo ! jj
9637       enddo ! i
9638       do i=1,nres
9639         num_cont_hb(i)=num_cont_hb_old(i)
9640       enddo
9641 c                write (iout,*) "gradcorr5 in eello5"
9642 c                do iii=1,nres
9643 c                  write (iout,'(i5,3f10.5)')
9644 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9645 c                enddo
9646       return
9647       end
9648 c------------------------------------------------------------------------------
9649       subroutine add_hb_contact_eello(ii,jj,itask)
9650       implicit real*8 (a-h,o-z)
9651       include "DIMENSIONS"
9652       include "COMMON.IOUNITS"
9653       integer max_cont
9654       integer max_dim
9655       parameter (max_cont=maxconts)
9656       parameter (max_dim=70)
9657       include "COMMON.CONTACTS"
9658       include 'COMMON.CONTMAT'
9659       include 'COMMON.CORRMAT'
9660       double precision zapas(max_dim,maxconts,max_fg_procs),
9661      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9662       common /przechowalnia/ zapas
9663       integer i,j,ii,jj,iproc,itask(4),nn
9664 c      write (iout,*) "itask",itask
9665       do i=1,2
9666         iproc=itask(i)
9667         if (iproc.gt.0) then
9668           do j=1,num_cont_hb(ii)
9669             jjc=jcont_hb(j,ii)
9670 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9671             if (jjc.eq.jj) then
9672               ncont_sent(iproc)=ncont_sent(iproc)+1
9673               nn=ncont_sent(iproc)
9674               zapas(1,nn,iproc)=ii
9675               zapas(2,nn,iproc)=jjc
9676               zapas(3,nn,iproc)=d_cont(j,ii)
9677               ind=3
9678               do kk=1,3
9679                 ind=ind+1
9680                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9681               enddo
9682               do kk=1,2
9683                 do ll=1,2
9684                   ind=ind+1
9685                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9686                 enddo
9687               enddo
9688               do jj=1,5
9689                 do kk=1,3
9690                   do ll=1,2
9691                     do mm=1,2
9692                       ind=ind+1
9693                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9694                     enddo
9695                   enddo
9696                 enddo
9697               enddo
9698               exit
9699             endif
9700           enddo
9701         endif
9702       enddo
9703       return
9704       end
9705 c------------------------------------------------------------------------------
9706       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9707       implicit real*8 (a-h,o-z)
9708       include 'DIMENSIONS'
9709       include 'COMMON.IOUNITS'
9710       include 'COMMON.DERIV'
9711       include 'COMMON.INTERACT'
9712       include 'COMMON.CONTACTS'
9713       include 'COMMON.CONTMAT'
9714       include 'COMMON.CORRMAT'
9715       include 'COMMON.SHIELD'
9716       include 'COMMON.CONTROL'
9717       double precision gx(3),gx1(3)
9718       logical lprn
9719       lprn=.false.
9720 C      print *,"wchodze",fac_shield(i),shield_mode
9721       eij=facont_hb(jj,i)
9722       ekl=facont_hb(kk,k)
9723       ees0pij=ees0p(jj,i)
9724       ees0pkl=ees0p(kk,k)
9725       ees0mij=ees0m(jj,i)
9726       ees0mkl=ees0m(kk,k)
9727       ekont=eij*ekl
9728       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9729 C*
9730 C     & fac_shield(i)**2*fac_shield(j)**2
9731 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9732 C Following 4 lines for diagnostics.
9733 cd    ees0pkl=0.0D0
9734 cd    ees0pij=1.0D0
9735 cd    ees0mkl=0.0D0
9736 cd    ees0mij=1.0D0
9737 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9738 c     & 'Contacts ',i,j,
9739 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9740 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9741 c     & 'gradcorr_long'
9742 C Calculate the multi-body contribution to energy.
9743 C      ecorr=ecorr+ekont*ees
9744 C Calculate multi-body contributions to the gradient.
9745       coeffpees0pij=coeffp*ees0pij
9746       coeffmees0mij=coeffm*ees0mij
9747       coeffpees0pkl=coeffp*ees0pkl
9748       coeffmees0mkl=coeffm*ees0mkl
9749       do ll=1,3
9750 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9751         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9752      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9753      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9754         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9755      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9756      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9757 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9758         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9759      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9760      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9761         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9762      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9763      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9764         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9765      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9766      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9767         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9768         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9769         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9770      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9771      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9772         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9773         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9774 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9775       enddo
9776 c      write (iout,*)
9777 cgrad      do m=i+1,j-1
9778 cgrad        do ll=1,3
9779 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9780 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9781 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9782 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9783 cgrad        enddo
9784 cgrad      enddo
9785 cgrad      do m=k+1,l-1
9786 cgrad        do ll=1,3
9787 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9788 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9789 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9790 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9791 cgrad        enddo
9792 cgrad      enddo
9793 c      write (iout,*) "ehbcorr",ekont*ees
9794 C      print *,ekont,ees,i,k
9795       ehbcorr=ekont*ees
9796 C now gradient over shielding
9797 C      return
9798       if (shield_mode.gt.0) then
9799        j=ees0plist(jj,i)
9800        l=ees0plist(kk,k)
9801 C        print *,i,j,fac_shield(i),fac_shield(j),
9802 C     &fac_shield(k),fac_shield(l)
9803         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9804      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9805           do ilist=1,ishield_list(i)
9806            iresshield=shield_list(ilist,i)
9807            do m=1,3
9808            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9809 C     &      *2.0
9810            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9811      &              rlocshield
9812      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9813             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9814      &+rlocshield
9815            enddo
9816           enddo
9817           do ilist=1,ishield_list(j)
9818            iresshield=shield_list(ilist,j)
9819            do m=1,3
9820            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9821 C     &     *2.0
9822            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9823      &              rlocshield
9824      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9825            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9826      &     +rlocshield
9827            enddo
9828           enddo
9829
9830           do ilist=1,ishield_list(k)
9831            iresshield=shield_list(ilist,k)
9832            do m=1,3
9833            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9834 C     &     *2.0
9835            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9836      &              rlocshield
9837      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9838            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9839      &     +rlocshield
9840            enddo
9841           enddo
9842           do ilist=1,ishield_list(l)
9843            iresshield=shield_list(ilist,l)
9844            do m=1,3
9845            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9846 C     &     *2.0
9847            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9848      &              rlocshield
9849      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9850            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9851      &     +rlocshield
9852            enddo
9853           enddo
9854 C          print *,gshieldx(m,iresshield)
9855           do m=1,3
9856             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9857      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9858             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9859      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9860             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9861      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9862             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9863      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9864
9865             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9866      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9867             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9868      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9869             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9870      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9871             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9872      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9873
9874            enddo
9875       endif
9876       endif
9877       return
9878       end
9879 #ifdef MOMENT
9880 C---------------------------------------------------------------------------
9881       subroutine dipole(i,j,jj)
9882       implicit real*8 (a-h,o-z)
9883       include 'DIMENSIONS'
9884       include 'COMMON.IOUNITS'
9885       include 'COMMON.CHAIN'
9886       include 'COMMON.FFIELD'
9887       include 'COMMON.DERIV'
9888       include 'COMMON.INTERACT'
9889       include 'COMMON.CONTACTS'
9890       include 'COMMON.CONTMAT'
9891       include 'COMMON.CORRMAT'
9892       include 'COMMON.TORSION'
9893       include 'COMMON.VAR'
9894       include 'COMMON.GEO'
9895       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9896      &  auxmat(2,2)
9897       iti1 = itortyp(itype(i+1))
9898       if (j.lt.nres-1) then
9899         itj1 = itype2loc(itype(j+1))
9900       else
9901         itj1=nloctyp
9902       endif
9903       do iii=1,2
9904         dipi(iii,1)=Ub2(iii,i)
9905         dipderi(iii)=Ub2der(iii,i)
9906         dipi(iii,2)=b1(iii,i+1)
9907         dipj(iii,1)=Ub2(iii,j)
9908         dipderj(iii)=Ub2der(iii,j)
9909         dipj(iii,2)=b1(iii,j+1)
9910       enddo
9911       kkk=0
9912       do iii=1,2
9913         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9914         do jjj=1,2
9915           kkk=kkk+1
9916           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9917         enddo
9918       enddo
9919       do kkk=1,5
9920         do lll=1,3
9921           mmm=0
9922           do iii=1,2
9923             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9924      &        auxvec(1))
9925             do jjj=1,2
9926               mmm=mmm+1
9927               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9928             enddo
9929           enddo
9930         enddo
9931       enddo
9932       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9933       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9934       do iii=1,2
9935         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9936       enddo
9937       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9938       do iii=1,2
9939         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9940       enddo
9941       return
9942       end
9943 #endif
9944 C---------------------------------------------------------------------------
9945       subroutine calc_eello(i,j,k,l,jj,kk)
9946 C
9947 C This subroutine computes matrices and vectors needed to calculate
9948 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9949 C
9950       implicit real*8 (a-h,o-z)
9951       include 'DIMENSIONS'
9952       include 'COMMON.IOUNITS'
9953       include 'COMMON.CHAIN'
9954       include 'COMMON.DERIV'
9955       include 'COMMON.INTERACT'
9956       include 'COMMON.CONTACTS'
9957       include 'COMMON.CONTMAT'
9958       include 'COMMON.CORRMAT'
9959       include 'COMMON.TORSION'
9960       include 'COMMON.VAR'
9961       include 'COMMON.GEO'
9962       include 'COMMON.FFIELD'
9963       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9964      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9965       logical lprn
9966       common /kutas/ lprn
9967 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9968 cd     & ' jj=',jj,' kk=',kk
9969 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9970 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9971 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9972       do iii=1,2
9973         do jjj=1,2
9974           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9975           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9976         enddo
9977       enddo
9978       call transpose2(aa1(1,1),aa1t(1,1))
9979       call transpose2(aa2(1,1),aa2t(1,1))
9980       do kkk=1,5
9981         do lll=1,3
9982           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9983      &      aa1tder(1,1,lll,kkk))
9984           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9985      &      aa2tder(1,1,lll,kkk))
9986         enddo
9987       enddo
9988       if (l.eq.j+1) then
9989 C parallel orientation of the two CA-CA-CA frames.
9990         if (i.gt.1) then
9991           iti=itype2loc(itype(i))
9992         else
9993           iti=nloctyp
9994         endif
9995         itk1=itype2loc(itype(k+1))
9996         itj=itype2loc(itype(j))
9997         if (l.lt.nres-1) then
9998           itl1=itype2loc(itype(l+1))
9999         else
10000           itl1=nloctyp
10001         endif
10002 C A1 kernel(j+1) A2T
10003 cd        do iii=1,2
10004 cd          write (iout,'(3f10.5,5x,3f10.5)')
10005 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10006 cd        enddo
10007         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10008      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10009      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10010 C Following matrices are needed only for 6-th order cumulants
10011         IF (wcorr6.gt.0.0d0) THEN
10012         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10013      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10014      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10015         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10016      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10017      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10018      &   ADtEAderx(1,1,1,1,1,1))
10019         lprn=.false.
10020         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10021      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10022      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10023      &   ADtEA1derx(1,1,1,1,1,1))
10024         ENDIF
10025 C End 6-th order cumulants
10026 cd        lprn=.false.
10027 cd        if (lprn) then
10028 cd        write (2,*) 'In calc_eello6'
10029 cd        do iii=1,2
10030 cd          write (2,*) 'iii=',iii
10031 cd          do kkk=1,5
10032 cd            write (2,*) 'kkk=',kkk
10033 cd            do jjj=1,2
10034 cd              write (2,'(3(2f10.5),5x)')
10035 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10036 cd            enddo
10037 cd          enddo
10038 cd        enddo
10039 cd        endif
10040         call transpose2(EUgder(1,1,k),auxmat(1,1))
10041         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10042         call transpose2(EUg(1,1,k),auxmat(1,1))
10043         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10044         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10045 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10046 c    in theta; to be sriten later.
10047 c#ifdef NEWCORR
10048 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
10049 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10050 c        call transpose2(EUg(1,1,k),auxmat(1,1))
10051 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10052 c#endif
10053         do iii=1,2
10054           do kkk=1,5
10055             do lll=1,3
10056               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10057      &          EAEAderx(1,1,lll,kkk,iii,1))
10058             enddo
10059           enddo
10060         enddo
10061 C A1T kernel(i+1) A2
10062         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10063      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10064      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10065 C Following matrices are needed only for 6-th order cumulants
10066         IF (wcorr6.gt.0.0d0) THEN
10067         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10068      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10069      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10070         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10071      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10072      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10073      &   ADtEAderx(1,1,1,1,1,2))
10074         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10075      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10076      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10077      &   ADtEA1derx(1,1,1,1,1,2))
10078         ENDIF
10079 C End 6-th order cumulants
10080         call transpose2(EUgder(1,1,l),auxmat(1,1))
10081         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10082         call transpose2(EUg(1,1,l),auxmat(1,1))
10083         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10084         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10085         do iii=1,2
10086           do kkk=1,5
10087             do lll=1,3
10088               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10089      &          EAEAderx(1,1,lll,kkk,iii,2))
10090             enddo
10091           enddo
10092         enddo
10093 C AEAb1 and AEAb2
10094 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10095 C They are needed only when the fifth- or the sixth-order cumulants are
10096 C indluded.
10097         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10098         call transpose2(AEA(1,1,1),auxmat(1,1))
10099         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10100         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10101         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10102         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10103         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10104         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10105         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10106         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10107         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10108         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10109         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10110         call transpose2(AEA(1,1,2),auxmat(1,1))
10111         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10112         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10113         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10114         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10115         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10116         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10117         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10118         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10119         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10120         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10121         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10122 C Calculate the Cartesian derivatives of the vectors.
10123         do iii=1,2
10124           do kkk=1,5
10125             do lll=1,3
10126               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10127               call matvec2(auxmat(1,1),b1(1,i),
10128      &          AEAb1derx(1,lll,kkk,iii,1,1))
10129               call matvec2(auxmat(1,1),Ub2(1,i),
10130      &          AEAb2derx(1,lll,kkk,iii,1,1))
10131               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10132      &          AEAb1derx(1,lll,kkk,iii,2,1))
10133               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10134      &          AEAb2derx(1,lll,kkk,iii,2,1))
10135               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10136               call matvec2(auxmat(1,1),b1(1,j),
10137      &          AEAb1derx(1,lll,kkk,iii,1,2))
10138               call matvec2(auxmat(1,1),Ub2(1,j),
10139      &          AEAb2derx(1,lll,kkk,iii,1,2))
10140               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10141      &          AEAb1derx(1,lll,kkk,iii,2,2))
10142               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10143      &          AEAb2derx(1,lll,kkk,iii,2,2))
10144             enddo
10145           enddo
10146         enddo
10147         ENDIF
10148 C End vectors
10149       else
10150 C Antiparallel orientation of the two CA-CA-CA frames.
10151         if (i.gt.1) then
10152           iti=itype2loc(itype(i))
10153         else
10154           iti=nloctyp
10155         endif
10156         itk1=itype2loc(itype(k+1))
10157         itl=itype2loc(itype(l))
10158         itj=itype2loc(itype(j))
10159         if (j.lt.nres-1) then
10160           itj1=itype2loc(itype(j+1))
10161         else
10162           itj1=nloctyp
10163         endif
10164 C A2 kernel(j-1)T A1T
10165         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10166      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10167      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10168 C Following matrices are needed only for 6-th order cumulants
10169         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10170      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10171         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10172      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10173      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10174         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10175      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10176      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10177      &   ADtEAderx(1,1,1,1,1,1))
10178         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10179      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10180      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10181      &   ADtEA1derx(1,1,1,1,1,1))
10182         ENDIF
10183 C End 6-th order cumulants
10184         call transpose2(EUgder(1,1,k),auxmat(1,1))
10185         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10186         call transpose2(EUg(1,1,k),auxmat(1,1))
10187         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10188         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10189         do iii=1,2
10190           do kkk=1,5
10191             do lll=1,3
10192               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10193      &          EAEAderx(1,1,lll,kkk,iii,1))
10194             enddo
10195           enddo
10196         enddo
10197 C A2T kernel(i+1)T A1
10198         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10199      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10200      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10201 C Following matrices are needed only for 6-th order cumulants
10202         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10203      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10204         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10205      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10206      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10207         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10208      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10209      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10210      &   ADtEAderx(1,1,1,1,1,2))
10211         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10212      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10213      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10214      &   ADtEA1derx(1,1,1,1,1,2))
10215         ENDIF
10216 C End 6-th order cumulants
10217         call transpose2(EUgder(1,1,j),auxmat(1,1))
10218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10219         call transpose2(EUg(1,1,j),auxmat(1,1))
10220         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10221         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10222         do iii=1,2
10223           do kkk=1,5
10224             do lll=1,3
10225               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10226      &          EAEAderx(1,1,lll,kkk,iii,2))
10227             enddo
10228           enddo
10229         enddo
10230 C AEAb1 and AEAb2
10231 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10232 C They are needed only when the fifth- or the sixth-order cumulants are
10233 C indluded.
10234         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10235      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10236         call transpose2(AEA(1,1,1),auxmat(1,1))
10237         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10238         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10239         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10240         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10241         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10242         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10243         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10244         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10245         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10246         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10247         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10248         call transpose2(AEA(1,1,2),auxmat(1,1))
10249         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10250         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10251         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10252         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10253         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10254         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10255         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10256         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10257         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10258         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10259         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10260 C Calculate the Cartesian derivatives of the vectors.
10261         do iii=1,2
10262           do kkk=1,5
10263             do lll=1,3
10264               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10265               call matvec2(auxmat(1,1),b1(1,i),
10266      &          AEAb1derx(1,lll,kkk,iii,1,1))
10267               call matvec2(auxmat(1,1),Ub2(1,i),
10268      &          AEAb2derx(1,lll,kkk,iii,1,1))
10269               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10270      &          AEAb1derx(1,lll,kkk,iii,2,1))
10271               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10272      &          AEAb2derx(1,lll,kkk,iii,2,1))
10273               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10274               call matvec2(auxmat(1,1),b1(1,l),
10275      &          AEAb1derx(1,lll,kkk,iii,1,2))
10276               call matvec2(auxmat(1,1),Ub2(1,l),
10277      &          AEAb2derx(1,lll,kkk,iii,1,2))
10278               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10279      &          AEAb1derx(1,lll,kkk,iii,2,2))
10280               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10281      &          AEAb2derx(1,lll,kkk,iii,2,2))
10282             enddo
10283           enddo
10284         enddo
10285         ENDIF
10286 C End vectors
10287       endif
10288       return
10289       end
10290 C---------------------------------------------------------------------------
10291       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10292      &  KK,KKderg,AKA,AKAderg,AKAderx)
10293       implicit none
10294       integer nderg
10295       logical transp
10296       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10297      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10298      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10299       integer iii,kkk,lll
10300       integer jjj,mmm
10301       logical lprn
10302       common /kutas/ lprn
10303       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10304       do iii=1,nderg
10305         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10306      &    AKAderg(1,1,iii))
10307       enddo
10308 cd      if (lprn) write (2,*) 'In kernel'
10309       do kkk=1,5
10310 cd        if (lprn) write (2,*) 'kkk=',kkk
10311         do lll=1,3
10312           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10313      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10314 cd          if (lprn) then
10315 cd            write (2,*) 'lll=',lll
10316 cd            write (2,*) 'iii=1'
10317 cd            do jjj=1,2
10318 cd              write (2,'(3(2f10.5),5x)')
10319 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10320 cd            enddo
10321 cd          endif
10322           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10323      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10324 cd          if (lprn) then
10325 cd            write (2,*) 'lll=',lll
10326 cd            write (2,*) 'iii=2'
10327 cd            do jjj=1,2
10328 cd              write (2,'(3(2f10.5),5x)')
10329 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10330 cd            enddo
10331 cd          endif
10332         enddo
10333       enddo
10334       return
10335       end
10336 C---------------------------------------------------------------------------
10337       double precision function eello4(i,j,k,l,jj,kk)
10338       implicit real*8 (a-h,o-z)
10339       include 'DIMENSIONS'
10340       include 'COMMON.IOUNITS'
10341       include 'COMMON.CHAIN'
10342       include 'COMMON.DERIV'
10343       include 'COMMON.INTERACT'
10344       include 'COMMON.CONTACTS'
10345       include 'COMMON.CONTMAT'
10346       include 'COMMON.CORRMAT'
10347       include 'COMMON.TORSION'
10348       include 'COMMON.VAR'
10349       include 'COMMON.GEO'
10350       double precision pizda(2,2),ggg1(3),ggg2(3)
10351 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10352 cd        eello4=0.0d0
10353 cd        return
10354 cd      endif
10355 cd      print *,'eello4:',i,j,k,l,jj,kk
10356 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10357 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10358 cold      eij=facont_hb(jj,i)
10359 cold      ekl=facont_hb(kk,k)
10360 cold      ekont=eij*ekl
10361       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10362 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10363       gcorr_loc(k-1)=gcorr_loc(k-1)
10364      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10365       if (l.eq.j+1) then
10366         gcorr_loc(l-1)=gcorr_loc(l-1)
10367      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10368 C Al 4/16/16: Derivatives in theta, to be added later.
10369 c#ifdef NEWCORR
10370 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10371 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10372 c#endif
10373       else
10374         gcorr_loc(j-1)=gcorr_loc(j-1)
10375      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10376 c#ifdef NEWCORR
10377 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10378 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10379 c#endif
10380       endif
10381       do iii=1,2
10382         do kkk=1,5
10383           do lll=1,3
10384             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10385      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10386 cd            derx(lll,kkk,iii)=0.0d0
10387           enddo
10388         enddo
10389       enddo
10390 cd      gcorr_loc(l-1)=0.0d0
10391 cd      gcorr_loc(j-1)=0.0d0
10392 cd      gcorr_loc(k-1)=0.0d0
10393 cd      eel4=1.0d0
10394 cd      write (iout,*)'Contacts have occurred for peptide groups',
10395 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10396 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10397       if (j.lt.nres-1) then
10398         j1=j+1
10399         j2=j-1
10400       else
10401         j1=j-1
10402         j2=j-2
10403       endif
10404       if (l.lt.nres-1) then
10405         l1=l+1
10406         l2=l-1
10407       else
10408         l1=l-1
10409         l2=l-2
10410       endif
10411       do ll=1,3
10412 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10413 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10414         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10415         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10416 cgrad        ghalf=0.5d0*ggg1(ll)
10417         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10418         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10419         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10420         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10421         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10422         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10423 cgrad        ghalf=0.5d0*ggg2(ll)
10424         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10425         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10426         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10427         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10428         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10429         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10430       enddo
10431 cgrad      do m=i+1,j-1
10432 cgrad        do ll=1,3
10433 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10434 cgrad        enddo
10435 cgrad      enddo
10436 cgrad      do m=k+1,l-1
10437 cgrad        do ll=1,3
10438 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10439 cgrad        enddo
10440 cgrad      enddo
10441 cgrad      do m=i+2,j2
10442 cgrad        do ll=1,3
10443 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10444 cgrad        enddo
10445 cgrad      enddo
10446 cgrad      do m=k+2,l2
10447 cgrad        do ll=1,3
10448 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10449 cgrad        enddo
10450 cgrad      enddo
10451 cd      do iii=1,nres-3
10452 cd        write (2,*) iii,gcorr_loc(iii)
10453 cd      enddo
10454       eello4=ekont*eel4
10455 cd      write (2,*) 'ekont',ekont
10456 cd      write (iout,*) 'eello4',ekont*eel4
10457       return
10458       end
10459 C---------------------------------------------------------------------------
10460       double precision function eello5(i,j,k,l,jj,kk)
10461       implicit real*8 (a-h,o-z)
10462       include 'DIMENSIONS'
10463       include 'COMMON.IOUNITS'
10464       include 'COMMON.CHAIN'
10465       include 'COMMON.DERIV'
10466       include 'COMMON.INTERACT'
10467       include 'COMMON.CONTACTS'
10468       include 'COMMON.CONTMAT'
10469       include 'COMMON.CORRMAT'
10470       include 'COMMON.TORSION'
10471       include 'COMMON.VAR'
10472       include 'COMMON.GEO'
10473       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10474       double precision ggg1(3),ggg2(3)
10475 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10476 C                                                                              C
10477 C                            Parallel chains                                   C
10478 C                                                                              C
10479 C          o             o                   o             o                   C
10480 C         /l\           / \             \   / \           / \   /              C
10481 C        /   \         /   \             \ /   \         /   \ /               C
10482 C       j| o |l1       | o |              o| o |         | o |o                C
10483 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10484 C      \i/   \         /   \ /             /   \         /   \                 C
10485 C       o    k1             o                                                  C
10486 C         (I)          (II)                (III)          (IV)                 C
10487 C                                                                              C
10488 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10489 C                                                                              C
10490 C                            Antiparallel chains                               C
10491 C                                                                              C
10492 C          o             o                   o             o                   C
10493 C         /j\           / \             \   / \           / \   /              C
10494 C        /   \         /   \             \ /   \         /   \ /               C
10495 C      j1| o |l        | o |              o| o |         | o |o                C
10496 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10497 C      \i/   \         /   \ /             /   \         /   \                 C
10498 C       o     k1            o                                                  C
10499 C         (I)          (II)                (III)          (IV)                 C
10500 C                                                                              C
10501 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10502 C                                                                              C
10503 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10504 C                                                                              C
10505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10506 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10507 cd        eello5=0.0d0
10508 cd        return
10509 cd      endif
10510 cd      write (iout,*)
10511 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10512 cd     &   ' and',k,l
10513       itk=itype2loc(itype(k))
10514       itl=itype2loc(itype(l))
10515       itj=itype2loc(itype(j))
10516       eello5_1=0.0d0
10517       eello5_2=0.0d0
10518       eello5_3=0.0d0
10519       eello5_4=0.0d0
10520 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10521 cd     &   eel5_3_num,eel5_4_num)
10522       do iii=1,2
10523         do kkk=1,5
10524           do lll=1,3
10525             derx(lll,kkk,iii)=0.0d0
10526           enddo
10527         enddo
10528       enddo
10529 cd      eij=facont_hb(jj,i)
10530 cd      ekl=facont_hb(kk,k)
10531 cd      ekont=eij*ekl
10532 cd      write (iout,*)'Contacts have occurred for peptide groups',
10533 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10534 cd      goto 1111
10535 C Contribution from the graph I.
10536 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10537 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10538       call transpose2(EUg(1,1,k),auxmat(1,1))
10539       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10540       vv(1)=pizda(1,1)-pizda(2,2)
10541       vv(2)=pizda(1,2)+pizda(2,1)
10542       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10543      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10544 C Explicit gradient in virtual-dihedral angles.
10545       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10546      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10547      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10548       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10549       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10550       vv(1)=pizda(1,1)-pizda(2,2)
10551       vv(2)=pizda(1,2)+pizda(2,1)
10552       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10553      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10554      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10555       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10556       vv(1)=pizda(1,1)-pizda(2,2)
10557       vv(2)=pizda(1,2)+pizda(2,1)
10558       if (l.eq.j+1) then
10559         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10560      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10561      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10562       else
10563         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10564      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10565      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10566       endif
10567 C Cartesian gradient
10568       do iii=1,2
10569         do kkk=1,5
10570           do lll=1,3
10571             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10572      &        pizda(1,1))
10573             vv(1)=pizda(1,1)-pizda(2,2)
10574             vv(2)=pizda(1,2)+pizda(2,1)
10575             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10576      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10577      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10578           enddo
10579         enddo
10580       enddo
10581 c      goto 1112
10582 c1111  continue
10583 C Contribution from graph II
10584       call transpose2(EE(1,1,k),auxmat(1,1))
10585       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10586       vv(1)=pizda(1,1)+pizda(2,2)
10587       vv(2)=pizda(2,1)-pizda(1,2)
10588       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10589      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10590 C Explicit gradient in virtual-dihedral angles.
10591       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10592      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10593       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10594       vv(1)=pizda(1,1)+pizda(2,2)
10595       vv(2)=pizda(2,1)-pizda(1,2)
10596       if (l.eq.j+1) then
10597         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10598      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10599      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10600       else
10601         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10602      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10603      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10604       endif
10605 C Cartesian gradient
10606       do iii=1,2
10607         do kkk=1,5
10608           do lll=1,3
10609             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10610      &        pizda(1,1))
10611             vv(1)=pizda(1,1)+pizda(2,2)
10612             vv(2)=pizda(2,1)-pizda(1,2)
10613             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10614      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10615      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10616           enddo
10617         enddo
10618       enddo
10619 cd      goto 1112
10620 cd1111  continue
10621       if (l.eq.j+1) then
10622 cd        goto 1110
10623 C Parallel orientation
10624 C Contribution from graph III
10625         call transpose2(EUg(1,1,l),auxmat(1,1))
10626         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10627         vv(1)=pizda(1,1)-pizda(2,2)
10628         vv(2)=pizda(1,2)+pizda(2,1)
10629         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10630      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10631 C Explicit gradient in virtual-dihedral angles.
10632         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10633      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10634      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10635         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10636         vv(1)=pizda(1,1)-pizda(2,2)
10637         vv(2)=pizda(1,2)+pizda(2,1)
10638         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10639      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10640      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10641         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10642         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10643         vv(1)=pizda(1,1)-pizda(2,2)
10644         vv(2)=pizda(1,2)+pizda(2,1)
10645         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10646      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10647      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10648 C Cartesian gradient
10649         do iii=1,2
10650           do kkk=1,5
10651             do lll=1,3
10652               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10653      &          pizda(1,1))
10654               vv(1)=pizda(1,1)-pizda(2,2)
10655               vv(2)=pizda(1,2)+pizda(2,1)
10656               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10657      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10658      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10659             enddo
10660           enddo
10661         enddo
10662 cd        goto 1112
10663 C Contribution from graph IV
10664 cd1110    continue
10665         call transpose2(EE(1,1,l),auxmat(1,1))
10666         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10667         vv(1)=pizda(1,1)+pizda(2,2)
10668         vv(2)=pizda(2,1)-pizda(1,2)
10669         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10670      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10671 C Explicit gradient in virtual-dihedral angles.
10672         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10673      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10674         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10675         vv(1)=pizda(1,1)+pizda(2,2)
10676         vv(2)=pizda(2,1)-pizda(1,2)
10677         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10678      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10679      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10680 C Cartesian gradient
10681         do iii=1,2
10682           do kkk=1,5
10683             do lll=1,3
10684               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10685      &          pizda(1,1))
10686               vv(1)=pizda(1,1)+pizda(2,2)
10687               vv(2)=pizda(2,1)-pizda(1,2)
10688               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10689      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10690      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10691             enddo
10692           enddo
10693         enddo
10694       else
10695 C Antiparallel orientation
10696 C Contribution from graph III
10697 c        goto 1110
10698         call transpose2(EUg(1,1,j),auxmat(1,1))
10699         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10700         vv(1)=pizda(1,1)-pizda(2,2)
10701         vv(2)=pizda(1,2)+pizda(2,1)
10702         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10703      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10704 C Explicit gradient in virtual-dihedral angles.
10705         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10706      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10707      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10708         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10709         vv(1)=pizda(1,1)-pizda(2,2)
10710         vv(2)=pizda(1,2)+pizda(2,1)
10711         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10712      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10713      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10714         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10715         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10716         vv(1)=pizda(1,1)-pizda(2,2)
10717         vv(2)=pizda(1,2)+pizda(2,1)
10718         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10719      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10720      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10721 C Cartesian gradient
10722         do iii=1,2
10723           do kkk=1,5
10724             do lll=1,3
10725               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10726      &          pizda(1,1))
10727               vv(1)=pizda(1,1)-pizda(2,2)
10728               vv(2)=pizda(1,2)+pizda(2,1)
10729               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10730      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10731      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10732             enddo
10733           enddo
10734         enddo
10735 cd        goto 1112
10736 C Contribution from graph IV
10737 1110    continue
10738         call transpose2(EE(1,1,j),auxmat(1,1))
10739         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10740         vv(1)=pizda(1,1)+pizda(2,2)
10741         vv(2)=pizda(2,1)-pizda(1,2)
10742         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10743      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10744 C Explicit gradient in virtual-dihedral angles.
10745         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10746      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10747         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10748         vv(1)=pizda(1,1)+pizda(2,2)
10749         vv(2)=pizda(2,1)-pizda(1,2)
10750         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10751      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10752      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10753 C Cartesian gradient
10754         do iii=1,2
10755           do kkk=1,5
10756             do lll=1,3
10757               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10758      &          pizda(1,1))
10759               vv(1)=pizda(1,1)+pizda(2,2)
10760               vv(2)=pizda(2,1)-pizda(1,2)
10761               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10762      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10763      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10764             enddo
10765           enddo
10766         enddo
10767       endif
10768 1112  continue
10769       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10770 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10771 cd        write (2,*) 'ijkl',i,j,k,l
10772 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10773 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10774 cd      endif
10775 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10776 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10777 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10778 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10779       if (j.lt.nres-1) then
10780         j1=j+1
10781         j2=j-1
10782       else
10783         j1=j-1
10784         j2=j-2
10785       endif
10786       if (l.lt.nres-1) then
10787         l1=l+1
10788         l2=l-1
10789       else
10790         l1=l-1
10791         l2=l-2
10792       endif
10793 cd      eij=1.0d0
10794 cd      ekl=1.0d0
10795 cd      ekont=1.0d0
10796 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10797 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10798 C        summed up outside the subrouine as for the other subroutines
10799 C        handling long-range interactions. The old code is commented out
10800 C        with "cgrad" to keep track of changes.
10801       do ll=1,3
10802 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10803 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10804         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10805         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10806 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10807 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10808 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10809 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10810 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10811 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10812 c     &   gradcorr5ij,
10813 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10814 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10815 cgrad        ghalf=0.5d0*ggg1(ll)
10816 cd        ghalf=0.0d0
10817         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10818         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10819         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10820         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10821         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10822         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10823 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10824 cgrad        ghalf=0.5d0*ggg2(ll)
10825 cd        ghalf=0.0d0
10826         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10827         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10828         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10829         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10830         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10831         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10832       enddo
10833 cd      goto 1112
10834 cgrad      do m=i+1,j-1
10835 cgrad        do ll=1,3
10836 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10837 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10838 cgrad        enddo
10839 cgrad      enddo
10840 cgrad      do m=k+1,l-1
10841 cgrad        do ll=1,3
10842 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10843 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10844 cgrad        enddo
10845 cgrad      enddo
10846 c1112  continue
10847 cgrad      do m=i+2,j2
10848 cgrad        do ll=1,3
10849 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10850 cgrad        enddo
10851 cgrad      enddo
10852 cgrad      do m=k+2,l2
10853 cgrad        do ll=1,3
10854 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10855 cgrad        enddo
10856 cgrad      enddo
10857 cd      do iii=1,nres-3
10858 cd        write (2,*) iii,g_corr5_loc(iii)
10859 cd      enddo
10860       eello5=ekont*eel5
10861 cd      write (2,*) 'ekont',ekont
10862 cd      write (iout,*) 'eello5',ekont*eel5
10863       return
10864       end
10865 c--------------------------------------------------------------------------
10866       double precision function eello6(i,j,k,l,jj,kk)
10867       implicit real*8 (a-h,o-z)
10868       include 'DIMENSIONS'
10869       include 'COMMON.IOUNITS'
10870       include 'COMMON.CHAIN'
10871       include 'COMMON.DERIV'
10872       include 'COMMON.INTERACT'
10873       include 'COMMON.CONTACTS'
10874       include 'COMMON.CONTMAT'
10875       include 'COMMON.CORRMAT'
10876       include 'COMMON.TORSION'
10877       include 'COMMON.VAR'
10878       include 'COMMON.GEO'
10879       include 'COMMON.FFIELD'
10880       double precision ggg1(3),ggg2(3)
10881 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10882 cd        eello6=0.0d0
10883 cd        return
10884 cd      endif
10885 cd      write (iout,*)
10886 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10887 cd     &   ' and',k,l
10888       eello6_1=0.0d0
10889       eello6_2=0.0d0
10890       eello6_3=0.0d0
10891       eello6_4=0.0d0
10892       eello6_5=0.0d0
10893       eello6_6=0.0d0
10894 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10895 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10896       do iii=1,2
10897         do kkk=1,5
10898           do lll=1,3
10899             derx(lll,kkk,iii)=0.0d0
10900           enddo
10901         enddo
10902       enddo
10903 cd      eij=facont_hb(jj,i)
10904 cd      ekl=facont_hb(kk,k)
10905 cd      ekont=eij*ekl
10906 cd      eij=1.0d0
10907 cd      ekl=1.0d0
10908 cd      ekont=1.0d0
10909       if (l.eq.j+1) then
10910         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10911         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10912         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10913         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10914         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10915         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10916       else
10917         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10918         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10919         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10920         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10921         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10922           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10923         else
10924           eello6_5=0.0d0
10925         endif
10926         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10927       endif
10928 C If turn contributions are considered, they will be handled separately.
10929       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10930 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10931 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10932 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10933 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10934 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10935 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10936 cd      goto 1112
10937       if (j.lt.nres-1) then
10938         j1=j+1
10939         j2=j-1
10940       else
10941         j1=j-1
10942         j2=j-2
10943       endif
10944       if (l.lt.nres-1) then
10945         l1=l+1
10946         l2=l-1
10947       else
10948         l1=l-1
10949         l2=l-2
10950       endif
10951       do ll=1,3
10952 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10953 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10954 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10955 cgrad        ghalf=0.5d0*ggg1(ll)
10956 cd        ghalf=0.0d0
10957         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10958         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10959         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10960         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10961         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10962         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10963         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10964         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10965 cgrad        ghalf=0.5d0*ggg2(ll)
10966 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10967 cd        ghalf=0.0d0
10968         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10969         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10970         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10971         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10972         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10973         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10974       enddo
10975 cd      goto 1112
10976 cgrad      do m=i+1,j-1
10977 cgrad        do ll=1,3
10978 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10979 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10980 cgrad        enddo
10981 cgrad      enddo
10982 cgrad      do m=k+1,l-1
10983 cgrad        do ll=1,3
10984 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10985 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10986 cgrad        enddo
10987 cgrad      enddo
10988 cgrad1112  continue
10989 cgrad      do m=i+2,j2
10990 cgrad        do ll=1,3
10991 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10992 cgrad        enddo
10993 cgrad      enddo
10994 cgrad      do m=k+2,l2
10995 cgrad        do ll=1,3
10996 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10997 cgrad        enddo
10998 cgrad      enddo
10999 cd      do iii=1,nres-3
11000 cd        write (2,*) iii,g_corr6_loc(iii)
11001 cd      enddo
11002       eello6=ekont*eel6
11003 cd      write (2,*) 'ekont',ekont
11004 cd      write (iout,*) 'eello6',ekont*eel6
11005       return
11006       end
11007 c--------------------------------------------------------------------------
11008       double precision function eello6_graph1(i,j,k,l,imat,swap)
11009       implicit real*8 (a-h,o-z)
11010       include 'DIMENSIONS'
11011       include 'COMMON.IOUNITS'
11012       include 'COMMON.CHAIN'
11013       include 'COMMON.DERIV'
11014       include 'COMMON.INTERACT'
11015       include 'COMMON.CONTACTS'
11016       include 'COMMON.CONTMAT'
11017       include 'COMMON.CORRMAT'
11018       include 'COMMON.TORSION'
11019       include 'COMMON.VAR'
11020       include 'COMMON.GEO'
11021       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11022       logical swap
11023       logical lprn
11024       common /kutas/ lprn
11025 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11026 C                                                                              C
11027 C      Parallel       Antiparallel                                             C
11028 C                                                                              C
11029 C          o             o                                                     C
11030 C         /l\           /j\                                                    C
11031 C        /   \         /   \                                                   C
11032 C       /| o |         | o |\                                                  C
11033 C     \ j|/k\|  /   \  |/k\|l /                                                C
11034 C      \ /   \ /     \ /   \ /                                                 C
11035 C       o     o       o     o                                                  C
11036 C       i             i                                                        C
11037 C                                                                              C
11038 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11039       itk=itype2loc(itype(k))
11040       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11041       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11042       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11043       call transpose2(EUgC(1,1,k),auxmat(1,1))
11044       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11045       vv1(1)=pizda1(1,1)-pizda1(2,2)
11046       vv1(2)=pizda1(1,2)+pizda1(2,1)
11047       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11048       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11049       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11050       s5=scalar2(vv(1),Dtobr2(1,i))
11051 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11052       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11053       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11054      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11055      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11056      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11057      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11058      & +scalar2(vv(1),Dtobr2der(1,i)))
11059       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11060       vv1(1)=pizda1(1,1)-pizda1(2,2)
11061       vv1(2)=pizda1(1,2)+pizda1(2,1)
11062       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11063       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11064       if (l.eq.j+1) then
11065         g_corr6_loc(l-1)=g_corr6_loc(l-1)
11066      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11067      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11068      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11069      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11070       else
11071         g_corr6_loc(j-1)=g_corr6_loc(j-1)
11072      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11073      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11074      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11075      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11076       endif
11077       call transpose2(EUgCder(1,1,k),auxmat(1,1))
11078       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11079       vv1(1)=pizda1(1,1)-pizda1(2,2)
11080       vv1(2)=pizda1(1,2)+pizda1(2,1)
11081       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11082      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11083      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11084      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11085       do iii=1,2
11086         if (swap) then
11087           ind=3-iii
11088         else
11089           ind=iii
11090         endif
11091         do kkk=1,5
11092           do lll=1,3
11093             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11094             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11095             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11096             call transpose2(EUgC(1,1,k),auxmat(1,1))
11097             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11098      &        pizda1(1,1))
11099             vv1(1)=pizda1(1,1)-pizda1(2,2)
11100             vv1(2)=pizda1(1,2)+pizda1(2,1)
11101             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11102             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11103      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11104             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11105      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11106             s5=scalar2(vv(1),Dtobr2(1,i))
11107             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11108           enddo
11109         enddo
11110       enddo
11111       return
11112       end
11113 c----------------------------------------------------------------------------
11114       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11115       implicit real*8 (a-h,o-z)
11116       include 'DIMENSIONS'
11117       include 'COMMON.IOUNITS'
11118       include 'COMMON.CHAIN'
11119       include 'COMMON.DERIV'
11120       include 'COMMON.INTERACT'
11121       include 'COMMON.CONTACTS'
11122       include 'COMMON.CONTMAT'
11123       include 'COMMON.CORRMAT'
11124       include 'COMMON.TORSION'
11125       include 'COMMON.VAR'
11126       include 'COMMON.GEO'
11127       logical swap
11128       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11129      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11130       logical lprn
11131       common /kutas/ lprn
11132 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11133 C                                                                              C
11134 C      Parallel       Antiparallel                                             C
11135 C                                                                              C
11136 C          o             o                                                     C
11137 C     \   /l\           /j\   /                                                C
11138 C      \ /   \         /   \ /                                                 C
11139 C       o| o |         | o |o                                                  C
11140 C     \ j|/k\|      \  |/k\|l                                                  C
11141 C      \ /   \       \ /   \                                                   C
11142 C       o             o                                                        C
11143 C       i             i                                                        C
11144 C                                                                              C
11145 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11146 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11147 C AL 7/4/01 s1 would occur in the sixth-order moment,
11148 C           but not in a cluster cumulant
11149 #ifdef MOMENT
11150       s1=dip(1,jj,i)*dip(1,kk,k)
11151 #endif
11152       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11153       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11154       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11155       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11156       call transpose2(EUg(1,1,k),auxmat(1,1))
11157       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11158       vv(1)=pizda(1,1)-pizda(2,2)
11159       vv(2)=pizda(1,2)+pizda(2,1)
11160       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11161 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11162 #ifdef MOMENT
11163       eello6_graph2=-(s1+s2+s3+s4)
11164 #else
11165       eello6_graph2=-(s2+s3+s4)
11166 #endif
11167 c      eello6_graph2=-s3
11168 C Derivatives in gamma(i-1)
11169       if (i.gt.1) then
11170 #ifdef MOMENT
11171         s1=dipderg(1,jj,i)*dip(1,kk,k)
11172 #endif
11173         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11174         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11175         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11176         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11177 #ifdef MOMENT
11178         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11179 #else
11180         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11181 #endif
11182 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11183       endif
11184 C Derivatives in gamma(k-1)
11185 #ifdef MOMENT
11186       s1=dip(1,jj,i)*dipderg(1,kk,k)
11187 #endif
11188       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11189       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11190       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11191       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11192       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11193       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11194       vv(1)=pizda(1,1)-pizda(2,2)
11195       vv(2)=pizda(1,2)+pizda(2,1)
11196       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11197 #ifdef MOMENT
11198       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11199 #else
11200       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11201 #endif
11202 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11203 C Derivatives in gamma(j-1) or gamma(l-1)
11204       if (j.gt.1) then
11205 #ifdef MOMENT
11206         s1=dipderg(3,jj,i)*dip(1,kk,k)
11207 #endif
11208         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11209         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11210         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11211         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11212         vv(1)=pizda(1,1)-pizda(2,2)
11213         vv(2)=pizda(1,2)+pizda(2,1)
11214         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11215 #ifdef MOMENT
11216         if (swap) then
11217           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11218         else
11219           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11220         endif
11221 #endif
11222         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11223 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11224       endif
11225 C Derivatives in gamma(l-1) or gamma(j-1)
11226       if (l.gt.1) then
11227 #ifdef MOMENT
11228         s1=dip(1,jj,i)*dipderg(3,kk,k)
11229 #endif
11230         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11231         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11232         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11233         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11234         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11235         vv(1)=pizda(1,1)-pizda(2,2)
11236         vv(2)=pizda(1,2)+pizda(2,1)
11237         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11238 #ifdef MOMENT
11239         if (swap) then
11240           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11241         else
11242           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11243         endif
11244 #endif
11245         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11246 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11247       endif
11248 C Cartesian derivatives.
11249       if (lprn) then
11250         write (2,*) 'In eello6_graph2'
11251         do iii=1,2
11252           write (2,*) 'iii=',iii
11253           do kkk=1,5
11254             write (2,*) 'kkk=',kkk
11255             do jjj=1,2
11256               write (2,'(3(2f10.5),5x)')
11257      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11258             enddo
11259           enddo
11260         enddo
11261       endif
11262       do iii=1,2
11263         do kkk=1,5
11264           do lll=1,3
11265 #ifdef MOMENT
11266             if (iii.eq.1) then
11267               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11268             else
11269               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11270             endif
11271 #endif
11272             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11273      &        auxvec(1))
11274             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11275             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11276      &        auxvec(1))
11277             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11278             call transpose2(EUg(1,1,k),auxmat(1,1))
11279             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11280      &        pizda(1,1))
11281             vv(1)=pizda(1,1)-pizda(2,2)
11282             vv(2)=pizda(1,2)+pizda(2,1)
11283             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11284 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11285 #ifdef MOMENT
11286             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11287 #else
11288             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11289 #endif
11290             if (swap) then
11291               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11292             else
11293               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11294             endif
11295           enddo
11296         enddo
11297       enddo
11298       return
11299       end
11300 c----------------------------------------------------------------------------
11301       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11302       implicit real*8 (a-h,o-z)
11303       include 'DIMENSIONS'
11304       include 'COMMON.IOUNITS'
11305       include 'COMMON.CHAIN'
11306       include 'COMMON.DERIV'
11307       include 'COMMON.INTERACT'
11308       include 'COMMON.CONTACTS'
11309       include 'COMMON.CONTMAT'
11310       include 'COMMON.CORRMAT'
11311       include 'COMMON.TORSION'
11312       include 'COMMON.VAR'
11313       include 'COMMON.GEO'
11314       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11315       logical swap
11316 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11317 C                                                                              C
11318 C      Parallel       Antiparallel                                             C
11319 C                                                                              C
11320 C          o             o                                                     C
11321 C         /l\   /   \   /j\                                                    C
11322 C        /   \ /     \ /   \                                                   C
11323 C       /| o |o       o| o |\                                                  C
11324 C       j|/k\|  /      |/k\|l /                                                C
11325 C        /   \ /       /   \ /                                                 C
11326 C       /     o       /     o                                                  C
11327 C       i             i                                                        C
11328 C                                                                              C
11329 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11330 C
11331 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11332 C           energy moment and not to the cluster cumulant.
11333       iti=itortyp(itype(i))
11334       if (j.lt.nres-1) then
11335         itj1=itype2loc(itype(j+1))
11336       else
11337         itj1=nloctyp
11338       endif
11339       itk=itype2loc(itype(k))
11340       itk1=itype2loc(itype(k+1))
11341       if (l.lt.nres-1) then
11342         itl1=itype2loc(itype(l+1))
11343       else
11344         itl1=nloctyp
11345       endif
11346 #ifdef MOMENT
11347       s1=dip(4,jj,i)*dip(4,kk,k)
11348 #endif
11349       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11350       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11351       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11352       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11353       call transpose2(EE(1,1,k),auxmat(1,1))
11354       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11355       vv(1)=pizda(1,1)+pizda(2,2)
11356       vv(2)=pizda(2,1)-pizda(1,2)
11357       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11358 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11359 cd     & "sum",-(s2+s3+s4)
11360 #ifdef MOMENT
11361       eello6_graph3=-(s1+s2+s3+s4)
11362 #else
11363       eello6_graph3=-(s2+s3+s4)
11364 #endif
11365 c      eello6_graph3=-s4
11366 C Derivatives in gamma(k-1)
11367       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11368       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11369       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11370       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11371 C Derivatives in gamma(l-1)
11372       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11373       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11374       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11375       vv(1)=pizda(1,1)+pizda(2,2)
11376       vv(2)=pizda(2,1)-pizda(1,2)
11377       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11378       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11379 C Cartesian derivatives.
11380       do iii=1,2
11381         do kkk=1,5
11382           do lll=1,3
11383 #ifdef MOMENT
11384             if (iii.eq.1) then
11385               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11386             else
11387               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11388             endif
11389 #endif
11390             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11391      &        auxvec(1))
11392             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11393             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11394      &        auxvec(1))
11395             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11396             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11397      &        pizda(1,1))
11398             vv(1)=pizda(1,1)+pizda(2,2)
11399             vv(2)=pizda(2,1)-pizda(1,2)
11400             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11401 #ifdef MOMENT
11402             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11403 #else
11404             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11405 #endif
11406             if (swap) then
11407               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11408             else
11409               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11410             endif
11411 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11412           enddo
11413         enddo
11414       enddo
11415       return
11416       end
11417 c----------------------------------------------------------------------------
11418       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11419       implicit real*8 (a-h,o-z)
11420       include 'DIMENSIONS'
11421       include 'COMMON.IOUNITS'
11422       include 'COMMON.CHAIN'
11423       include 'COMMON.DERIV'
11424       include 'COMMON.INTERACT'
11425       include 'COMMON.CONTACTS'
11426       include 'COMMON.CONTMAT'
11427       include 'COMMON.CORRMAT'
11428       include 'COMMON.TORSION'
11429       include 'COMMON.VAR'
11430       include 'COMMON.GEO'
11431       include 'COMMON.FFIELD'
11432       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11433      & auxvec1(2),auxmat1(2,2)
11434       logical swap
11435 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11436 C                                                                              C
11437 C      Parallel       Antiparallel                                             C
11438 C                                                                              C
11439 C          o             o                                                     C
11440 C         /l\   /   \   /j\                                                    C
11441 C        /   \ /     \ /   \                                                   C
11442 C       /| o |o       o| o |\                                                  C
11443 C     \ j|/k\|      \  |/k\|l                                                  C
11444 C      \ /   \       \ /   \                                                   C
11445 C       o     \       o     \                                                  C
11446 C       i             i                                                        C
11447 C                                                                              C
11448 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11449 C
11450 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11451 C           energy moment and not to the cluster cumulant.
11452 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11453       iti=itype2loc(itype(i))
11454       itj=itype2loc(itype(j))
11455       if (j.lt.nres-1) then
11456         itj1=itype2loc(itype(j+1))
11457       else
11458         itj1=nloctyp
11459       endif
11460       itk=itype2loc(itype(k))
11461       if (k.lt.nres-1) then
11462         itk1=itype2loc(itype(k+1))
11463       else
11464         itk1=nloctyp
11465       endif
11466       itl=itype2loc(itype(l))
11467       if (l.lt.nres-1) then
11468         itl1=itype2loc(itype(l+1))
11469       else
11470         itl1=nloctyp
11471       endif
11472 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11473 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11474 cd     & ' itl',itl,' itl1',itl1
11475 #ifdef MOMENT
11476       if (imat.eq.1) then
11477         s1=dip(3,jj,i)*dip(3,kk,k)
11478       else
11479         s1=dip(2,jj,j)*dip(2,kk,l)
11480       endif
11481 #endif
11482       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11483       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11484       if (j.eq.l+1) then
11485         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11486         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11487       else
11488         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11489         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11490       endif
11491       call transpose2(EUg(1,1,k),auxmat(1,1))
11492       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11493       vv(1)=pizda(1,1)-pizda(2,2)
11494       vv(2)=pizda(2,1)+pizda(1,2)
11495       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11496 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11497 #ifdef MOMENT
11498       eello6_graph4=-(s1+s2+s3+s4)
11499 #else
11500       eello6_graph4=-(s2+s3+s4)
11501 #endif
11502 C Derivatives in gamma(i-1)
11503       if (i.gt.1) then
11504 #ifdef MOMENT
11505         if (imat.eq.1) then
11506           s1=dipderg(2,jj,i)*dip(3,kk,k)
11507         else
11508           s1=dipderg(4,jj,j)*dip(2,kk,l)
11509         endif
11510 #endif
11511         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11512         if (j.eq.l+1) then
11513           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11514           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11515         else
11516           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11517           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11518         endif
11519         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11520         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11521 cd          write (2,*) 'turn6 derivatives'
11522 #ifdef MOMENT
11523           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11524 #else
11525           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11526 #endif
11527         else
11528 #ifdef MOMENT
11529           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11530 #else
11531           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11532 #endif
11533         endif
11534       endif
11535 C Derivatives in gamma(k-1)
11536 #ifdef MOMENT
11537       if (imat.eq.1) then
11538         s1=dip(3,jj,i)*dipderg(2,kk,k)
11539       else
11540         s1=dip(2,jj,j)*dipderg(4,kk,l)
11541       endif
11542 #endif
11543       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11544       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11545       if (j.eq.l+1) then
11546         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11547         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11548       else
11549         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11550         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11551       endif
11552       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11553       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11554       vv(1)=pizda(1,1)-pizda(2,2)
11555       vv(2)=pizda(2,1)+pizda(1,2)
11556       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11557       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11558 #ifdef MOMENT
11559         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11560 #else
11561         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11562 #endif
11563       else
11564 #ifdef MOMENT
11565         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11566 #else
11567         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11568 #endif
11569       endif
11570 C Derivatives in gamma(j-1) or gamma(l-1)
11571       if (l.eq.j+1 .and. l.gt.1) then
11572         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11573         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11574         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11575         vv(1)=pizda(1,1)-pizda(2,2)
11576         vv(2)=pizda(2,1)+pizda(1,2)
11577         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11578         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11579       else if (j.gt.1) then
11580         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11581         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11582         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11583         vv(1)=pizda(1,1)-pizda(2,2)
11584         vv(2)=pizda(2,1)+pizda(1,2)
11585         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11586         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11587           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11588         else
11589           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11590         endif
11591       endif
11592 C Cartesian derivatives.
11593       do iii=1,2
11594         do kkk=1,5
11595           do lll=1,3
11596 #ifdef MOMENT
11597             if (iii.eq.1) then
11598               if (imat.eq.1) then
11599                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11600               else
11601                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11602               endif
11603             else
11604               if (imat.eq.1) then
11605                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11606               else
11607                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11608               endif
11609             endif
11610 #endif
11611             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11612      &        auxvec(1))
11613             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11614             if (j.eq.l+1) then
11615               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11616      &          b1(1,j+1),auxvec(1))
11617               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11618             else
11619               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11620      &          b1(1,l+1),auxvec(1))
11621               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11622             endif
11623             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11624      &        pizda(1,1))
11625             vv(1)=pizda(1,1)-pizda(2,2)
11626             vv(2)=pizda(2,1)+pizda(1,2)
11627             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11628             if (swap) then
11629               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11630 #ifdef MOMENT
11631                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11632      &             -(s1+s2+s4)
11633 #else
11634                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11635      &             -(s2+s4)
11636 #endif
11637                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11638               else
11639 #ifdef MOMENT
11640                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11641 #else
11642                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11643 #endif
11644                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11645               endif
11646             else
11647 #ifdef MOMENT
11648               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11649 #else
11650               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11651 #endif
11652               if (l.eq.j+1) then
11653                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11654               else
11655                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11656               endif
11657             endif
11658           enddo
11659         enddo
11660       enddo
11661       return
11662       end
11663 c----------------------------------------------------------------------------
11664       double precision function eello_turn6(i,jj,kk)
11665       implicit real*8 (a-h,o-z)
11666       include 'DIMENSIONS'
11667       include 'COMMON.IOUNITS'
11668       include 'COMMON.CHAIN'
11669       include 'COMMON.DERIV'
11670       include 'COMMON.INTERACT'
11671       include 'COMMON.CONTACTS'
11672       include 'COMMON.CONTMAT'
11673       include 'COMMON.CORRMAT'
11674       include 'COMMON.TORSION'
11675       include 'COMMON.VAR'
11676       include 'COMMON.GEO'
11677       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11678      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11679      &  ggg1(3),ggg2(3)
11680       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11681      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11682 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11683 C           the respective energy moment and not to the cluster cumulant.
11684       s1=0.0d0
11685       s8=0.0d0
11686       s13=0.0d0
11687 c
11688       eello_turn6=0.0d0
11689       j=i+4
11690       k=i+1
11691       l=i+3
11692       iti=itype2loc(itype(i))
11693       itk=itype2loc(itype(k))
11694       itk1=itype2loc(itype(k+1))
11695       itl=itype2loc(itype(l))
11696       itj=itype2loc(itype(j))
11697 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11698 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11699 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11700 cd        eello6=0.0d0
11701 cd        return
11702 cd      endif
11703 cd      write (iout,*)
11704 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11705 cd     &   ' and',k,l
11706 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11707       do iii=1,2
11708         do kkk=1,5
11709           do lll=1,3
11710             derx_turn(lll,kkk,iii)=0.0d0
11711           enddo
11712         enddo
11713       enddo
11714 cd      eij=1.0d0
11715 cd      ekl=1.0d0
11716 cd      ekont=1.0d0
11717       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11718 cd      eello6_5=0.0d0
11719 cd      write (2,*) 'eello6_5',eello6_5
11720 #ifdef MOMENT
11721       call transpose2(AEA(1,1,1),auxmat(1,1))
11722       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11723       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11724       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11725 #endif
11726       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11727       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11728       s2 = scalar2(b1(1,k),vtemp1(1))
11729 #ifdef MOMENT
11730       call transpose2(AEA(1,1,2),atemp(1,1))
11731       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11732       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11733       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11734 #endif
11735       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11736       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11737       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11738 #ifdef MOMENT
11739       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11740       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11741       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11742       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11743       ss13 = scalar2(b1(1,k),vtemp4(1))
11744       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11745 #endif
11746 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11747 c      s1=0.0d0
11748 c      s2=0.0d0
11749 c      s8=0.0d0
11750 c      s12=0.0d0
11751 c      s13=0.0d0
11752       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11753 C Derivatives in gamma(i+2)
11754       s1d =0.0d0
11755       s8d =0.0d0
11756 #ifdef MOMENT
11757       call transpose2(AEA(1,1,1),auxmatd(1,1))
11758       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11759       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11760       call transpose2(AEAderg(1,1,2),atempd(1,1))
11761       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11762       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11763 #endif
11764       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11765       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11766       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11767 c      s1d=0.0d0
11768 c      s2d=0.0d0
11769 c      s8d=0.0d0
11770 c      s12d=0.0d0
11771 c      s13d=0.0d0
11772       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11773 C Derivatives in gamma(i+3)
11774 #ifdef MOMENT
11775       call transpose2(AEA(1,1,1),auxmatd(1,1))
11776       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11777       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11778       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11779 #endif
11780       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11781       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11782       s2d = scalar2(b1(1,k),vtemp1d(1))
11783 #ifdef MOMENT
11784       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11785       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11786 #endif
11787       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11788 #ifdef MOMENT
11789       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11790       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11791       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11792 #endif
11793 c      s1d=0.0d0
11794 c      s2d=0.0d0
11795 c      s8d=0.0d0
11796 c      s12d=0.0d0
11797 c      s13d=0.0d0
11798 #ifdef MOMENT
11799       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11800      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11801 #else
11802       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11803      &               -0.5d0*ekont*(s2d+s12d)
11804 #endif
11805 C Derivatives in gamma(i+4)
11806       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11807       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11808       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11809 #ifdef MOMENT
11810       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11811       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11812       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11813 #endif
11814 c      s1d=0.0d0
11815 c      s2d=0.0d0
11816 c      s8d=0.0d0
11817 C      s12d=0.0d0
11818 c      s13d=0.0d0
11819 #ifdef MOMENT
11820       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11821 #else
11822       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11823 #endif
11824 C Derivatives in gamma(i+5)
11825 #ifdef MOMENT
11826       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11827       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11828       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11829 #endif
11830       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11831       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11832       s2d = scalar2(b1(1,k),vtemp1d(1))
11833 #ifdef MOMENT
11834       call transpose2(AEA(1,1,2),atempd(1,1))
11835       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11836       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11837 #endif
11838       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11839       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11840 #ifdef MOMENT
11841       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11842       ss13d = scalar2(b1(1,k),vtemp4d(1))
11843       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11844 #endif
11845 c      s1d=0.0d0
11846 c      s2d=0.0d0
11847 c      s8d=0.0d0
11848 c      s12d=0.0d0
11849 c      s13d=0.0d0
11850 #ifdef MOMENT
11851       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11852      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11853 #else
11854       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11855      &               -0.5d0*ekont*(s2d+s12d)
11856 #endif
11857 C Cartesian derivatives
11858       do iii=1,2
11859         do kkk=1,5
11860           do lll=1,3
11861 #ifdef MOMENT
11862             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11863             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11864             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11865 #endif
11866             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11867             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11868      &          vtemp1d(1))
11869             s2d = scalar2(b1(1,k),vtemp1d(1))
11870 #ifdef MOMENT
11871             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11872             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11873             s8d = -(atempd(1,1)+atempd(2,2))*
11874      &           scalar2(cc(1,1,l),vtemp2(1))
11875 #endif
11876             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11877      &           auxmatd(1,1))
11878             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11879             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11880 c      s1d=0.0d0
11881 c      s2d=0.0d0
11882 c      s8d=0.0d0
11883 c      s12d=0.0d0
11884 c      s13d=0.0d0
11885 #ifdef MOMENT
11886             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11887      &        - 0.5d0*(s1d+s2d)
11888 #else
11889             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11890      &        - 0.5d0*s2d
11891 #endif
11892 #ifdef MOMENT
11893             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11894      &        - 0.5d0*(s8d+s12d)
11895 #else
11896             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11897      &        - 0.5d0*s12d
11898 #endif
11899           enddo
11900         enddo
11901       enddo
11902 #ifdef MOMENT
11903       do kkk=1,5
11904         do lll=1,3
11905           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11906      &      achuj_tempd(1,1))
11907           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11908           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11909           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11910           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11911           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11912      &      vtemp4d(1))
11913           ss13d = scalar2(b1(1,k),vtemp4d(1))
11914           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11915           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11916         enddo
11917       enddo
11918 #endif
11919 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11920 cd     &  16*eel_turn6_num
11921 cd      goto 1112
11922       if (j.lt.nres-1) then
11923         j1=j+1
11924         j2=j-1
11925       else
11926         j1=j-1
11927         j2=j-2
11928       endif
11929       if (l.lt.nres-1) then
11930         l1=l+1
11931         l2=l-1
11932       else
11933         l1=l-1
11934         l2=l-2
11935       endif
11936       do ll=1,3
11937 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11938 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11939 cgrad        ghalf=0.5d0*ggg1(ll)
11940 cd        ghalf=0.0d0
11941         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11942         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11943         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11944      &    +ekont*derx_turn(ll,2,1)
11945         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11946         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11947      &    +ekont*derx_turn(ll,4,1)
11948         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11949         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11950         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11951 cgrad        ghalf=0.5d0*ggg2(ll)
11952 cd        ghalf=0.0d0
11953         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11954      &    +ekont*derx_turn(ll,2,2)
11955         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11956         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11957      &    +ekont*derx_turn(ll,4,2)
11958         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11959         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11960         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11961       enddo
11962 cd      goto 1112
11963 cgrad      do m=i+1,j-1
11964 cgrad        do ll=1,3
11965 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11966 cgrad        enddo
11967 cgrad      enddo
11968 cgrad      do m=k+1,l-1
11969 cgrad        do ll=1,3
11970 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11971 cgrad        enddo
11972 cgrad      enddo
11973 cgrad1112  continue
11974 cgrad      do m=i+2,j2
11975 cgrad        do ll=1,3
11976 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11977 cgrad        enddo
11978 cgrad      enddo
11979 cgrad      do m=k+2,l2
11980 cgrad        do ll=1,3
11981 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11982 cgrad        enddo
11983 cgrad      enddo
11984 cd      do iii=1,nres-3
11985 cd        write (2,*) iii,g_corr6_loc(iii)
11986 cd      enddo
11987       eello_turn6=ekont*eel_turn6
11988 cd      write (2,*) 'ekont',ekont
11989 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11990       return
11991       end
11992 C-----------------------------------------------------------------------------
11993 #endif
11994       double precision function scalar(u,v)
11995 !DIR$ INLINEALWAYS scalar
11996 #ifndef OSF
11997 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11998 #endif
11999       implicit none
12000       double precision u(3),v(3)
12001 cd      double precision sc
12002 cd      integer i
12003 cd      sc=0.0d0
12004 cd      do i=1,3
12005 cd        sc=sc+u(i)*v(i)
12006 cd      enddo
12007 cd      scalar=sc
12008
12009       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12010       return
12011       end
12012 crc-------------------------------------------------
12013       SUBROUTINE MATVEC2(A1,V1,V2)
12014 !DIR$ INLINEALWAYS MATVEC2
12015 #ifndef OSF
12016 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12017 #endif
12018       implicit real*8 (a-h,o-z)
12019       include 'DIMENSIONS'
12020       DIMENSION A1(2,2),V1(2),V2(2)
12021 c      DO 1 I=1,2
12022 c        VI=0.0
12023 c        DO 3 K=1,2
12024 c    3     VI=VI+A1(I,K)*V1(K)
12025 c        Vaux(I)=VI
12026 c    1 CONTINUE
12027
12028       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12029       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12030
12031       v2(1)=vaux1
12032       v2(2)=vaux2
12033       END
12034 C---------------------------------------
12035       SUBROUTINE MATMAT2(A1,A2,A3)
12036 #ifndef OSF
12037 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12038 #endif
12039       implicit real*8 (a-h,o-z)
12040       include 'DIMENSIONS'
12041       DIMENSION A1(2,2),A2(2,2),A3(2,2)
12042 c      DIMENSION AI3(2,2)
12043 c        DO  J=1,2
12044 c          A3IJ=0.0
12045 c          DO K=1,2
12046 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
12047 c          enddo
12048 c          A3(I,J)=A3IJ
12049 c       enddo
12050 c      enddo
12051
12052       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12053       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12054       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12055       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12056
12057       A3(1,1)=AI3_11
12058       A3(2,1)=AI3_21
12059       A3(1,2)=AI3_12
12060       A3(2,2)=AI3_22
12061       END
12062
12063 c-------------------------------------------------------------------------
12064       double precision function scalar2(u,v)
12065 !DIR$ INLINEALWAYS scalar2
12066       implicit none
12067       double precision u(2),v(2)
12068       double precision sc
12069       integer i
12070       scalar2=u(1)*v(1)+u(2)*v(2)
12071       return
12072       end
12073
12074 C-----------------------------------------------------------------------------
12075
12076       subroutine transpose2(a,at)
12077 !DIR$ INLINEALWAYS transpose2
12078 #ifndef OSF
12079 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12080 #endif
12081       implicit none
12082       double precision a(2,2),at(2,2)
12083       at(1,1)=a(1,1)
12084       at(1,2)=a(2,1)
12085       at(2,1)=a(1,2)
12086       at(2,2)=a(2,2)
12087       return
12088       end
12089 c--------------------------------------------------------------------------
12090       subroutine transpose(n,a,at)
12091       implicit none
12092       integer n,i,j
12093       double precision a(n,n),at(n,n)
12094       do i=1,n
12095         do j=1,n
12096           at(j,i)=a(i,j)
12097         enddo
12098       enddo
12099       return
12100       end
12101 C---------------------------------------------------------------------------
12102       subroutine prodmat3(a1,a2,kk,transp,prod)
12103 !DIR$ INLINEALWAYS prodmat3
12104 #ifndef OSF
12105 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12106 #endif
12107       implicit none
12108       integer i,j
12109       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12110       logical transp
12111 crc      double precision auxmat(2,2),prod_(2,2)
12112
12113       if (transp) then
12114 crc        call transpose2(kk(1,1),auxmat(1,1))
12115 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12116 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12117
12118            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12119      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12120            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12121      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12122            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12123      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12124            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12125      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12126
12127       else
12128 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12129 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12130
12131            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12132      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12133            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12134      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12135            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12136      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12137            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12138      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12139
12140       endif
12141 c      call transpose2(a2(1,1),a2t(1,1))
12142
12143 crc      print *,transp
12144 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12145 crc      print *,((prod(i,j),i=1,2),j=1,2)
12146
12147       return
12148       end
12149 CCC----------------------------------------------
12150       subroutine Eliptransfer(eliptran)
12151       implicit real*8 (a-h,o-z)
12152       include 'DIMENSIONS'
12153       include 'COMMON.GEO'
12154       include 'COMMON.VAR'
12155       include 'COMMON.LOCAL'
12156       include 'COMMON.CHAIN'
12157       include 'COMMON.DERIV'
12158       include 'COMMON.NAMES'
12159       include 'COMMON.INTERACT'
12160       include 'COMMON.IOUNITS'
12161       include 'COMMON.CALC'
12162       include 'COMMON.CONTROL'
12163       include 'COMMON.SPLITELE'
12164       include 'COMMON.SBRIDGE'
12165 C this is done by Adasko
12166 C      print *,"wchodze"
12167 C structure of box:
12168 C      water
12169 C--bordliptop-- buffore starts
12170 C--bufliptop--- here true lipid starts
12171 C      lipid
12172 C--buflipbot--- lipid ends buffore starts
12173 C--bordlipbot--buffore ends
12174       eliptran=0.0
12175       do i=ilip_start,ilip_end
12176 C       do i=1,1
12177         if (itype(i).eq.ntyp1) cycle
12178
12179         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12180         if (positi.le.0.0) positi=positi+boxzsize
12181 C        print *,i
12182 C first for peptide groups
12183 c for each residue check if it is in lipid or lipid water border area
12184        if ((positi.gt.bordlipbot)
12185      &.and.(positi.lt.bordliptop)) then
12186 C the energy transfer exist
12187         if (positi.lt.buflipbot) then
12188 C what fraction I am in
12189          fracinbuf=1.0d0-
12190      &        ((positi-bordlipbot)/lipbufthick)
12191 C lipbufthick is thickenes of lipid buffore
12192          sslip=sscalelip(fracinbuf)
12193          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12194          eliptran=eliptran+sslip*pepliptran
12195          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12196          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12197 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12198
12199 C        print *,"doing sccale for lower part"
12200 C         print *,i,sslip,fracinbuf,ssgradlip
12201         elseif (positi.gt.bufliptop) then
12202          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12203          sslip=sscalelip(fracinbuf)
12204          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12205          eliptran=eliptran+sslip*pepliptran
12206          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12207          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12208 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12209 C          print *, "doing sscalefor top part"
12210 C         print *,i,sslip,fracinbuf,ssgradlip
12211         else
12212          eliptran=eliptran+pepliptran
12213 C         print *,"I am in true lipid"
12214         endif
12215 C       else
12216 C       eliptran=elpitran+0.0 ! I am in water
12217        endif
12218        enddo
12219 C       print *, "nic nie bylo w lipidzie?"
12220 C now multiply all by the peptide group transfer factor
12221 C       eliptran=eliptran*pepliptran
12222 C now the same for side chains
12223 CV       do i=1,1
12224        do i=ilip_start,ilip_end
12225         if (itype(i).eq.ntyp1) cycle
12226         positi=(mod(c(3,i+nres),boxzsize))
12227         if (positi.le.0) positi=positi+boxzsize
12228 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12229 c for each residue check if it is in lipid or lipid water border area
12230 C       respos=mod(c(3,i+nres),boxzsize)
12231 C       print *,positi,bordlipbot,buflipbot
12232        if ((positi.gt.bordlipbot)
12233      & .and.(positi.lt.bordliptop)) then
12234 C the energy transfer exist
12235         if (positi.lt.buflipbot) then
12236          fracinbuf=1.0d0-
12237      &     ((positi-bordlipbot)/lipbufthick)
12238 C lipbufthick is thickenes of lipid buffore
12239          sslip=sscalelip(fracinbuf)
12240          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12241          eliptran=eliptran+sslip*liptranene(itype(i))
12242          gliptranx(3,i)=gliptranx(3,i)
12243      &+ssgradlip*liptranene(itype(i))
12244          gliptranc(3,i-1)= gliptranc(3,i-1)
12245      &+ssgradlip*liptranene(itype(i))
12246 C         print *,"doing sccale for lower part"
12247         elseif (positi.gt.bufliptop) then
12248          fracinbuf=1.0d0-
12249      &((bordliptop-positi)/lipbufthick)
12250          sslip=sscalelip(fracinbuf)
12251          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12252          eliptran=eliptran+sslip*liptranene(itype(i))
12253          gliptranx(3,i)=gliptranx(3,i)
12254      &+ssgradlip*liptranene(itype(i))
12255          gliptranc(3,i-1)= gliptranc(3,i-1)
12256      &+ssgradlip*liptranene(itype(i))
12257 C          print *, "doing sscalefor top part",sslip,fracinbuf
12258         else
12259          eliptran=eliptran+liptranene(itype(i))
12260 C         print *,"I am in true lipid"
12261         endif
12262         endif ! if in lipid or buffor
12263 C       else
12264 C       eliptran=elpitran+0.0 ! I am in water
12265        enddo
12266        return
12267        end
12268 C---------------------------------------------------------
12269 C AFM soubroutine for constant force
12270        subroutine AFMforce(Eafmforce)
12271        implicit real*8 (a-h,o-z)
12272       include 'DIMENSIONS'
12273       include 'COMMON.GEO'
12274       include 'COMMON.VAR'
12275       include 'COMMON.LOCAL'
12276       include 'COMMON.CHAIN'
12277       include 'COMMON.DERIV'
12278       include 'COMMON.NAMES'
12279       include 'COMMON.INTERACT'
12280       include 'COMMON.IOUNITS'
12281       include 'COMMON.CALC'
12282       include 'COMMON.CONTROL'
12283       include 'COMMON.SPLITELE'
12284       include 'COMMON.SBRIDGE'
12285       real*8 diffafm(3)
12286       dist=0.0d0
12287       Eafmforce=0.0d0
12288       do i=1,3
12289       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12290       dist=dist+diffafm(i)**2
12291       enddo
12292       dist=dsqrt(dist)
12293       Eafmforce=-forceAFMconst*(dist-distafminit)
12294       do i=1,3
12295       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12296       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12297       enddo
12298 C      print *,'AFM',Eafmforce
12299       return
12300       end
12301 C---------------------------------------------------------
12302 C AFM subroutine with pseudoconstant velocity
12303        subroutine AFMvel(Eafmforce)
12304        implicit real*8 (a-h,o-z)
12305       include 'DIMENSIONS'
12306       include 'COMMON.GEO'
12307       include 'COMMON.VAR'
12308       include 'COMMON.LOCAL'
12309       include 'COMMON.CHAIN'
12310       include 'COMMON.DERIV'
12311       include 'COMMON.NAMES'
12312       include 'COMMON.INTERACT'
12313       include 'COMMON.IOUNITS'
12314       include 'COMMON.CALC'
12315       include 'COMMON.CONTROL'
12316       include 'COMMON.SPLITELE'
12317       include 'COMMON.SBRIDGE'
12318       real*8 diffafm(3)
12319 C Only for check grad COMMENT if not used for checkgrad
12320 C      totT=3.0d0
12321 C--------------------------------------------------------
12322 C      print *,"wchodze"
12323       dist=0.0d0
12324       Eafmforce=0.0d0
12325       do i=1,3
12326       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12327       dist=dist+diffafm(i)**2
12328       enddo
12329       dist=dsqrt(dist)
12330       Eafmforce=0.5d0*forceAFMconst
12331      & *(distafminit+totTafm*velAFMconst-dist)**2
12332 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12333       do i=1,3
12334       gradafm(i,afmend-1)=-forceAFMconst*
12335      &(distafminit+totTafm*velAFMconst-dist)
12336      &*diffafm(i)/dist
12337       gradafm(i,afmbeg-1)=forceAFMconst*
12338      &(distafminit+totTafm*velAFMconst-dist)
12339      &*diffafm(i)/dist
12340       enddo
12341 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12342       return
12343       end
12344 C-----------------------------------------------------------
12345 C first for shielding is setting of function of side-chains
12346        subroutine set_shield_fac
12347       implicit real*8 (a-h,o-z)
12348       include 'DIMENSIONS'
12349       include 'COMMON.CHAIN'
12350       include 'COMMON.DERIV'
12351       include 'COMMON.IOUNITS'
12352       include 'COMMON.SHIELD'
12353       include 'COMMON.INTERACT'
12354 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12355       double precision div77_81/0.974996043d0/,
12356      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12357
12358 C the vector between center of side_chain and peptide group
12359        double precision pep_side(3),long,side_calf(3),
12360      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12361      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12362 C the line belowe needs to be changed for FGPROC>1
12363       do i=1,nres-1
12364       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12365       ishield_list(i)=0
12366 Cif there two consequtive dummy atoms there is no peptide group between them
12367 C the line below has to be changed for FGPROC>1
12368       VolumeTotal=0.0
12369       do k=1,nres
12370        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12371        dist_pep_side=0.0
12372        dist_side_calf=0.0
12373        do j=1,3
12374 C first lets set vector conecting the ithe side-chain with kth side-chain
12375       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12376 C      pep_side(j)=2.0d0
12377 C and vector conecting the side-chain with its proper calfa
12378       side_calf(j)=c(j,k+nres)-c(j,k)
12379 C      side_calf(j)=2.0d0
12380       pept_group(j)=c(j,i)-c(j,i+1)
12381 C lets have their lenght
12382       dist_pep_side=pep_side(j)**2+dist_pep_side
12383       dist_side_calf=dist_side_calf+side_calf(j)**2
12384       dist_pept_group=dist_pept_group+pept_group(j)**2
12385       enddo
12386        dist_pep_side=dsqrt(dist_pep_side)
12387        dist_pept_group=dsqrt(dist_pept_group)
12388        dist_side_calf=dsqrt(dist_side_calf)
12389       do j=1,3
12390         pep_side_norm(j)=pep_side(j)/dist_pep_side
12391         side_calf_norm(j)=dist_side_calf
12392       enddo
12393 C now sscale fraction
12394        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12395 C       print *,buff_shield,"buff"
12396 C now sscale
12397         if (sh_frac_dist.le.0.0) cycle
12398 C If we reach here it means that this side chain reaches the shielding sphere
12399 C Lets add him to the list for gradient
12400         ishield_list(i)=ishield_list(i)+1
12401 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12402 C this list is essential otherwise problem would be O3
12403         shield_list(ishield_list(i),i)=k
12404 C Lets have the sscale value
12405         if (sh_frac_dist.gt.1.0) then
12406          scale_fac_dist=1.0d0
12407          do j=1,3
12408          sh_frac_dist_grad(j)=0.0d0
12409          enddo
12410         else
12411          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12412      &                   *(2.0*sh_frac_dist-3.0d0)
12413          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12414      &                  /dist_pep_side/buff_shield*0.5
12415 C remember for the final gradient multiply sh_frac_dist_grad(j)
12416 C for side_chain by factor -2 !
12417          do j=1,3
12418          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12419 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12420 C     &                    sh_frac_dist_grad(j)
12421          enddo
12422         endif
12423 C        if ((i.eq.3).and.(k.eq.2)) then
12424 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12425 C     & ,"TU"
12426 C        endif
12427
12428 C this is what is now we have the distance scaling now volume...
12429       short=short_r_sidechain(itype(k))
12430       long=long_r_sidechain(itype(k))
12431       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12432 C now costhet_grad
12433 C       costhet=0.0d0
12434        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12435 C       costhet_fac=0.0d0
12436        do j=1,3
12437          costhet_grad(j)=costhet_fac*pep_side(j)
12438        enddo
12439 C remember for the final gradient multiply costhet_grad(j)
12440 C for side_chain by factor -2 !
12441 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12442 C pep_side0pept_group is vector multiplication
12443       pep_side0pept_group=0.0
12444       do j=1,3
12445       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12446       enddo
12447       cosalfa=(pep_side0pept_group/
12448      & (dist_pep_side*dist_side_calf))
12449       fac_alfa_sin=1.0-cosalfa**2
12450       fac_alfa_sin=dsqrt(fac_alfa_sin)
12451       rkprim=fac_alfa_sin*(long-short)+short
12452 C now costhet_grad
12453        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12454        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12455
12456        do j=1,3
12457          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12458      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12459      &*(long-short)/fac_alfa_sin*cosalfa/
12460      &((dist_pep_side*dist_side_calf))*
12461      &((side_calf(j))-cosalfa*
12462      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12463
12464         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12465      &*(long-short)/fac_alfa_sin*cosalfa
12466      &/((dist_pep_side*dist_side_calf))*
12467      &(pep_side(j)-
12468      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12469        enddo
12470
12471       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12472      &                    /VSolvSphere_div
12473      &                    *wshield
12474 C now the gradient...
12475 C grad_shield is gradient of Calfa for peptide groups
12476 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12477 C     &               costhet,cosphi
12478 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12479 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12480       do j=1,3
12481       grad_shield(j,i)=grad_shield(j,i)
12482 C gradient po skalowaniu
12483      &                +(sh_frac_dist_grad(j)
12484 C  gradient po costhet
12485      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12486      &-scale_fac_dist*(cosphi_grad_long(j))
12487      &/(1.0-cosphi) )*div77_81
12488      &*VofOverlap
12489 C grad_shield_side is Cbeta sidechain gradient
12490       grad_shield_side(j,ishield_list(i),i)=
12491      &        (sh_frac_dist_grad(j)*(-2.0d0)
12492      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12493      &       +scale_fac_dist*(cosphi_grad_long(j))
12494      &        *2.0d0/(1.0-cosphi))
12495      &        *div77_81*VofOverlap
12496
12497        grad_shield_loc(j,ishield_list(i),i)=
12498      &   scale_fac_dist*cosphi_grad_loc(j)
12499      &        *2.0d0/(1.0-cosphi)
12500      &        *div77_81*VofOverlap
12501       enddo
12502       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12503       enddo
12504       fac_shield(i)=VolumeTotal*div77_81+div4_81
12505 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12506       enddo
12507       return
12508       end
12509 C--------------------------------------------------------------------------
12510       double precision function tschebyshev(m,n,x,y)
12511       implicit none
12512       include "DIMENSIONS"
12513       integer i,m,n
12514       double precision x(n),y,yy(0:maxvar),aux
12515 c Tschebyshev polynomial. Note that the first term is omitted
12516 c m=0: the constant term is included
12517 c m=1: the constant term is not included
12518       yy(0)=1.0d0
12519       yy(1)=y
12520       do i=2,n
12521         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12522       enddo
12523       aux=0.0d0
12524       do i=m,n
12525         aux=aux+x(i)*yy(i)
12526       enddo
12527       tschebyshev=aux
12528       return
12529       end
12530 C--------------------------------------------------------------------------
12531       double precision function gradtschebyshev(m,n,x,y)
12532       implicit none
12533       include "DIMENSIONS"
12534       integer i,m,n
12535       double precision x(n+1),y,yy(0:maxvar),aux
12536 c Tschebyshev polynomial. Note that the first term is omitted
12537 c m=0: the constant term is included
12538 c m=1: the constant term is not included
12539       yy(0)=1.0d0
12540       yy(1)=2.0d0*y
12541       do i=2,n
12542         yy(i)=2*y*yy(i-1)-yy(i-2)
12543       enddo
12544       aux=0.0d0
12545       do i=m,n
12546         aux=aux+x(i+1)*yy(i)*(i+1)
12547 C        print *, x(i+1),yy(i),i
12548       enddo
12549       gradtschebyshev=aux
12550       return
12551       end
12552 C------------------------------------------------------------------------
12553 C first for shielding is setting of function of side-chains
12554        subroutine set_shield_fac2
12555       implicit real*8 (a-h,o-z)
12556       include 'DIMENSIONS'
12557       include 'COMMON.CHAIN'
12558       include 'COMMON.DERIV'
12559       include 'COMMON.IOUNITS'
12560       include 'COMMON.SHIELD'
12561       include 'COMMON.INTERACT'
12562 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12563       double precision div77_81/0.974996043d0/,
12564      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12565
12566 C the vector between center of side_chain and peptide group
12567        double precision pep_side(3),long,side_calf(3),
12568      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12569      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12570 C the line belowe needs to be changed for FGPROC>1
12571       do i=1,nres-1
12572       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12573       ishield_list(i)=0
12574 Cif there two consequtive dummy atoms there is no peptide group between them
12575 C the line below has to be changed for FGPROC>1
12576       VolumeTotal=0.0
12577       do k=1,nres
12578        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12579        dist_pep_side=0.0
12580        dist_side_calf=0.0
12581        do j=1,3
12582 C first lets set vector conecting the ithe side-chain with kth side-chain
12583       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12584 C      pep_side(j)=2.0d0
12585 C and vector conecting the side-chain with its proper calfa
12586       side_calf(j)=c(j,k+nres)-c(j,k)
12587 C      side_calf(j)=2.0d0
12588       pept_group(j)=c(j,i)-c(j,i+1)
12589 C lets have their lenght
12590       dist_pep_side=pep_side(j)**2+dist_pep_side
12591       dist_side_calf=dist_side_calf+side_calf(j)**2
12592       dist_pept_group=dist_pept_group+pept_group(j)**2
12593       enddo
12594        dist_pep_side=dsqrt(dist_pep_side)
12595        dist_pept_group=dsqrt(dist_pept_group)
12596        dist_side_calf=dsqrt(dist_side_calf)
12597       do j=1,3
12598         pep_side_norm(j)=pep_side(j)/dist_pep_side
12599         side_calf_norm(j)=dist_side_calf
12600       enddo
12601 C now sscale fraction
12602        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12603 C       print *,buff_shield,"buff"
12604 C now sscale
12605         if (sh_frac_dist.le.0.0) cycle
12606 C If we reach here it means that this side chain reaches the shielding sphere
12607 C Lets add him to the list for gradient
12608         ishield_list(i)=ishield_list(i)+1
12609 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12610 C this list is essential otherwise problem would be O3
12611         shield_list(ishield_list(i),i)=k
12612 C Lets have the sscale value
12613         if (sh_frac_dist.gt.1.0) then
12614          scale_fac_dist=1.0d0
12615          do j=1,3
12616          sh_frac_dist_grad(j)=0.0d0
12617          enddo
12618         else
12619          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12620      &                   *(2.0d0*sh_frac_dist-3.0d0)
12621          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12622      &                  /dist_pep_side/buff_shield*0.5d0
12623 C remember for the final gradient multiply sh_frac_dist_grad(j)
12624 C for side_chain by factor -2 !
12625          do j=1,3
12626          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12627 C         sh_frac_dist_grad(j)=0.0d0
12628 C         scale_fac_dist=1.0d0
12629 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12630 C     &                    sh_frac_dist_grad(j)
12631          enddo
12632         endif
12633 C this is what is now we have the distance scaling now volume...
12634       short=short_r_sidechain(itype(k))
12635       long=long_r_sidechain(itype(k))
12636       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12637       sinthet=short/dist_pep_side*costhet
12638 C now costhet_grad
12639 C       costhet=0.6d0
12640 C       sinthet=0.8
12641        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12642 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12643 C     &             -short/dist_pep_side**2/costhet)
12644 C       costhet_fac=0.0d0
12645        do j=1,3
12646          costhet_grad(j)=costhet_fac*pep_side(j)
12647        enddo
12648 C remember for the final gradient multiply costhet_grad(j)
12649 C for side_chain by factor -2 !
12650 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12651 C pep_side0pept_group is vector multiplication
12652       pep_side0pept_group=0.0d0
12653       do j=1,3
12654       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12655       enddo
12656       cosalfa=(pep_side0pept_group/
12657      & (dist_pep_side*dist_side_calf))
12658       fac_alfa_sin=1.0d0-cosalfa**2
12659       fac_alfa_sin=dsqrt(fac_alfa_sin)
12660       rkprim=fac_alfa_sin*(long-short)+short
12661 C      rkprim=short
12662
12663 C now costhet_grad
12664        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12665 C       cosphi=0.6
12666        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12667        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12668      &      dist_pep_side**2)
12669 C       sinphi=0.8
12670        do j=1,3
12671          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12672      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12673      &*(long-short)/fac_alfa_sin*cosalfa/
12674      &((dist_pep_side*dist_side_calf))*
12675      &((side_calf(j))-cosalfa*
12676      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12677 C       cosphi_grad_long(j)=0.0d0
12678         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12679      &*(long-short)/fac_alfa_sin*cosalfa
12680      &/((dist_pep_side*dist_side_calf))*
12681      &(pep_side(j)-
12682      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12683 C       cosphi_grad_loc(j)=0.0d0
12684        enddo
12685 C      print *,sinphi,sinthet
12686 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12687 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12688       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12689      &                    /VSolvSphere_div
12690 C     &                    *wshield
12691 C now the gradient...
12692       do j=1,3
12693       grad_shield(j,i)=grad_shield(j,i)
12694 C gradient po skalowaniu
12695      &                +(sh_frac_dist_grad(j)*VofOverlap
12696 C  gradient po costhet
12697      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12698      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12699      &       sinphi/sinthet*costhet*costhet_grad(j)
12700      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12701      & )*wshield
12702 C grad_shield_side is Cbeta sidechain gradient
12703       grad_shield_side(j,ishield_list(i),i)=
12704      &        (sh_frac_dist_grad(j)*(-2.0d0)
12705      &        *VofOverlap
12706      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12707      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12708      &       sinphi/sinthet*costhet*costhet_grad(j)
12709      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12710      &       )*wshield
12711
12712        grad_shield_loc(j,ishield_list(i),i)=
12713      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12714      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12715      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12716      &        ))
12717      &        *wshield
12718       enddo
12719 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12720 c     & scale_fac_dist
12721       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12722       enddo
12723       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12724 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12725 c     &  " wshield",wshield
12726 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12727       enddo
12728       return
12729       end
12730 C-----------------------------------------------------------------------
12731 C-----------------------------------------------------------
12732 C This subroutine is to mimic the histone like structure but as well can be
12733 C utilizet to nanostructures (infinit) small modification has to be used to
12734 C make it finite (z gradient at the ends has to be changes as well as the x,y
12735 C gradient has to be modified at the ends
12736 C The energy function is Kihara potential
12737 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12738 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12739 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12740 C simple Kihara potential
12741       subroutine calctube(Etube)
12742        implicit real*8 (a-h,o-z)
12743       include 'DIMENSIONS'
12744       include 'COMMON.GEO'
12745       include 'COMMON.VAR'
12746       include 'COMMON.LOCAL'
12747       include 'COMMON.CHAIN'
12748       include 'COMMON.DERIV'
12749       include 'COMMON.NAMES'
12750       include 'COMMON.INTERACT'
12751       include 'COMMON.IOUNITS'
12752       include 'COMMON.CALC'
12753       include 'COMMON.CONTROL'
12754       include 'COMMON.SPLITELE'
12755       include 'COMMON.SBRIDGE'
12756       double precision tub_r,vectube(3),enetube(maxres*2)
12757       Etube=0.0d0
12758       do i=1,2*nres
12759         enetube(i)=0.0d0
12760       enddo
12761 C first we calculate the distance from tube center
12762 C first sugare-phosphate group for NARES this would be peptide group
12763 C for UNRES
12764       do i=1,nres
12765 C lets ommit dummy atoms for now
12766        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12767 C now calculate distance from center of tube and direction vectors
12768       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12769           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12770       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12771           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12772       vectube(1)=vectube(1)-tubecenter(1)
12773       vectube(2)=vectube(2)-tubecenter(2)
12774
12775 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12776 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12777
12778 C as the tube is infinity we do not calculate the Z-vector use of Z
12779 C as chosen axis
12780       vectube(3)=0.0d0
12781 C now calculte the distance
12782        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12783 C now normalize vector
12784       vectube(1)=vectube(1)/tub_r
12785       vectube(2)=vectube(2)/tub_r
12786 C calculte rdiffrence between r and r0
12787       rdiff=tub_r-tubeR0
12788 C and its 6 power
12789       rdiff6=rdiff**6.0d0
12790 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12791        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12792 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12793 C       print *,rdiff,rdiff6,pep_aa_tube
12794 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12795 C now we calculate gradient
12796        fac=(-12.0d0*pep_aa_tube/rdiff6+
12797      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12798 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12799 C     &rdiff,fac
12800
12801 C now direction of gg_tube vector
12802         do j=1,3
12803         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12804         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12805         enddo
12806         enddo
12807 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12808         do i=1,nres
12809 C Lets not jump over memory as we use many times iti
12810          iti=itype(i)
12811 C lets ommit dummy atoms for now
12812          if ((iti.eq.ntyp1)
12813 C in UNRES uncomment the line below as GLY has no side-chain...
12814 C      .or.(iti.eq.10)
12815      &   ) cycle
12816           vectube(1)=c(1,i+nres)
12817           vectube(1)=mod(vectube(1),boxxsize)
12818           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12819           vectube(2)=c(2,i+nres)
12820           vectube(2)=mod(vectube(2),boxxsize)
12821           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12822
12823       vectube(1)=vectube(1)-tubecenter(1)
12824       vectube(2)=vectube(2)-tubecenter(2)
12825
12826 C as the tube is infinity we do not calculate the Z-vector use of Z
12827 C as chosen axis
12828       vectube(3)=0.0d0
12829 C now calculte the distance
12830        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12831 C now normalize vector
12832       vectube(1)=vectube(1)/tub_r
12833       vectube(2)=vectube(2)/tub_r
12834 C calculte rdiffrence between r and r0
12835       rdiff=tub_r-tubeR0
12836 C and its 6 power
12837       rdiff6=rdiff**6.0d0
12838 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12839        sc_aa_tube=sc_aa_tube_par(iti)
12840        sc_bb_tube=sc_bb_tube_par(iti)
12841        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12842 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12843 C now we calculate gradient
12844        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12845      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12846 C now direction of gg_tube vector
12847          do j=1,3
12848           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12849           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12850          enddo
12851         enddo
12852         do i=1,2*nres
12853           Etube=Etube+enetube(i)
12854         enddo
12855 C        print *,"ETUBE", etube
12856         return
12857         end
12858 C TO DO 1) add to total energy
12859 C       2) add to gradient summation
12860 C       3) add reading parameters (AND of course oppening of PARAM file)
12861 C       4) add reading the center of tube
12862 C       5) add COMMONs
12863 C       6) add to zerograd
12864
12865 C-----------------------------------------------------------------------
12866 C-----------------------------------------------------------
12867 C This subroutine is to mimic the histone like structure but as well can be
12868 C utilizet to nanostructures (infinit) small modification has to be used to
12869 C make it finite (z gradient at the ends has to be changes as well as the x,y
12870 C gradient has to be modified at the ends
12871 C The energy function is Kihara potential
12872 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12873 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12874 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12875 C simple Kihara potential
12876       subroutine calctube2(Etube)
12877        implicit real*8 (a-h,o-z)
12878       include 'DIMENSIONS'
12879       include 'COMMON.GEO'
12880       include 'COMMON.VAR'
12881       include 'COMMON.LOCAL'
12882       include 'COMMON.CHAIN'
12883       include 'COMMON.DERIV'
12884       include 'COMMON.NAMES'
12885       include 'COMMON.INTERACT'
12886       include 'COMMON.IOUNITS'
12887       include 'COMMON.CALC'
12888       include 'COMMON.CONTROL'
12889       include 'COMMON.SPLITELE'
12890       include 'COMMON.SBRIDGE'
12891       double precision tub_r,vectube(3),enetube(maxres*2)
12892       Etube=0.0d0
12893       do i=1,2*nres
12894         enetube(i)=0.0d0
12895       enddo
12896 C first we calculate the distance from tube center
12897 C first sugare-phosphate group for NARES this would be peptide group
12898 C for UNRES
12899       do i=1,nres
12900 C lets ommit dummy atoms for now
12901        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12902 C now calculate distance from center of tube and direction vectors
12903       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12904           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12905       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12906           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12907       vectube(1)=vectube(1)-tubecenter(1)
12908       vectube(2)=vectube(2)-tubecenter(2)
12909
12910 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12911 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12912
12913 C as the tube is infinity we do not calculate the Z-vector use of Z
12914 C as chosen axis
12915       vectube(3)=0.0d0
12916 C now calculte the distance
12917        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12918 C now normalize vector
12919       vectube(1)=vectube(1)/tub_r
12920       vectube(2)=vectube(2)/tub_r
12921 C calculte rdiffrence between r and r0
12922       rdiff=tub_r-tubeR0
12923 C and its 6 power
12924       rdiff6=rdiff**6.0d0
12925 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12926        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12927 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12928 C       print *,rdiff,rdiff6,pep_aa_tube
12929 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12930 C now we calculate gradient
12931        fac=(-12.0d0*pep_aa_tube/rdiff6+
12932      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12933 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12934 C     &rdiff,fac
12935
12936 C now direction of gg_tube vector
12937         do j=1,3
12938         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12939         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12940         enddo
12941         enddo
12942 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12943         do i=1,nres
12944 C Lets not jump over memory as we use many times iti
12945          iti=itype(i)
12946 C lets ommit dummy atoms for now
12947          if ((iti.eq.ntyp1)
12948 C in UNRES uncomment the line below as GLY has no side-chain...
12949      &      .or.(iti.eq.10)
12950      &   ) cycle
12951           vectube(1)=c(1,i+nres)
12952           vectube(1)=mod(vectube(1),boxxsize)
12953           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12954           vectube(2)=c(2,i+nres)
12955           vectube(2)=mod(vectube(2),boxxsize)
12956           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12957
12958       vectube(1)=vectube(1)-tubecenter(1)
12959       vectube(2)=vectube(2)-tubecenter(2)
12960 C THIS FRAGMENT MAKES TUBE FINITE
12961         positi=(mod(c(3,i+nres),boxzsize))
12962         if (positi.le.0) positi=positi+boxzsize
12963 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12964 c for each residue check if it is in lipid or lipid water border area
12965 C       respos=mod(c(3,i+nres),boxzsize)
12966        print *,positi,bordtubebot,buftubebot,bordtubetop
12967        if ((positi.gt.bordtubebot)
12968      & .and.(positi.lt.bordtubetop)) then
12969 C the energy transfer exist
12970         if (positi.lt.buftubebot) then
12971          fracinbuf=1.0d0-
12972      &     ((positi-bordtubebot)/tubebufthick)
12973 C lipbufthick is thickenes of lipid buffore
12974          sstube=sscalelip(fracinbuf)
12975          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12976          print *,ssgradtube, sstube,tubetranene(itype(i))
12977          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12978          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12979      &+ssgradtube*tubetranene(itype(i))
12980          gg_tube(3,i-1)= gg_tube(3,i-1)
12981      &+ssgradtube*tubetranene(itype(i))
12982 C         print *,"doing sccale for lower part"
12983         elseif (positi.gt.buftubetop) then
12984          fracinbuf=1.0d0-
12985      &((bordtubetop-positi)/tubebufthick)
12986          sstube=sscalelip(fracinbuf)
12987          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12988          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12989 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12990 C     &+ssgradtube*tubetranene(itype(i))
12991 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12992 C     &+ssgradtube*tubetranene(itype(i))
12993 C          print *, "doing sscalefor top part",sslip,fracinbuf
12994         else
12995          sstube=1.0d0
12996          ssgradtube=0.0d0
12997          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12998 C         print *,"I am in true lipid"
12999         endif
13000         else
13001 C          sstube=0.0d0
13002 C          ssgradtube=0.0d0
13003         cycle
13004         endif ! if in lipid or buffor
13005 CEND OF FINITE FRAGMENT
13006 C as the tube is infinity we do not calculate the Z-vector use of Z
13007 C as chosen axis
13008       vectube(3)=0.0d0
13009 C now calculte the distance
13010        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13011 C now normalize vector
13012       vectube(1)=vectube(1)/tub_r
13013       vectube(2)=vectube(2)/tub_r
13014 C calculte rdiffrence between r and r0
13015       rdiff=tub_r-tubeR0
13016 C and its 6 power
13017       rdiff6=rdiff**6.0d0
13018 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13019        sc_aa_tube=sc_aa_tube_par(iti)
13020        sc_bb_tube=sc_bb_tube_par(iti)
13021        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13022      &                 *sstube+enetube(i+nres)
13023 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13024 C now we calculate gradient
13025        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13026      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13027 C now direction of gg_tube vector
13028          do j=1,3
13029           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13030           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13031          enddo
13032          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13033      &+ssgradtube*enetube(i+nres)/sstube
13034          gg_tube(3,i-1)= gg_tube(3,i-1)
13035      &+ssgradtube*enetube(i+nres)/sstube
13036
13037         enddo
13038         do i=1,2*nres
13039           Etube=Etube+enetube(i)
13040         enddo
13041 C        print *,"ETUBE", etube
13042         return
13043         end
13044 C TO DO 1) add to total energy
13045 C       2) add to gradient summation
13046 C       3) add reading parameters (AND of course oppening of PARAM file)
13047 C       4) add reading the center of tube
13048 C       5) add COMMONs
13049 C       6) add to zerograd
13050 c----------------------------------------------------------------------------
13051       subroutine e_saxs(Esaxs_constr)
13052       implicit none
13053       include 'DIMENSIONS'
13054 #ifdef MPI
13055       include "mpif.h"
13056       include "COMMON.SETUP"
13057       integer IERR
13058 #endif
13059       include 'COMMON.SBRIDGE'
13060       include 'COMMON.CHAIN'
13061       include 'COMMON.GEO'
13062       include 'COMMON.DERIV'
13063       include 'COMMON.LOCAL'
13064       include 'COMMON.INTERACT'
13065       include 'COMMON.VAR'
13066       include 'COMMON.IOUNITS'
13067 c      include 'COMMON.MD'
13068 #ifdef LANG0
13069 #ifdef FIVEDIAG
13070       include 'COMMON.LANGEVIN.lang0.5diag'
13071 #else
13072       include 'COMMON.LANGEVIN.lang0'
13073 #endif
13074 #else
13075       include 'COMMON.LANGEVIN'
13076 #endif
13077       include 'COMMON.CONTROL'
13078       include 'COMMON.SAXS'
13079       include 'COMMON.NAMES'
13080       include 'COMMON.TIME1'
13081       include 'COMMON.FFIELD'
13082 c
13083       double precision Esaxs_constr
13084       integer i,iint,j,k,l
13085       double precision PgradC(maxSAXS,3,maxres),
13086      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13087 #ifdef MPI
13088       double precision PgradC_(maxSAXS,3,maxres),
13089      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13090 #endif
13091       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13092      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13093      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13094      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13095       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13096       double precision dist,mygauss,mygaussder
13097       external dist
13098       integer llicz,lllicz
13099       double precision time01
13100 c  SAXS restraint penalty function
13101 #ifdef DEBUG
13102       write(iout,*) "------- SAXS penalty function start -------"
13103       write (iout,*) "nsaxs",nsaxs
13104       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13105       write (iout,*) "Psaxs"
13106       do i=1,nsaxs
13107         write (iout,'(i5,e15.5)') i, Psaxs(i)
13108       enddo
13109 #endif
13110 #ifdef TIMING
13111       time01=MPI_Wtime()
13112 #endif
13113       Esaxs_constr = 0.0d0
13114       do k=1,nsaxs
13115         Pcalc(k)=0.0d0
13116         do j=1,nres
13117           do l=1,3
13118             PgradC(k,l,j)=0.0d0
13119             PgradX(k,l,j)=0.0d0
13120           enddo
13121         enddo
13122       enddo
13123 c      lllicz=0
13124       do i=iatsc_s,iatsc_e
13125        if (itype(i).eq.ntyp1) cycle
13126        do iint=1,nint_gr(i)
13127          do j=istart(i,iint),iend(i,iint)
13128            if (itype(j).eq.ntyp1) cycle
13129 #ifdef ALLSAXS
13130            dijCACA=dist(i,j)
13131            dijCASC=dist(i,j+nres)
13132            dijSCCA=dist(i+nres,j)
13133            dijSCSC=dist(i+nres,j+nres)
13134            sigma2CACA=2.0d0/(pstok**2)
13135            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13136            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13137            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13138            do k=1,nsaxs
13139              dk = distsaxs(k)
13140              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13141              if (itype(j).ne.10) then
13142              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13143              else
13144              endif
13145              expCASC = 0.0d0
13146              if (itype(i).ne.10) then
13147              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13148              else
13149              expSCCA = 0.0d0
13150              endif
13151              if (itype(i).ne.10 .and. itype(j).ne.10) then
13152              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13153              else
13154              expSCSC = 0.0d0
13155              endif
13156              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13157 #ifdef DEBUG
13158              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13159 #endif
13160              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13161              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13162              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13163              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13164              do l=1,3
13165 c CA CA
13166                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13167                PgradC(k,l,i) = PgradC(k,l,i)-aux
13168                PgradC(k,l,j) = PgradC(k,l,j)+aux
13169 c CA SC
13170                if (itype(j).ne.10) then
13171                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13172                PgradC(k,l,i) = PgradC(k,l,i)-aux
13173                PgradC(k,l,j) = PgradC(k,l,j)+aux
13174                PgradX(k,l,j) = PgradX(k,l,j)+aux
13175                endif
13176 c SC CA
13177                if (itype(i).ne.10) then
13178                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13179                PgradX(k,l,i) = PgradX(k,l,i)-aux
13180                PgradC(k,l,i) = PgradC(k,l,i)-aux
13181                PgradC(k,l,j) = PgradC(k,l,j)+aux
13182                endif
13183 c SC SC
13184                if (itype(i).ne.10 .and. itype(j).ne.10) then
13185                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13186                PgradC(k,l,i) = PgradC(k,l,i)-aux
13187                PgradC(k,l,j) = PgradC(k,l,j)+aux
13188                PgradX(k,l,i) = PgradX(k,l,i)-aux
13189                PgradX(k,l,j) = PgradX(k,l,j)+aux
13190                endif
13191              enddo ! l
13192            enddo ! k
13193 #else
13194            dijCACA=dist(i,j)
13195            sigma2CACA=scal_rad**2*0.25d0/
13196      &        (restok(itype(j))**2+restok(itype(i))**2)
13197 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13198 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13199 #ifdef MYGAUSS
13200            sigmaCACA=dsqrt(sigma2CACA)
13201            threesig=3.0d0/sigmaCACA
13202 c           llicz=0
13203            do k=1,nsaxs
13204              dk = distsaxs(k)
13205              if (dabs(dijCACA-dk).ge.threesig) cycle
13206 c             llicz=llicz+1
13207 c             lllicz=lllicz+1
13208              aux = sigmaCACA*(dijCACA-dk)
13209              expCACA = mygauss(aux)
13210 c             if (expcaca.eq.0.0d0) cycle
13211              Pcalc(k) = Pcalc(k)+expCACA
13212              CACAgrad = -sigmaCACA*mygaussder(aux)
13213 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13214              do l=1,3
13215                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13216                PgradC(k,l,i) = PgradC(k,l,i)-aux
13217                PgradC(k,l,j) = PgradC(k,l,j)+aux
13218              enddo ! l
13219            enddo ! k
13220 c           write (iout,*) "i",i," j",j," llicz",llicz
13221 #else
13222            IF (saxs_cutoff.eq.0) THEN
13223            do k=1,nsaxs
13224              dk = distsaxs(k)
13225              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13226              Pcalc(k) = Pcalc(k)+expCACA
13227              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13228              do l=1,3
13229                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13230                PgradC(k,l,i) = PgradC(k,l,i)-aux
13231                PgradC(k,l,j) = PgradC(k,l,j)+aux
13232              enddo ! l
13233            enddo ! k
13234            ELSE
13235            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13236            do k=1,nsaxs
13237              dk = distsaxs(k)
13238 c             write (2,*) "ijk",i,j,k
13239              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13240              if (sss2.eq.0.0d0) cycle
13241              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13242              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13243      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13244      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13245      &           sss2,ssgrad2
13246              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13247              Pcalc(k) = Pcalc(k)+expCACA
13248 #ifdef DEBUG
13249              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13250 #endif
13251              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13252      &             ssgrad2*expCACA/sss2
13253              do l=1,3
13254 c CA CA
13255                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13256                PgradC(k,l,i) = PgradC(k,l,i)+aux
13257                PgradC(k,l,j) = PgradC(k,l,j)-aux
13258              enddo ! l
13259            enddo ! k
13260            ENDIF
13261 #endif
13262 #endif
13263          enddo ! j
13264        enddo ! iint
13265       enddo ! i
13266 c#ifdef TIMING
13267 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13268 c#endif
13269 c      write (iout,*) "lllicz",lllicz
13270 c#ifdef TIMING
13271 c      time01=MPI_Wtime()
13272 c#endif
13273 #ifdef MPI
13274       if (nfgtasks.gt.1) then
13275        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13276      &    MPI_SUM,FG_COMM,IERR)
13277 c        if (fg_rank.eq.king) then
13278           do k=1,nsaxs
13279             Pcalc(k) = Pcalc_(k)
13280           enddo
13281 c        endif
13282 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13283 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13284 c        if (fg_rank.eq.king) then
13285 c          do i=1,nres
13286 c            do l=1,3
13287 c              do k=1,nsaxs
13288 c                PgradC(k,l,i) = PgradC_(k,l,i)
13289 c              enddo
13290 c            enddo
13291 c          enddo
13292 c        endif
13293 #ifdef ALLSAXS
13294 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13295 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13296 c        if (fg_rank.eq.king) then
13297 c          do i=1,nres
13298 c            do l=1,3
13299 c              do k=1,nsaxs
13300 c                PgradX(k,l,i) = PgradX_(k,l,i)
13301 c              enddo
13302 c            enddo
13303 c          enddo
13304 c        endif
13305 #endif
13306       endif
13307 #endif
13308       Cnorm = 0.0d0
13309       do k=1,nsaxs
13310         Cnorm = Cnorm + Pcalc(k)
13311       enddo
13312 #ifdef MPI
13313       if (fg_rank.eq.king) then
13314 #endif
13315       Esaxs_constr = dlog(Cnorm)-wsaxs0
13316       do k=1,nsaxs
13317         if (Pcalc(k).gt.0.0d0)
13318      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13319 #ifdef DEBUG
13320         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13321 #endif
13322       enddo
13323 #ifdef DEBUG
13324       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13325 #endif
13326 #ifdef MPI
13327       endif
13328 #endif
13329       gsaxsC=0.0d0
13330       gsaxsX=0.0d0
13331       do i=nnt,nct
13332         do l=1,3
13333           auxC=0.0d0
13334           auxC1=0.0d0
13335           auxX=0.0d0
13336           auxX1=0.d0
13337           do k=1,nsaxs
13338             if (Pcalc(k).gt.0)
13339      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13340             auxC1 = auxC1+PgradC(k,l,i)
13341 #ifdef ALLSAXS
13342             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13343             auxX1 = auxX1+PgradX(k,l,i)
13344 #endif
13345           enddo
13346           gsaxsC(l,i) = auxC - auxC1/Cnorm
13347 #ifdef ALLSAXS
13348           gsaxsX(l,i) = auxX - auxX1/Cnorm
13349 #endif
13350 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13351 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13352 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13353 c     *     " gradX",wsaxs*gsaxsX(l,i)
13354         enddo
13355       enddo
13356 #ifdef TIMING
13357       time_SAXS=time_SAXS+MPI_Wtime()-time01
13358 #endif
13359 #ifdef DEBUG
13360       write (iout,*) "gsaxsc"
13361       do i=nnt,nct
13362         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13363       enddo
13364 #endif
13365 #ifdef MPI
13366 c      endif
13367 #endif
13368       return
13369       end
13370 c----------------------------------------------------------------------------
13371       subroutine e_saxsC(Esaxs_constr)
13372       implicit none
13373       include 'DIMENSIONS'
13374 #ifdef MPI
13375       include "mpif.h"
13376       include "COMMON.SETUP"
13377       integer IERR
13378 #endif
13379       include 'COMMON.SBRIDGE'
13380       include 'COMMON.CHAIN'
13381       include 'COMMON.GEO'
13382       include 'COMMON.DERIV'
13383       include 'COMMON.LOCAL'
13384       include 'COMMON.INTERACT'
13385       include 'COMMON.VAR'
13386       include 'COMMON.IOUNITS'
13387 c      include 'COMMON.MD'
13388 #ifdef LANG0
13389 #ifdef FIVEDIAG
13390       include 'COMMON.LANGEVIN.lang0.5diag'
13391 #else
13392       include 'COMMON.LANGEVIN.lang0'
13393 #endif
13394 #else
13395       include 'COMMON.LANGEVIN'
13396 #endif
13397       include 'COMMON.CONTROL'
13398       include 'COMMON.SAXS'
13399       include 'COMMON.NAMES'
13400       include 'COMMON.TIME1'
13401       include 'COMMON.FFIELD'
13402 c
13403       double precision Esaxs_constr
13404       integer i,iint,j,k,l
13405       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13406 #ifdef MPI
13407       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13408 #endif
13409       double precision dk,dijCASPH,dijSCSPH,
13410      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13411      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13412      & auxX,auxX1,Cnorm
13413 c  SAXS restraint penalty function
13414 #ifdef DEBUG
13415       write(iout,*) "------- SAXS penalty function start -------"
13416       write (iout,*) "nsaxs",nsaxs
13417
13418       do i=nnt,nct
13419         print *,MyRank,"C",i,(C(j,i),j=1,3)
13420       enddo
13421       do i=nnt,nct
13422         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13423       enddo
13424 #endif
13425       Esaxs_constr = 0.0d0
13426       logPtot=0.0d0
13427       do j=isaxs_start,isaxs_end
13428         Pcalc=0.0d0
13429         do i=1,nres
13430           do l=1,3
13431             PgradC(l,i)=0.0d0
13432             PgradX(l,i)=0.0d0
13433           enddo
13434         enddo
13435         do i=nnt,nct
13436           if (itype(i).eq.ntyp1) cycle
13437           dijCASPH=0.0d0
13438           dijSCSPH=0.0d0
13439           do l=1,3
13440             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13441           enddo
13442           if (itype(i).ne.10) then
13443           do l=1,3
13444             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13445           enddo
13446           endif
13447           sigma2CA=2.0d0/pstok**2
13448           sigma2SC=4.0d0/restok(itype(i))**2
13449           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13450           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13451           Pcalc = Pcalc+expCASPH+expSCSPH
13452 #ifdef DEBUG
13453           write(*,*) "processor i j Pcalc",
13454      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13455 #endif
13456           CASPHgrad = sigma2CA*expCASPH
13457           SCSPHgrad = sigma2SC*expSCSPH
13458           do l=1,3
13459             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13460             PgradX(l,i) = PgradX(l,i) + aux
13461             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13462           enddo ! l
13463         enddo ! i
13464         do i=nnt,nct
13465           do l=1,3
13466             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13467             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13468           enddo
13469         enddo
13470         logPtot = logPtot - dlog(Pcalc)
13471 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13472 c     &    " logPtot",logPtot
13473       enddo ! j
13474 #ifdef MPI
13475       if (nfgtasks.gt.1) then
13476 c        write (iout,*) "logPtot before reduction",logPtot
13477         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13478      &    MPI_SUM,king,FG_COMM,IERR)
13479         logPtot = logPtot_
13480 c        write (iout,*) "logPtot after reduction",logPtot
13481         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13482      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13483         if (fg_rank.eq.king) then
13484           do i=1,nres
13485             do l=1,3
13486               gsaxsC(l,i) = gsaxsC_(l,i)
13487             enddo
13488           enddo
13489         endif
13490         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13491      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13492         if (fg_rank.eq.king) then
13493           do i=1,nres
13494             do l=1,3
13495               gsaxsX(l,i) = gsaxsX_(l,i)
13496             enddo
13497           enddo
13498         endif
13499       endif
13500 #endif
13501       Esaxs_constr = logPtot
13502       return
13503       end
13504 c----------------------------------------------------------------------------
13505       double precision function sscale2(r,r_cut,r0,rlamb)
13506       implicit none
13507       double precision r,gamm,r_cut,r0,rlamb,rr
13508       rr = dabs(r-r0)
13509 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13510 c      write (2,*) "rr",rr
13511       if(rr.lt.r_cut-rlamb) then
13512         sscale2=1.0d0
13513       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13514         gamm=(rr-(r_cut-rlamb))/rlamb
13515         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13516       else
13517         sscale2=0d0
13518       endif
13519       return
13520       end
13521 C-----------------------------------------------------------------------
13522       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13523       implicit none
13524       double precision r,gamm,r_cut,r0,rlamb,rr
13525       rr = dabs(r-r0)
13526       if(rr.lt.r_cut-rlamb) then
13527         sscalgrad2=0.0d0
13528       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13529         gamm=(rr-(r_cut-rlamb))/rlamb
13530         if (r.ge.r0) then
13531           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13532         else
13533           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13534         endif
13535       else
13536         sscalgrad2=0.0d0
13537       endif
13538       return
13539       end