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

   1       subroutine etotal(energia)
   2       implicit none
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  34      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  35      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  36      & eliptran,Eafmforce,Etube,
  37      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  38       integer n_corr,n_corr1
  39 #ifdef MPI
  40 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  41 c     & " nfgtasks",nfgtasks
  42       if (nfgtasks.gt.1) then
  43         time00=MPI_Wtime()
  44 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  45         if (fg_rank.eq.0) then
  46           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  47 c          print *,"Processor",myrank," BROADCAST iorder"
  48 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  49 C FG slaves as WEIGHTS array.
  50           weights_(1)=wsc
  51           weights_(2)=wscp
  52           weights_(3)=welec
  53           weights_(4)=wcorr
  54           weights_(5)=wcorr5
  55           weights_(6)=wcorr6
  56           weights_(7)=wel_loc
  57           weights_(8)=wturn3
  58           weights_(9)=wturn4
  59           weights_(10)=wturn6
  60           weights_(11)=wang
  61           weights_(12)=wscloc
  62           weights_(13)=wtor
  63           weights_(14)=wtor_d
  64           weights_(15)=wstrain
  65           weights_(16)=wvdwpp
  66           weights_(17)=wbond
  67           weights_(18)=scal14
  68           weights_(21)=wsccor
  69           weights_(22)=wtube
  70           weights_(26)=wsaxs
  71           weights_(28)=wdfa_dist
  72           weights_(29)=wdfa_tor
  73           weights_(30)=wdfa_nei
  74           weights_(31)=wdfa_beta
  75 C FG Master broadcasts the WEIGHTS_ array
  76           call MPI_Bcast(weights_(1),n_ene,
  77      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  78         else
  79 C FG slaves receive the WEIGHTS array
  80           call MPI_Bcast(weights(1),n_ene,
  81      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  82           wsc=weights(1)
  83           wscp=weights(2)
  84           welec=weights(3)
  85           wcorr=weights(4)
  86           wcorr5=weights(5)
  87           wcorr6=weights(6)
  88           wel_loc=weights(7)
  89           wturn3=weights(8)
  90           wturn4=weights(9)
  91           wturn6=weights(10)
  92           wang=weights(11)
  93           wscloc=weights(12)
  94           wtor=weights(13)
  95           wtor_d=weights(14)
  96           wstrain=weights(15)
  97           wvdwpp=weights(16)
  98           wbond=weights(17)
  99           scal14=weights(18)
 100           wsccor=weights(21)
 101           wtube=weights(22)
 102           wsaxs=weights(26)
 103           wdfa_dist=weights_(28)
 104           wdfa_tor=weights_(29)
 105           wdfa_nei=weights_(30)
 106           wdfa_beta=weights_(31)
 107         endif
 108         time_Bcast=time_Bcast+MPI_Wtime()-time00
 109         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 110 c        call chainbuild_cart
 111       endif
 112 #ifndef DFA
 113       edfadis=0.0d0
 114       edfator=0.0d0
 115       edfanei=0.0d0
 116       edfabet=0.0d0
 117 #endif
 118 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 119 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 120 #else
 121 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 122 c        call int_from_cart1(.false.)
 123 c      endif
 124 #endif
 125 #ifdef TIMING
 126       time00=MPI_Wtime()
 127 #endif
 128 C
 129 C Compute the side-chain and electrostatic interaction energy
 130 C
 131 C      print *,ipot
 132       goto (101,102,103,104,105,106) ipot
 133 C Lennard-Jones potential.
 134   101 call elj(evdw)
 135 cd    print '(a)','Exit ELJ'
 136       goto 107
 137 C Lennard-Jones-Kihara potential (shifted).
 138   102 call eljk(evdw)
 139       goto 107
 140 C Berne-Pechukas potential (dilated LJ, angular dependence).
 141   103 call ebp(evdw)
 142       goto 107
 143 C Gay-Berne potential (shifted LJ, angular dependence).
 144   104 call egb(evdw)
 145 C      print *,"bylem w egb"
 146       goto 107
 147 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 148   105 call egbv(evdw)
 149       goto 107
 150 C Soft-sphere potential
 151   106 call e_softsphere(evdw)
 152 C
 153 C Calculate electrostatic (H-bonding) energy of the main chain.
 154 C
 155   107 continue
 156 #ifdef DFA
 157 C     BARTEK for dfa test!
 158       if (wdfa_dist.gt.0) then
 159         call edfad(edfadis)
 160       else
 161         edfadis=0
 162       endif
 163 c      print*, 'edfad is finished!', edfadis
 164       if (wdfa_tor.gt.0) then
 165         call edfat(edfator)
 166       else
 167         edfator=0
 168       endif
 169 c      print*, 'edfat is finished!', edfator
 170       if (wdfa_nei.gt.0) then
 171         call edfan(edfanei)
 172       else
 173         edfanei=0
 174       endif
 175 c      print*, 'edfan is finished!', edfanei
 176       if (wdfa_beta.gt.0) then
 177         call edfab(edfabet)
 178       else
 179         edfabet=0
 180       endif
 181 #endif
 182 cmc
 183 cmc Sep-06: egb takes care of dynamic ss bonds too
 184 cmc
 185 c      if (dyn_ss) call dyn_set_nss
 186
 187 c      print *,"Processor",myrank," computed USCSC"
 188 #ifdef TIMING
 189       time01=MPI_Wtime()
 190 #endif
 191       call vec_and_deriv
 192 #ifdef TIMING
 193       time_vec=time_vec+MPI_Wtime()-time01
 194 #endif
 195 C Introduction of shielding effect first for each peptide group
 196 C the shielding factor is set this factor is describing how each
 197 C peptide group is shielded by side-chains
 198 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 199 C      write (iout,*) "shield_mode",shield_mode
 200       if (shield_mode.eq.1) then
 201        call set_shield_fac
 202       else if  (shield_mode.eq.2) then
 203        call set_shield_fac2
 204       endif
 205 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 206       if (ipot.lt.6) then
 207 #ifdef SPLITELE
 208          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 209      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 210      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 211      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 212 #else
 213          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 214      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 215      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 216      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 217 #endif
 218             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 219          else
 220             ees=0.0d0
 221             evdw1=0.0d0
 222             eel_loc=0.0d0
 223             eello_turn3=0.0d0
 224             eello_turn4=0.0d0
 225          endif
 226       else
 227         write (iout,*) "Soft-spheer ELEC potential"
 228 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 229 c     &   eello_turn4)
 230       endif
 231 c#ifdef TIMING
 232 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 233 c#endif
 234 c      print *,"Processor",myrank," computed UELEC"
 235 C
 236 C Calculate excluded-volume interaction energy between peptide groups
 237 C and side chains.
 238 C
 239       if (ipot.lt.6) then
 240        if(wscp.gt.0d0) then
 241         call escp(evdw2,evdw2_14)
 242        else
 243         evdw2=0
 244         evdw2_14=0
 245        endif
 246       else
 247 c        write (iout,*) "Soft-sphere SCP potential"
 248         call escp_soft_sphere(evdw2,evdw2_14)
 249       endif
 250 c
 251 c Calculate the bond-stretching energy
 252 c
 253       call ebond(estr)
 254 C
 255 C Calculate the disulfide-bridge and other energy and the contributions
 256 C from other distance constraints.
 257 cd      write (iout,*) 'Calling EHPB'
 258       call edis(ehpb)
 259 cd    print *,'EHPB exitted succesfully.'
 260 C
 261 C Calculate the virtual-bond-angle energy.
 262 C
 263       if (wang.gt.0d0) then
 264        if (tor_mode.eq.0) then
 265          call ebend(ebe)
 266        else
 267 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 268 C energy function
 269          call ebend_kcc(ebe)
 270        endif
 271       else
 272         ebe=0.0d0
 273       endif
 274       ethetacnstr=0.0d0
 275       if (with_theta_constr) call etheta_constr(ethetacnstr)
 276 c      print *,"Processor",myrank," computed UB"
 277 C
 278 C Calculate the SC local energy.
 279 C
 280 C      print *,"TU DOCHODZE?"
 281       call esc(escloc)
 282 c      print *,"Processor",myrank," computed USC"
 283 C
 284 C Calculate the virtual-bond torsional energy.
 285 C
 286 cd    print *,'nterm=',nterm
 287 C      print *,"tor",tor_mode
 288       if (wtor.gt.0.0d0) then
 289          if (tor_mode.eq.0) then
 290            call etor(etors)
 291          else
 292 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 293 C energy function
 294            call etor_kcc(etors)
 295          endif
 296       else
 297         etors=0.0d0
 298       endif
 299       edihcnstr=0.0d0
 300       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 301 c      print *,"Processor",myrank," computed Utor"
 302       if (constr_homology.ge.1) then
 303         call e_modeller(ehomology_constr)
 304 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 305 c     &  'Processor',fg_rank,' CG group',kolor,
 306 c     &  ' absolute rank',MyRank
 307       else
 308         ehomology_constr=0.0d0
 309       endif
 310 C
 311 C 6/23/01 Calculate double-torsional energy
 312 C
 313       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 314         call etor_d(etors_d)
 315       else
 316         etors_d=0
 317       endif
 318 c      print *,"Processor",myrank," computed Utord"
 319 C
 320 C 21/5/07 Calculate local sicdechain correlation energy
 321 C
 322       if (wsccor.gt.0.0d0) then
 323         call eback_sc_corr(esccor)
 324       else
 325         esccor=0.0d0
 326       endif
 327 #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)/sigma(itypi,itypj))
2111             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
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/sigma(itypi,itypj)*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))
2738             sssgrad=sscagrad(sqrt(rij))
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))
4048             sssgrad=sscagrad(sqrt(rij))
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,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)))
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)))
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 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7228 c     & ,zz,xx,yy
7229 c#define DEBUG
7230 #ifdef DEBUG
7231 C
7232 C This section to check the numerical derivatives of the energy of ith side
7233 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7234 C #define DEBUG in the code to turn it on.
7235 C
7236         write (2,*) "sumene               =",sumene
7237         aincr=1.0d-7
7238         xxsave=xx
7239         xx=xx+aincr
7240         write (2,*) xx,yy,zz
7241         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7242         de_dxx_num=(sumenep-sumene)/aincr
7243         xx=xxsave
7244         write (2,*) "xx+ sumene from enesc=",sumenep
7245         yysave=yy
7246         yy=yy+aincr
7247         write (2,*) xx,yy,zz
7248         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7249         de_dyy_num=(sumenep-sumene)/aincr
7250         yy=yysave
7251         write (2,*) "yy+ sumene from enesc=",sumenep
7252         zzsave=zz
7253         zz=zz+aincr
7254         write (2,*) xx,yy,zz
7255         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7256         de_dzz_num=(sumenep-sumene)/aincr
7257         zz=zzsave
7258         write (2,*) "zz+ sumene from enesc=",sumenep
7259         costsave=cost2tab(i+1)
7260         sintsave=sint2tab(i+1)
7261         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7262         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7263         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7264         de_dt_num=(sumenep-sumene)/aincr
7265         write (2,*) " t+ sumene from enesc=",sumenep
7266         cost2tab(i+1)=costsave
7267         sint2tab(i+1)=sintsave
7268 C End of diagnostics section.
7269 #endif
7270 C
7271 C Compute the gradient of esc
7272 C
7273 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7274         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7275         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7276         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7277         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7278         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7279         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7280         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7281         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7282         pom1=(sumene3*sint2tab(i+1)+sumene1)
7283      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7284         pom2=(sumene4*cost2tab(i+1)+sumene2)
7285      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7286         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7287         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7288      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7289      &  +x(40)*yy*zz
7290         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7291         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7292      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7293      &  +x(60)*yy*zz
7294         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7295      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7296      &        +(pom1+pom2)*pom_dx
7297 #ifdef DEBUG
7298         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7299 #endif
7300 C
7301         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7302         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7303      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7304      &  +x(40)*xx*zz
7305         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7306         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7307      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7308      &  +x(59)*zz**2 +x(60)*xx*zz
7309         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7310      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7311      &        +(pom1-pom2)*pom_dy
7312 #ifdef DEBUG
7313         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7314 #endif
7315 C
7316         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7317      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7318      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7319      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7320      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7321      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7322      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7323      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7324 #ifdef DEBUG
7325         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7326 #endif
7327 C
7328         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7329      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7330      &  +pom1*pom_dt1+pom2*pom_dt2
7331 #ifdef DEBUG
7332         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7333 #endif
7334 c#undef DEBUG
7335 c
7336 C
7337        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7338        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7339        cosfac2xx=cosfac2*xx
7340        sinfac2yy=sinfac2*yy
7341        do k = 1,3
7342          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7343      &      vbld_inv(i+1)
7344          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7345      &      vbld_inv(i)
7346          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7347          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7348 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7349 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7350 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7351 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7352          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7353          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7354          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7355          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7356          dZZ_Ci1(k)=0.0d0
7357          dZZ_Ci(k)=0.0d0
7358          do j=1,3
7359            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7360      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7361            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7362      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7363          enddo
7364
7365          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7366          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7367          dZZ_XYZ(k)=vbld_inv(i+nres)*
7368      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7369 c
7370          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7371          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7372        enddo
7373
7374        do k=1,3
7375          dXX_Ctab(k,i)=dXX_Ci(k)
7376          dXX_C1tab(k,i)=dXX_Ci1(k)
7377          dYY_Ctab(k,i)=dYY_Ci(k)
7378          dYY_C1tab(k,i)=dYY_Ci1(k)
7379          dZZ_Ctab(k,i)=dZZ_Ci(k)
7380          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7381          dXX_XYZtab(k,i)=dXX_XYZ(k)
7382          dYY_XYZtab(k,i)=dYY_XYZ(k)
7383          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7384        enddo
7385
7386        do k = 1,3
7387 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7388 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7389 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7390 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7391 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7392 c     &    dt_dci(k)
7393 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7394 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7395          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7396      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7397          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7398      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7399          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7400      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7401        enddo
7402 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7403 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7404
7405 C to check gradient call subroutine check_grad
7406
7407     1 continue
7408       enddo
7409       return
7410       end
7411 c------------------------------------------------------------------------------
7412       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7413       implicit none
7414       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7415      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7416       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7417      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7418      &   + x(10)*yy*zz
7419       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7420      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7421      & + x(20)*yy*zz
7422       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7423      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7424      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7425      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7426      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7427      &  +x(40)*xx*yy*zz
7428       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7429      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7430      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7431      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7432      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7433      &  +x(60)*xx*yy*zz
7434       dsc_i   = 0.743d0+x(61)
7435       dp2_i   = 1.9d0+x(62)
7436       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7437      &          *(xx*cost2+yy*sint2))
7438       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7439      &          *(xx*cost2-yy*sint2))
7440       s1=(1+x(63))/(0.1d0 + dscp1)
7441       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7442       s2=(1+x(65))/(0.1d0 + dscp2)
7443       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7444       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7445      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7446       enesc=sumene
7447       return
7448       end
7449 #endif
7450 c------------------------------------------------------------------------------
7451       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7452 C
7453 C This procedure calculates two-body contact function g(rij) and its derivative:
7454 C
7455 C           eps0ij                                     !       x < -1
7456 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7457 C            0                                         !       x > 1
7458 C
7459 C where x=(rij-r0ij)/delta
7460 C
7461 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7462 C
7463       implicit none
7464       double precision rij,r0ij,eps0ij,fcont,fprimcont
7465       double precision x,x2,x4,delta
7466 c     delta=0.02D0*r0ij
7467 c      delta=0.2D0*r0ij
7468       x=(rij-r0ij)/delta
7469       if (x.lt.-1.0D0) then
7470         fcont=eps0ij
7471         fprimcont=0.0D0
7472       else if (x.le.1.0D0) then
7473         x2=x*x
7474         x4=x2*x2
7475         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7476         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7477       else
7478         fcont=0.0D0
7479         fprimcont=0.0D0
7480       endif
7481       return
7482       end
7483 c------------------------------------------------------------------------------
7484       subroutine splinthet(theti,delta,ss,ssder)
7485       implicit real*8 (a-h,o-z)
7486       include 'DIMENSIONS'
7487       include 'COMMON.VAR'
7488       include 'COMMON.GEO'
7489       thetup=pi-delta
7490       thetlow=delta
7491       if (theti.gt.pipol) then
7492         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7493       else
7494         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7495         ssder=-ssder
7496       endif
7497       return
7498       end
7499 c------------------------------------------------------------------------------
7500       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7501       implicit none
7502       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7503       double precision ksi,ksi2,ksi3,a1,a2,a3
7504       a1=fprim0*delta/(f1-f0)
7505       a2=3.0d0-2.0d0*a1
7506       a3=a1-2.0d0
7507       ksi=(x-x0)/delta
7508       ksi2=ksi*ksi
7509       ksi3=ksi2*ksi
7510       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7511       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7512       return
7513       end
7514 c------------------------------------------------------------------------------
7515       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7516       implicit none
7517       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7518       double precision ksi,ksi2,ksi3,a1,a2,a3
7519       ksi=(x-x0)/delta
7520       ksi2=ksi*ksi
7521       ksi3=ksi2*ksi
7522       a1=fprim0x*delta
7523       a2=3*(f1x-f0x)-2*fprim0x*delta
7524       a3=fprim0x*delta-2*(f1x-f0x)
7525       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7526       return
7527       end
7528 C-----------------------------------------------------------------------------
7529 #ifdef CRYST_TOR
7530 C-----------------------------------------------------------------------------
7531       subroutine etor(etors)
7532       implicit real*8 (a-h,o-z)
7533       include 'DIMENSIONS'
7534       include 'COMMON.VAR'
7535       include 'COMMON.GEO'
7536       include 'COMMON.LOCAL'
7537       include 'COMMON.TORSION'
7538       include 'COMMON.INTERACT'
7539       include 'COMMON.DERIV'
7540       include 'COMMON.CHAIN'
7541       include 'COMMON.NAMES'
7542       include 'COMMON.IOUNITS'
7543       include 'COMMON.FFIELD'
7544       include 'COMMON.TORCNSTR'
7545       include 'COMMON.CONTROL'
7546       logical lprn
7547 C Set lprn=.true. for debugging
7548       lprn=.false.
7549 c      lprn=.true.
7550       etors=0.0D0
7551       do i=iphi_start,iphi_end
7552       etors_ii=0.0D0
7553         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7554      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7555         itori=itortyp(itype(i-2))
7556         itori1=itortyp(itype(i-1))
7557         phii=phi(i)
7558         gloci=0.0D0
7559 C Proline-Proline pair is a special case...
7560         if (itori.eq.3 .and. itori1.eq.3) then
7561           if (phii.gt.-dwapi3) then
7562             cosphi=dcos(3*phii)
7563             fac=1.0D0/(1.0D0-cosphi)
7564             etorsi=v1(1,3,3)*fac
7565             etorsi=etorsi+etorsi
7566             etors=etors+etorsi-v1(1,3,3)
7567             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7568             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7569           endif
7570           do j=1,3
7571             v1ij=v1(j+1,itori,itori1)
7572             v2ij=v2(j+1,itori,itori1)
7573             cosphi=dcos(j*phii)
7574             sinphi=dsin(j*phii)
7575             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7576             if (energy_dec) etors_ii=etors_ii+
7577      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7578             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7579           enddo
7580         else
7581           do j=1,nterm_old
7582             v1ij=v1(j,itori,itori1)
7583             v2ij=v2(j,itori,itori1)
7584             cosphi=dcos(j*phii)
7585             sinphi=dsin(j*phii)
7586             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7587             if (energy_dec) etors_ii=etors_ii+
7588      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7589             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7590           enddo
7591         endif
7592         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7593              'etor',i,etors_ii
7594         if (lprn)
7595      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7596      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7597      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7598         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7599 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7600       enddo
7601       return
7602       end
7603 c------------------------------------------------------------------------------
7604       subroutine etor_d(etors_d)
7605       etors_d=0.0d0
7606       return
7607       end
7608 c----------------------------------------------------------------------------
7609 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7610       subroutine e_modeller(ehomology_constr)
7611       ehomology_constr=0.0d0
7612       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7613       return
7614       end
7615 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7616
7617 c------------------------------------------------------------------------------
7618       subroutine etor_d(etors_d)
7619       etors_d=0.0d0
7620       return
7621       end
7622 c----------------------------------------------------------------------------
7623 #else
7624       subroutine etor(etors)
7625       implicit real*8 (a-h,o-z)
7626       include 'DIMENSIONS'
7627       include 'COMMON.VAR'
7628       include 'COMMON.GEO'
7629       include 'COMMON.LOCAL'
7630       include 'COMMON.TORSION'
7631       include 'COMMON.INTERACT'
7632       include 'COMMON.DERIV'
7633       include 'COMMON.CHAIN'
7634       include 'COMMON.NAMES'
7635       include 'COMMON.IOUNITS'
7636       include 'COMMON.FFIELD'
7637       include 'COMMON.TORCNSTR'
7638       include 'COMMON.CONTROL'
7639       logical lprn
7640 C Set lprn=.true. for debugging
7641       lprn=.false.
7642 c     lprn=.true.
7643       etors=0.0D0
7644       do i=iphi_start,iphi_end
7645 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7646 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7647 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7648 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7649         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7650      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7651 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7652 C For introducing the NH3+ and COO- group please check the etor_d for reference
7653 C and guidance
7654         etors_ii=0.0D0
7655          if (iabs(itype(i)).eq.20) then
7656          iblock=2
7657          else
7658          iblock=1
7659          endif
7660         itori=itortyp(itype(i-2))
7661         itori1=itortyp(itype(i-1))
7662         phii=phi(i)
7663         gloci=0.0D0
7664 C Regular cosine and sine terms
7665         do j=1,nterm(itori,itori1,iblock)
7666           v1ij=v1(j,itori,itori1,iblock)
7667           v2ij=v2(j,itori,itori1,iblock)
7668           cosphi=dcos(j*phii)
7669           sinphi=dsin(j*phii)
7670           etors=etors+v1ij*cosphi+v2ij*sinphi
7671           if (energy_dec) etors_ii=etors_ii+
7672      &                v1ij*cosphi+v2ij*sinphi
7673           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7674         enddo
7675 C Lorentz terms
7676 C                         v1
7677 C  E = SUM ----------------------------------- - v1
7678 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7679 C
7680         cosphi=dcos(0.5d0*phii)
7681         sinphi=dsin(0.5d0*phii)
7682         do j=1,nlor(itori,itori1,iblock)
7683           vl1ij=vlor1(j,itori,itori1)
7684           vl2ij=vlor2(j,itori,itori1)
7685           vl3ij=vlor3(j,itori,itori1)
7686           pom=vl2ij*cosphi+vl3ij*sinphi
7687           pom1=1.0d0/(pom*pom+1.0d0)
7688           etors=etors+vl1ij*pom1
7689           if (energy_dec) etors_ii=etors_ii+
7690      &                vl1ij*pom1
7691           pom=-pom*pom1*pom1
7692           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7693         enddo
7694 C Subtract the constant term
7695         etors=etors-v0(itori,itori1,iblock)
7696           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7697      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7698         if (lprn)
7699      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7700      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7701      &  (v1(j,itori,itori1,iblock),j=1,6),
7702      &  (v2(j,itori,itori1,iblock),j=1,6)
7703         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7704 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7705       enddo
7706       return
7707       end
7708 c----------------------------------------------------------------------------
7709       subroutine etor_d(etors_d)
7710 C 6/23/01 Compute double torsional energy
7711       implicit real*8 (a-h,o-z)
7712       include 'DIMENSIONS'
7713       include 'COMMON.VAR'
7714       include 'COMMON.GEO'
7715       include 'COMMON.LOCAL'
7716       include 'COMMON.TORSION'
7717       include 'COMMON.INTERACT'
7718       include 'COMMON.DERIV'
7719       include 'COMMON.CHAIN'
7720       include 'COMMON.NAMES'
7721       include 'COMMON.IOUNITS'
7722       include 'COMMON.FFIELD'
7723       include 'COMMON.TORCNSTR'
7724       logical lprn
7725 C Set lprn=.true. for debugging
7726       lprn=.false.
7727 c     lprn=.true.
7728       etors_d=0.0D0
7729 c      write(iout,*) "a tu??"
7730       do i=iphid_start,iphid_end
7731 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7732 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7733 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7734 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7735 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7736          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7737      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7738      &  (itype(i+1).eq.ntyp1)) cycle
7739 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7740         itori=itortyp(itype(i-2))
7741         itori1=itortyp(itype(i-1))
7742         itori2=itortyp(itype(i))
7743         phii=phi(i)
7744         phii1=phi(i+1)
7745         gloci1=0.0D0
7746         gloci2=0.0D0
7747         iblock=1
7748         if (iabs(itype(i+1)).eq.20) iblock=2
7749 C Iblock=2 Proline type
7750 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7751 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7752 C        if (itype(i+1).eq.ntyp1) iblock=3
7753 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7754 C IS or IS NOT need for this
7755 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7756 C        is (itype(i-3).eq.ntyp1) ntblock=2
7757 C        ntblock is N-terminal blocking group
7758
7759 C Regular cosine and sine terms
7760         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7761 C Example of changes for NH3+ blocking group
7762 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7763 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7764           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7765           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7766           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7767           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7768           cosphi1=dcos(j*phii)
7769           sinphi1=dsin(j*phii)
7770           cosphi2=dcos(j*phii1)
7771           sinphi2=dsin(j*phii1)
7772           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7773      &     v2cij*cosphi2+v2sij*sinphi2
7774           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7775           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7776         enddo
7777         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7778           do l=1,k-1
7779             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7780             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7781             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7782             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7783             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7784             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7785             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7786             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7787             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7788      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7789             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7790      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7791             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7792      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7793           enddo
7794         enddo
7795         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7796         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7797       enddo
7798       return
7799       end
7800 #endif
7801 C----------------------------------------------------------------------------------
7802 C The rigorous attempt to derive energy function
7803       subroutine etor_kcc(etors)
7804       implicit real*8 (a-h,o-z)
7805       include 'DIMENSIONS'
7806       include 'COMMON.VAR'
7807       include 'COMMON.GEO'
7808       include 'COMMON.LOCAL'
7809       include 'COMMON.TORSION'
7810       include 'COMMON.INTERACT'
7811       include 'COMMON.DERIV'
7812       include 'COMMON.CHAIN'
7813       include 'COMMON.NAMES'
7814       include 'COMMON.IOUNITS'
7815       include 'COMMON.FFIELD'
7816       include 'COMMON.TORCNSTR'
7817       include 'COMMON.CONTROL'
7818       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7819       logical lprn
7820 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7821 C Set lprn=.true. for debugging
7822       lprn=energy_dec
7823 c     lprn=.true.
7824 C      print *,"wchodze kcc"
7825       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7826       etors=0.0D0
7827       do i=iphi_start,iphi_end
7828 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7829 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7830 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7831 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7832         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7833      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7834         itori=itortyp(itype(i-2))
7835         itori1=itortyp(itype(i-1))
7836         phii=phi(i)
7837         glocig=0.0D0
7838         glocit1=0.0d0
7839         glocit2=0.0d0
7840 C to avoid multiple devision by 2
7841 c        theti22=0.5d0*theta(i)
7842 C theta 12 is the theta_1 /2
7843 C theta 22 is theta_2 /2
7844 c        theti12=0.5d0*theta(i-1)
7845 C and appropriate sinus function
7846         sinthet1=dsin(theta(i-1))
7847         sinthet2=dsin(theta(i))
7848         costhet1=dcos(theta(i-1))
7849         costhet2=dcos(theta(i))
7850 C to speed up lets store its mutliplication
7851         sint1t2=sinthet2*sinthet1
7852         sint1t2n=1.0d0
7853 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7854 C +d_n*sin(n*gamma)) *
7855 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7856 C we have two sum 1) Non-Chebyshev which is with n and gamma
7857         nval=nterm_kcc_Tb(itori,itori1)
7858         c1(0)=0.0d0
7859         c2(0)=0.0d0
7860         c1(1)=1.0d0
7861         c2(1)=1.0d0
7862         do j=2,nval
7863           c1(j)=c1(j-1)*costhet1
7864           c2(j)=c2(j-1)*costhet2
7865         enddo
7866         etori=0.0d0
7867         do j=1,nterm_kcc(itori,itori1)
7868           cosphi=dcos(j*phii)
7869           sinphi=dsin(j*phii)
7870           sint1t2n1=sint1t2n
7871           sint1t2n=sint1t2n*sint1t2
7872           sumvalc=0.0d0
7873           gradvalct1=0.0d0
7874           gradvalct2=0.0d0
7875           do k=1,nval
7876             do l=1,nval
7877               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7878               gradvalct1=gradvalct1+
7879      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7880               gradvalct2=gradvalct2+
7881      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7882             enddo
7883           enddo
7884           gradvalct1=-gradvalct1*sinthet1
7885           gradvalct2=-gradvalct2*sinthet2
7886           sumvals=0.0d0
7887           gradvalst1=0.0d0
7888           gradvalst2=0.0d0
7889           do k=1,nval
7890             do l=1,nval
7891               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7892               gradvalst1=gradvalst1+
7893      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7894               gradvalst2=gradvalst2+
7895      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7896             enddo
7897           enddo
7898           gradvalst1=-gradvalst1*sinthet1
7899           gradvalst2=-gradvalst2*sinthet2
7900           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7901           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7902 C glocig is the gradient local i site in gamma
7903           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7904 C now gradient over theta_1
7905           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7906      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7907           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7908      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7909         enddo ! j
7910         etors=etors+etori
7911 C derivative over gamma
7912         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7913 C derivative over theta1
7914         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7915 C now derivative over theta2
7916         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7917         if (lprn) then
7918           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7919      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7920           write (iout,*) "c1",(c1(k),k=0,nval),
7921      &    " c2",(c2(k),k=0,nval)
7922         endif
7923       enddo
7924       return
7925       end
7926 c---------------------------------------------------------------------------------------------
7927       subroutine etor_constr(edihcnstr)
7928       implicit real*8 (a-h,o-z)
7929       include 'DIMENSIONS'
7930       include 'COMMON.VAR'
7931       include 'COMMON.GEO'
7932       include 'COMMON.LOCAL'
7933       include 'COMMON.TORSION'
7934       include 'COMMON.INTERACT'
7935       include 'COMMON.DERIV'
7936       include 'COMMON.CHAIN'
7937       include 'COMMON.NAMES'
7938       include 'COMMON.IOUNITS'
7939       include 'COMMON.FFIELD'
7940       include 'COMMON.TORCNSTR'
7941       include 'COMMON.BOUNDS'
7942       include 'COMMON.CONTROL'
7943 ! 6/20/98 - dihedral angle constraints
7944       edihcnstr=0.0d0
7945 c      do i=1,ndih_constr
7946       if (raw_psipred) then
7947         do i=idihconstr_start,idihconstr_end
7948           itori=idih_constr(i)
7949           phii=phi(itori)
7950           gaudih_i=vpsipred(1,i)
7951           gauder_i=0.0d0
7952           do j=1,2
7953             s = sdihed(j,i)
7954             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7955             dexpcos_i=dexp(-cos_i*cos_i)
7956             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7957             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7958      &            *cos_i*dexpcos_i/s**2
7959           enddo
7960           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7961           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7962           if (energy_dec)
7963      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7964      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7965      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7966      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7967      &     -wdihc*dlog(gaudih_i)
7968         enddo
7969       else
7970
7971       do i=idihconstr_start,idihconstr_end
7972         itori=idih_constr(i)
7973         phii=phi(itori)
7974         difi=pinorm(phii-phi0(i))
7975         if (difi.gt.drange(i)) then
7976           difi=difi-drange(i)
7977           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7978           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7979         else if (difi.lt.-drange(i)) then
7980           difi=difi+drange(i)
7981           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7982           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7983         else
7984           difi=0.0
7985         endif
7986       enddo
7987
7988       endif
7989
7990       return
7991       end
7992 c----------------------------------------------------------------------------
7993 c MODELLER restraint function
7994       subroutine e_modeller(ehomology_constr)
7995       implicit none
7996       include 'DIMENSIONS'
7997
7998       double precision ehomology_constr
7999       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8000       integer katy, odleglosci, test7
8001       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8002       real*8 Eval,Erot
8003       real*8 distance(max_template),distancek(max_template),
8004      &    min_odl,godl(max_template),dih_diff(max_template)
8005
8006 c
8007 c     FP - 30/10/2014 Temporary specifications for homology restraints
8008 c
8009       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8010      &                 sgtheta
8011       double precision, dimension (maxres) :: guscdiff,usc_diff
8012       double precision, dimension (max_template) ::
8013      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8014      &           theta_diff
8015       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8016      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8017      & betai,sum_sgodl,dij
8018       double precision dist,pinorm
8019 c
8020       include 'COMMON.SBRIDGE'
8021       include 'COMMON.CHAIN'
8022       include 'COMMON.GEO'
8023       include 'COMMON.DERIV'
8024       include 'COMMON.LOCAL'
8025       include 'COMMON.INTERACT'
8026       include 'COMMON.VAR'
8027       include 'COMMON.IOUNITS'
8028 c      include 'COMMON.MD'
8029       include 'COMMON.CONTROL'
8030       include 'COMMON.HOMOLOGY'
8031       include 'COMMON.QRESTR'
8032 c
8033 c     From subroutine Econstr_back
8034 c
8035       include 'COMMON.NAMES'
8036       include 'COMMON.TIME1'
8037 c
8038
8039
8040       do i=1,max_template
8041         distancek(i)=9999999.9
8042       enddo
8043
8044
8045       odleg=0.0d0
8046
8047 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8048 c function)
8049 C AL 5/2/14 - Introduce list of restraints
8050 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8051 #ifdef DEBUG
8052       write(iout,*) "------- dist restrs start -------"
8053 #endif
8054       do ii = link_start_homo,link_end_homo
8055          i = ires_homo(ii)
8056          j = jres_homo(ii)
8057          dij=dist(i,j)
8058 c        write (iout,*) "dij(",i,j,") =",dij
8059          nexl=0
8060          do k=1,constr_homology
8061 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8062            if(.not.l_homo(k,ii)) then
8063              nexl=nexl+1
8064              cycle
8065            endif
8066            distance(k)=odl(k,ii)-dij
8067 c          write (iout,*) "distance(",k,") =",distance(k)
8068 c
8069 c          For Gaussian-type Urestr
8070 c
8071            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8072 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8073 c          write (iout,*) "distancek(",k,") =",distancek(k)
8074 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8075 c
8076 c          For Lorentzian-type Urestr
8077 c
8078            if (waga_dist.lt.0.0d0) then
8079               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8080               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8081      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8082            endif
8083          enddo
8084
8085 c         min_odl=minval(distancek)
8086          do kk=1,constr_homology
8087           if(l_homo(kk,ii)) then
8088             min_odl=distancek(kk)
8089             exit
8090           endif
8091          enddo
8092          do kk=1,constr_homology
8093           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8094      &              min_odl=distancek(kk)
8095          enddo
8096
8097 c        write (iout,* )"min_odl",min_odl
8098 #ifdef DEBUG
8099          write (iout,*) "ij dij",i,j,dij
8100          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8101          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8102          write (iout,* )"min_odl",min_odl
8103 #endif
8104 #ifdef OLDRESTR
8105          odleg2=0.0d0
8106 #else
8107          if (waga_dist.ge.0.0d0) then
8108            odleg2=nexl
8109          else
8110            odleg2=0.0d0
8111          endif
8112 #endif
8113          do k=1,constr_homology
8114 c Nie wiem po co to liczycie jeszcze raz!
8115 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8116 c     &              (2*(sigma_odl(i,j,k))**2))
8117            if(.not.l_homo(k,ii)) cycle
8118            if (waga_dist.ge.0.0d0) then
8119 c
8120 c          For Gaussian-type Urestr
8121 c
8122             godl(k)=dexp(-distancek(k)+min_odl)
8123             odleg2=odleg2+godl(k)
8124 c
8125 c          For Lorentzian-type Urestr
8126 c
8127            else
8128             odleg2=odleg2+distancek(k)
8129            endif
8130
8131 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8132 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8133 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8134 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8135
8136          enddo
8137 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8138 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8139 #ifdef DEBUG
8140          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8141          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8142 #endif
8143            if (waga_dist.ge.0.0d0) then
8144 c
8145 c          For Gaussian-type Urestr
8146 c
8147               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8148 c
8149 c          For Lorentzian-type Urestr
8150 c
8151            else
8152               odleg=odleg+odleg2/constr_homology
8153            endif
8154 c
8155 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8156 c Gradient
8157 c
8158 c          For Gaussian-type Urestr
8159 c
8160          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8161          sum_sgodl=0.0d0
8162          do k=1,constr_homology
8163 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8164 c     &           *waga_dist)+min_odl
8165 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8166 c
8167          if(.not.l_homo(k,ii)) cycle
8168          if (waga_dist.ge.0.0d0) then
8169 c          For Gaussian-type Urestr
8170 c
8171            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8172 c
8173 c          For Lorentzian-type Urestr
8174 c
8175          else
8176            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8177      &           sigma_odlir(k,ii)**2)**2)
8178          endif
8179            sum_sgodl=sum_sgodl+sgodl
8180
8181 c            sgodl2=sgodl2+sgodl
8182 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8183 c      write(iout,*) "constr_homology=",constr_homology
8184 c      write(iout,*) i, j, k, "TEST K"
8185          enddo
8186          if (waga_dist.ge.0.0d0) then
8187 c
8188 c          For Gaussian-type Urestr
8189 c
8190             grad_odl3=waga_homology(iset)*waga_dist
8191      &                *sum_sgodl/(sum_godl*dij)
8192 c
8193 c          For Lorentzian-type Urestr
8194 c
8195          else
8196 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8197 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8198             grad_odl3=-waga_homology(iset)*waga_dist*
8199      &                sum_sgodl/(constr_homology*dij)
8200          endif
8201 c
8202 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8203
8204
8205 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8206 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8207 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8208
8209 ccc      write(iout,*) godl, sgodl, grad_odl3
8210
8211 c          grad_odl=grad_odl+grad_odl3
8212
8213          do jik=1,3
8214             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8215 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8216 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8217 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8218             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8219             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8220 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8221 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8222 c         if (i.eq.25.and.j.eq.27) then
8223 c         write(iout,*) "jik",jik,"i",i,"j",j
8224 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8225 c         write(iout,*) "grad_odl3",grad_odl3
8226 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8227 c         write(iout,*) "ggodl",ggodl
8228 c         write(iout,*) "ghpbc(",jik,i,")",
8229 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8230 c     &                 ghpbc(jik,j)
8231 c         endif
8232          enddo
8233 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8234 ccc     & dLOG(odleg2),"-odleg=", -odleg
8235
8236       enddo ! ii-loop for dist
8237 #ifdef DEBUG
8238       write(iout,*) "------- dist restrs end -------"
8239 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8240 c    &     waga_d.eq.1.0d0) call sum_gradient
8241 #endif
8242 c Pseudo-energy and gradient from dihedral-angle restraints from
8243 c homology templates
8244 c      write (iout,*) "End of distance loop"
8245 c      call flush(iout)
8246       kat=0.0d0
8247 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8248 #ifdef DEBUG
8249       write(iout,*) "------- dih restrs start -------"
8250       do i=idihconstr_start_homo,idihconstr_end_homo
8251         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8252       enddo
8253 #endif
8254       do i=idihconstr_start_homo,idihconstr_end_homo
8255         kat2=0.0d0
8256 c        betai=beta(i,i+1,i+2,i+3)
8257         betai = phi(i)
8258 c       write (iout,*) "betai =",betai
8259         do k=1,constr_homology
8260           dih_diff(k)=pinorm(dih(k,i)-betai)
8261 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8262 cd     &                  ,sigma_dih(k,i)
8263 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8264 c     &                                   -(6.28318-dih_diff(i,k))
8265 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8266 c     &                                   6.28318+dih_diff(i,k)
8267 #ifdef OLD_DIHED
8268           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8269 #else
8270           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8271 #endif
8272 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8273           gdih(k)=dexp(kat3)
8274           kat2=kat2+gdih(k)
8275 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8276 c          write(*,*)""
8277         enddo
8278 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8279 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8280 #ifdef DEBUG
8281         write (iout,*) "i",i," betai",betai," kat2",kat2
8282         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8283 #endif
8284         if (kat2.le.1.0d-14) cycle
8285         kat=kat-dLOG(kat2/constr_homology)
8286 c       write (iout,*) "kat",kat ! sum of -ln-s
8287
8288 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8289 ccc     & dLOG(kat2), "-kat=", -kat
8290
8291 c ----------------------------------------------------------------------
8292 c Gradient
8293 c ----------------------------------------------------------------------
8294
8295         sum_gdih=kat2
8296         sum_sgdih=0.0d0
8297         do k=1,constr_homology
8298 #ifdef OLD_DIHED
8299           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8300 #else
8301           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8302 #endif
8303 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8304           sum_sgdih=sum_sgdih+sgdih
8305         enddo
8306 c       grad_dih3=sum_sgdih/sum_gdih
8307         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8308
8309 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8310 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8311 ccc     & gloc(nphi+i-3,icg)
8312         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8313 c        if (i.eq.25) then
8314 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8315 c        endif
8316 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8317 ccc     & gloc(nphi+i-3,icg)
8318
8319       enddo ! i-loop for dih
8320 #ifdef DEBUG
8321       write(iout,*) "------- dih restrs end -------"
8322 #endif
8323
8324 c Pseudo-energy and gradient for theta angle restraints from
8325 c homology templates
8326 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8327 c adapted
8328
8329 c
8330 c     For constr_homology reference structures (FP)
8331 c
8332 c     Uconst_back_tot=0.0d0
8333       Eval=0.0d0
8334       Erot=0.0d0
8335 c     Econstr_back legacy
8336       do i=1,nres
8337 c     do i=ithet_start,ithet_end
8338        dutheta(i)=0.0d0
8339 c     enddo
8340 c     do i=loc_start,loc_end
8341         do j=1,3
8342           duscdiff(j,i)=0.0d0
8343           duscdiffx(j,i)=0.0d0
8344         enddo
8345       enddo
8346 c
8347 c     do iref=1,nref
8348 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8349 c     write (iout,*) "waga_theta",waga_theta
8350       if (waga_theta.gt.0.0d0) then
8351 #ifdef DEBUG
8352       write (iout,*) "usampl",usampl
8353       write(iout,*) "------- theta restrs start -------"
8354 c     do i=ithet_start,ithet_end
8355 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8356 c     enddo
8357 #endif
8358 c     write (iout,*) "maxres",maxres,"nres",nres
8359
8360       do i=ithet_start,ithet_end
8361 c
8362 c     do i=1,nfrag_back
8363 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8364 c
8365 c Deviation of theta angles wrt constr_homology ref structures
8366 c
8367         utheta_i=0.0d0 ! argument of Gaussian for single k
8368         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8369 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8370 c       over residues in a fragment
8371 c       write (iout,*) "theta(",i,")=",theta(i)
8372         do k=1,constr_homology
8373 c
8374 c         dtheta_i=theta(j)-thetaref(j,iref)
8375 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8376           theta_diff(k)=thetatpl(k,i)-theta(i)
8377 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8378 cd     &                  ,sigma_theta(k,i)
8379
8380 c
8381           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8382 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8383           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8384           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8385 c         Gradient for single Gaussian restraint in subr Econstr_back
8386 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8387 c
8388         enddo
8389 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8390 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8391
8392 c
8393 c         Gradient for multiple Gaussian restraint
8394         sum_gtheta=gutheta_i
8395         sum_sgtheta=0.0d0
8396         do k=1,constr_homology
8397 c        New generalized expr for multiple Gaussian from Econstr_back
8398          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8399 c
8400 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8401           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8402         enddo
8403 c       Final value of gradient using same var as in Econstr_back
8404         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8405      &      +sum_sgtheta/sum_gtheta*waga_theta
8406      &               *waga_homology(iset)
8407 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8408 c     &               *waga_homology(iset)
8409 c       dutheta(i)=sum_sgtheta/sum_gtheta
8410 c
8411 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8412         Eval=Eval-dLOG(gutheta_i/constr_homology)
8413 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8414 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8415 c       Uconst_back=Uconst_back+utheta(i)
8416       enddo ! (i-loop for theta)
8417 #ifdef DEBUG
8418       write(iout,*) "------- theta restrs end -------"
8419 #endif
8420       endif
8421 c
8422 c Deviation of local SC geometry
8423 c
8424 c Separation of two i-loops (instructed by AL - 11/3/2014)
8425 c
8426 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8427 c     write (iout,*) "waga_d",waga_d
8428
8429 #ifdef DEBUG
8430       write(iout,*) "------- SC restrs start -------"
8431       write (iout,*) "Initial duscdiff,duscdiffx"
8432       do i=loc_start,loc_end
8433         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8434      &                 (duscdiffx(jik,i),jik=1,3)
8435       enddo
8436 #endif
8437       do i=loc_start,loc_end
8438         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8439         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8440 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8441 c       write(iout,*) "xxtab, yytab, zztab"
8442 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8443         do k=1,constr_homology
8444 c
8445           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8446 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8447           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8448           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8449 c         write(iout,*) "dxx, dyy, dzz"
8450 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8451 c
8452           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8453 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8454 c         uscdiffk(k)=usc_diff(i)
8455           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8456 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8457 c     &       " guscdiff2",guscdiff2(k)
8458           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8459 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8460 c     &      xxref(j),yyref(j),zzref(j)
8461         enddo
8462 c
8463 c       Gradient
8464 c
8465 c       Generalized expression for multiple Gaussian acc to that for a single
8466 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8467 c
8468 c       Original implementation
8469 c       sum_guscdiff=guscdiff(i)
8470 c
8471 c       sum_sguscdiff=0.0d0
8472 c       do k=1,constr_homology
8473 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8474 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8475 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8476 c       enddo
8477 c
8478 c       Implementation of new expressions for gradient (Jan. 2015)
8479 c
8480 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8481         do k=1,constr_homology
8482 c
8483 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8484 c       before. Now the drivatives should be correct
8485 c
8486           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8487 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8488           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8489           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8490 c
8491 c         New implementation
8492 c
8493           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8494      &                 sigma_d(k,i) ! for the grad wrt r'
8495 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8496 c
8497 c
8498 c        New implementation
8499          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8500          do jik=1,3
8501             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8502      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8503      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8504             duscdiff(jik,i)=duscdiff(jik,i)+
8505      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8506      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8507             duscdiffx(jik,i)=duscdiffx(jik,i)+
8508      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8509      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8510 c
8511 #ifdef DEBUG
8512              write(iout,*) "jik",jik,"i",i
8513              write(iout,*) "dxx, dyy, dzz"
8514              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8515              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8516 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8517 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8518 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8519 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8520 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8521 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8522 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8523 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8524 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8525 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8526 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8527 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8528 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8529 c            endif
8530 #endif
8531          enddo
8532         enddo
8533 c
8534 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8535 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8536 c
8537 c        write (iout,*) i," uscdiff",uscdiff(i)
8538 c
8539 c Put together deviations from local geometry
8540
8541 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8542 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8543         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8544 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8545 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8546 c       Uconst_back=Uconst_back+usc_diff(i)
8547 c
8548 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8549 c
8550 c     New implment: multiplied by sum_sguscdiff
8551 c
8552
8553       enddo ! (i-loop for dscdiff)
8554
8555 c      endif
8556
8557 #ifdef DEBUG
8558       write(iout,*) "------- SC restrs end -------"
8559         write (iout,*) "------ After SC loop in e_modeller ------"
8560         do i=loc_start,loc_end
8561          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8562          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8563         enddo
8564       if (waga_theta.eq.1.0d0) then
8565       write (iout,*) "in e_modeller after SC restr end: dutheta"
8566       do i=ithet_start,ithet_end
8567         write (iout,*) i,dutheta(i)
8568       enddo
8569       endif
8570       if (waga_d.eq.1.0d0) then
8571       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8572       do i=1,nres
8573         write (iout,*) i,(duscdiff(j,i),j=1,3)
8574         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8575       enddo
8576       endif
8577 #endif
8578
8579 c Total energy from homology restraints
8580 #ifdef DEBUG
8581       write (iout,*) "odleg",odleg," kat",kat
8582 #endif
8583 c
8584 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8585 c
8586 c     ehomology_constr=odleg+kat
8587 c
8588 c     For Lorentzian-type Urestr
8589 c
8590
8591       if (waga_dist.ge.0.0d0) then
8592 c
8593 c          For Gaussian-type Urestr
8594 c
8595         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8596      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8597 c     write (iout,*) "ehomology_constr=",ehomology_constr
8598       else
8599 c
8600 c          For Lorentzian-type Urestr
8601 c
8602         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8603      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8604 c     write (iout,*) "ehomology_constr=",ehomology_constr
8605       endif
8606 #ifdef DEBUG
8607       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8608      & "Eval",waga_theta,eval,
8609      &   "Erot",waga_d,Erot
8610       write (iout,*) "ehomology_constr",ehomology_constr
8611 #endif
8612       return
8613 c
8614 c FP 01/15 end
8615 c
8616   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8617   747 format(a12,i4,i4,i4,f8.3,f8.3)
8618   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8619   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8620   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8621      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8622       end
8623 c----------------------------------------------------------------------------
8624 C The rigorous attempt to derive energy function
8625       subroutine ebend_kcc(etheta)
8626
8627       implicit real*8 (a-h,o-z)
8628       include 'DIMENSIONS'
8629       include 'COMMON.VAR'
8630       include 'COMMON.GEO'
8631       include 'COMMON.LOCAL'
8632       include 'COMMON.TORSION'
8633       include 'COMMON.INTERACT'
8634       include 'COMMON.DERIV'
8635       include 'COMMON.CHAIN'
8636       include 'COMMON.NAMES'
8637       include 'COMMON.IOUNITS'
8638       include 'COMMON.FFIELD'
8639       include 'COMMON.TORCNSTR'
8640       include 'COMMON.CONTROL'
8641       logical lprn
8642       double precision thybt1(maxang_kcc)
8643 C Set lprn=.true. for debugging
8644       lprn=energy_dec
8645 c     lprn=.true.
8646 C      print *,"wchodze kcc"
8647       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8648       etheta=0.0D0
8649       do i=ithet_start,ithet_end
8650 c        print *,i,itype(i-1),itype(i),itype(i-2)
8651         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8652      &  .or.itype(i).eq.ntyp1) cycle
8653         iti=iabs(itortyp(itype(i-1)))
8654         sinthet=dsin(theta(i))
8655         costhet=dcos(theta(i))
8656         do j=1,nbend_kcc_Tb(iti)
8657           thybt1(j)=v1bend_chyb(j,iti)
8658         enddo
8659         sumth1thyb=v1bend_chyb(0,iti)+
8660      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8661         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8662      &    sumth1thyb
8663         ihelp=nbend_kcc_Tb(iti)-1
8664         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8665         etheta=etheta+sumth1thyb
8666 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8667         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8668       enddo
8669       return
8670       end
8671 c-------------------------------------------------------------------------------------
8672       subroutine etheta_constr(ethetacnstr)
8673
8674       implicit real*8 (a-h,o-z)
8675       include 'DIMENSIONS'
8676       include 'COMMON.VAR'
8677       include 'COMMON.GEO'
8678       include 'COMMON.LOCAL'
8679       include 'COMMON.TORSION'
8680       include 'COMMON.INTERACT'
8681       include 'COMMON.DERIV'
8682       include 'COMMON.CHAIN'
8683       include 'COMMON.NAMES'
8684       include 'COMMON.IOUNITS'
8685       include 'COMMON.FFIELD'
8686       include 'COMMON.TORCNSTR'
8687       include 'COMMON.CONTROL'
8688       ethetacnstr=0.0d0
8689 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8690       do i=ithetaconstr_start,ithetaconstr_end
8691         itheta=itheta_constr(i)
8692         thetiii=theta(itheta)
8693         difi=pinorm(thetiii-theta_constr0(i))
8694         if (difi.gt.theta_drange(i)) then
8695           difi=difi-theta_drange(i)
8696           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8697           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8698      &    +for_thet_constr(i)*difi**3
8699         else if (difi.lt.-drange(i)) then
8700           difi=difi+drange(i)
8701           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8702           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8703      &    +for_thet_constr(i)*difi**3
8704         else
8705           difi=0.0
8706         endif
8707        if (energy_dec) then
8708         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8709      &    i,itheta,rad2deg*thetiii,
8710      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8711      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8712      &    gloc(itheta+nphi-2,icg)
8713         endif
8714       enddo
8715       return
8716       end
8717 c------------------------------------------------------------------------------
8718       subroutine eback_sc_corr(esccor)
8719 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8720 c        conformational states; temporarily implemented as differences
8721 c        between UNRES torsional potentials (dependent on three types of
8722 c        residues) and the torsional potentials dependent on all 20 types
8723 c        of residues computed from AM1  energy surfaces of terminally-blocked
8724 c        amino-acid residues.
8725       implicit real*8 (a-h,o-z)
8726       include 'DIMENSIONS'
8727       include 'COMMON.VAR'
8728       include 'COMMON.GEO'
8729       include 'COMMON.LOCAL'
8730       include 'COMMON.TORSION'
8731       include 'COMMON.SCCOR'
8732       include 'COMMON.INTERACT'
8733       include 'COMMON.DERIV'
8734       include 'COMMON.CHAIN'
8735       include 'COMMON.NAMES'
8736       include 'COMMON.IOUNITS'
8737       include 'COMMON.FFIELD'
8738       include 'COMMON.CONTROL'
8739       logical lprn
8740 C Set lprn=.true. for debugging
8741       lprn=.false.
8742 c      lprn=.true.
8743 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8744       esccor=0.0D0
8745       do i=itau_start,itau_end
8746         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8747         esccor_ii=0.0D0
8748         isccori=isccortyp(itype(i-2))
8749         isccori1=isccortyp(itype(i-1))
8750 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8751         phii=phi(i)
8752         do intertyp=1,3 !intertyp
8753 cc Added 09 May 2012 (Adasko)
8754 cc  Intertyp means interaction type of backbone mainchain correlation:
8755 c   1 = SC...Ca...Ca...Ca
8756 c   2 = Ca...Ca...Ca...SC
8757 c   3 = SC...Ca...Ca...SCi
8758         gloci=0.0D0
8759         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8760      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8761      &      (itype(i-1).eq.ntyp1)))
8762      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8763      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8764      &     .or.(itype(i).eq.ntyp1)))
8765      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8766      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8767      &      (itype(i-3).eq.ntyp1)))) cycle
8768         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8769         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8770      & cycle
8771        do j=1,nterm_sccor(isccori,isccori1)
8772           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8773           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8774           cosphi=dcos(j*tauangle(intertyp,i))
8775           sinphi=dsin(j*tauangle(intertyp,i))
8776           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8777           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8778         enddo
8779 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8780         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8781         if (lprn)
8782      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8783      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8784      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8785      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8786         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8787        enddo !intertyp
8788       enddo
8789
8790       return
8791       end
8792 #ifdef FOURBODY
8793 c----------------------------------------------------------------------------
8794       subroutine multibody(ecorr)
8795 C This subroutine calculates multi-body contributions to energy following
8796 C the idea of Skolnick et al. If side chains I and J make a contact and
8797 C at the same time side chains I+1 and J+1 make a contact, an extra
8798 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8799       implicit real*8 (a-h,o-z)
8800       include 'DIMENSIONS'
8801       include 'COMMON.IOUNITS'
8802       include 'COMMON.DERIV'
8803       include 'COMMON.INTERACT'
8804       include 'COMMON.CONTACTS'
8805       include 'COMMON.CONTMAT'
8806       include 'COMMON.CORRMAT'
8807       double precision gx(3),gx1(3)
8808       logical lprn
8809
8810 C Set lprn=.true. for debugging
8811       lprn=.false.
8812
8813       if (lprn) then
8814         write (iout,'(a)') 'Contact function values:'
8815         do i=nnt,nct-2
8816           write (iout,'(i2,20(1x,i2,f10.5))')
8817      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8818         enddo
8819       endif
8820       ecorr=0.0D0
8821       do i=nnt,nct
8822         do j=1,3
8823           gradcorr(j,i)=0.0D0
8824           gradxorr(j,i)=0.0D0
8825         enddo
8826       enddo
8827       do i=nnt,nct-2
8828
8829         DO ISHIFT = 3,4
8830
8831         i1=i+ishift
8832         num_conti=num_cont(i)
8833         num_conti1=num_cont(i1)
8834         do jj=1,num_conti
8835           j=jcont(jj,i)
8836           do kk=1,num_conti1
8837             j1=jcont(kk,i1)
8838             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8839 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8840 cd   &                   ' ishift=',ishift
8841 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8842 C The system gains extra energy.
8843               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8844             endif   ! j1==j+-ishift
8845           enddo     ! kk
8846         enddo       ! jj
8847
8848         ENDDO ! ISHIFT
8849
8850       enddo         ! i
8851       return
8852       end
8853 c------------------------------------------------------------------------------
8854       double precision function esccorr(i,j,k,l,jj,kk)
8855       implicit real*8 (a-h,o-z)
8856       include 'DIMENSIONS'
8857       include 'COMMON.IOUNITS'
8858       include 'COMMON.DERIV'
8859       include 'COMMON.INTERACT'
8860       include 'COMMON.CONTACTS'
8861       include 'COMMON.CONTMAT'
8862       include 'COMMON.CORRMAT'
8863       include 'COMMON.SHIELD'
8864       double precision gx(3),gx1(3)
8865       logical lprn
8866       lprn=.false.
8867       eij=facont(jj,i)
8868       ekl=facont(kk,k)
8869 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8870 C Calculate the multi-body contribution to energy.
8871 C Calculate multi-body contributions to the gradient.
8872 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8873 cd   & k,l,(gacont(m,kk,k),m=1,3)
8874       do m=1,3
8875         gx(m) =ekl*gacont(m,jj,i)
8876         gx1(m)=eij*gacont(m,kk,k)
8877         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8878         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8879         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8880         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8881       enddo
8882       do m=i,j-1
8883         do ll=1,3
8884           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8885         enddo
8886       enddo
8887       do m=k,l-1
8888         do ll=1,3
8889           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8890         enddo
8891       enddo
8892       esccorr=-eij*ekl
8893       return
8894       end
8895 c------------------------------------------------------------------------------
8896       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8897 C This subroutine calculates multi-body contributions to hydrogen-bonding
8898       implicit real*8 (a-h,o-z)
8899       include 'DIMENSIONS'
8900       include 'COMMON.IOUNITS'
8901 #ifdef MPI
8902       include "mpif.h"
8903       parameter (max_cont=maxconts)
8904       parameter (max_dim=26)
8905       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8906       double precision zapas(max_dim,maxconts,max_fg_procs),
8907      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8908       common /przechowalnia/ zapas
8909       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8910      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8911 #endif
8912       include 'COMMON.SETUP'
8913       include 'COMMON.FFIELD'
8914       include 'COMMON.DERIV'
8915       include 'COMMON.INTERACT'
8916       include 'COMMON.CONTACTS'
8917       include 'COMMON.CONTMAT'
8918       include 'COMMON.CORRMAT'
8919       include 'COMMON.CONTROL'
8920       include 'COMMON.LOCAL'
8921       double precision gx(3),gx1(3),time00
8922       logical lprn,ldone
8923
8924 C Set lprn=.true. for debugging
8925       lprn=.false.
8926 #ifdef MPI
8927       n_corr=0
8928       n_corr1=0
8929       if (nfgtasks.le.1) goto 30
8930       if (lprn) then
8931         write (iout,'(a)') 'Contact function values before RECEIVE:'
8932         do i=nnt,nct-2
8933           write (iout,'(2i3,50(1x,i2,f5.2))')
8934      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8935      &    j=1,num_cont_hb(i))
8936         enddo
8937         call flush(iout)
8938       endif
8939       do i=1,ntask_cont_from
8940         ncont_recv(i)=0
8941       enddo
8942       do i=1,ntask_cont_to
8943         ncont_sent(i)=0
8944       enddo
8945 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8946 c     & ntask_cont_to
8947 C Make the list of contacts to send to send to other procesors
8948 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8949 c      call flush(iout)
8950       do i=iturn3_start,iturn3_end
8951 c        write (iout,*) "make contact list turn3",i," num_cont",
8952 c     &    num_cont_hb(i)
8953         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8954       enddo
8955       do i=iturn4_start,iturn4_end
8956 c        write (iout,*) "make contact list turn4",i," num_cont",
8957 c     &   num_cont_hb(i)
8958         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8959       enddo
8960       do ii=1,nat_sent
8961         i=iat_sent(ii)
8962 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8963 c     &    num_cont_hb(i)
8964         do j=1,num_cont_hb(i)
8965         do k=1,4
8966           jjc=jcont_hb(j,i)
8967           iproc=iint_sent_local(k,jjc,ii)
8968 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8969           if (iproc.gt.0) then
8970             ncont_sent(iproc)=ncont_sent(iproc)+1
8971             nn=ncont_sent(iproc)
8972             zapas(1,nn,iproc)=i
8973             zapas(2,nn,iproc)=jjc
8974             zapas(3,nn,iproc)=facont_hb(j,i)
8975             zapas(4,nn,iproc)=ees0p(j,i)
8976             zapas(5,nn,iproc)=ees0m(j,i)
8977             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8978             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8979             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8980             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8981             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8982             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8983             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8984             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8985             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8986             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8987             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8988             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8989             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8990             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8991             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8992             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8993             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8994             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8995             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8996             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8997             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8998           endif
8999         enddo
9000         enddo
9001       enddo
9002       if (lprn) then
9003       write (iout,*)
9004      &  "Numbers of contacts to be sent to other processors",
9005      &  (ncont_sent(i),i=1,ntask_cont_to)
9006       write (iout,*) "Contacts sent"
9007       do ii=1,ntask_cont_to
9008         nn=ncont_sent(ii)
9009         iproc=itask_cont_to(ii)
9010         write (iout,*) nn," contacts to processor",iproc,
9011      &   " of CONT_TO_COMM group"
9012         do i=1,nn
9013           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9014         enddo
9015       enddo
9016       call flush(iout)
9017       endif
9018       CorrelType=477
9019       CorrelID=fg_rank+1
9020       CorrelType1=478
9021       CorrelID1=nfgtasks+fg_rank+1
9022       ireq=0
9023 C Receive the numbers of needed contacts from other processors
9024       do ii=1,ntask_cont_from
9025         iproc=itask_cont_from(ii)
9026         ireq=ireq+1
9027         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9028      &    FG_COMM,req(ireq),IERR)
9029       enddo
9030 c      write (iout,*) "IRECV ended"
9031 c      call flush(iout)
9032 C Send the number of contacts needed by other processors
9033       do ii=1,ntask_cont_to
9034         iproc=itask_cont_to(ii)
9035         ireq=ireq+1
9036         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9037      &    FG_COMM,req(ireq),IERR)
9038       enddo
9039 c      write (iout,*) "ISEND ended"
9040 c      write (iout,*) "number of requests (nn)",ireq
9041 c      call flush(iout)
9042       if (ireq.gt.0)
9043      &  call MPI_Waitall(ireq,req,status_array,ierr)
9044 c      write (iout,*)
9045 c     &  "Numbers of contacts to be received from other processors",
9046 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9047 c      call flush(iout)
9048 C Receive contacts
9049       ireq=0
9050       do ii=1,ntask_cont_from
9051         iproc=itask_cont_from(ii)
9052         nn=ncont_recv(ii)
9053 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9054 c     &   " of CONT_TO_COMM group"
9055 c        call flush(iout)
9056         if (nn.gt.0) then
9057           ireq=ireq+1
9058           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9059      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9060 c          write (iout,*) "ireq,req",ireq,req(ireq)
9061         endif
9062       enddo
9063 C Send the contacts to processors that need them
9064       do ii=1,ntask_cont_to
9065         iproc=itask_cont_to(ii)
9066         nn=ncont_sent(ii)
9067 c        write (iout,*) nn," contacts to processor",iproc,
9068 c     &   " of CONT_TO_COMM group"
9069         if (nn.gt.0) then
9070           ireq=ireq+1
9071           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9072      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9073 c          write (iout,*) "ireq,req",ireq,req(ireq)
9074 c          do i=1,nn
9075 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9076 c          enddo
9077         endif
9078       enddo
9079 c      write (iout,*) "number of requests (contacts)",ireq
9080 c      write (iout,*) "req",(req(i),i=1,4)
9081 c      call flush(iout)
9082       if (ireq.gt.0)
9083      & call MPI_Waitall(ireq,req,status_array,ierr)
9084       do iii=1,ntask_cont_from
9085         iproc=itask_cont_from(iii)
9086         nn=ncont_recv(iii)
9087         if (lprn) then
9088         write (iout,*) "Received",nn," contacts from processor",iproc,
9089      &   " of CONT_FROM_COMM group"
9090         call flush(iout)
9091         do i=1,nn
9092           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9093         enddo
9094         call flush(iout)
9095         endif
9096         do i=1,nn
9097           ii=zapas_recv(1,i,iii)
9098 c Flag the received contacts to prevent double-counting
9099           jj=-zapas_recv(2,i,iii)
9100 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9101 c          call flush(iout)
9102           nnn=num_cont_hb(ii)+1
9103           num_cont_hb(ii)=nnn
9104           jcont_hb(nnn,ii)=jj
9105           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9106           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9107           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9108           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9109           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9110           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9111           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9112           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9113           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9114           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9115           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9116           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9117           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9118           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9119           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9120           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9121           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9122           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9123           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9124           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9125           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9126           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9127           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9128           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9129         enddo
9130       enddo
9131       if (lprn) then
9132         write (iout,'(a)') 'Contact function values after receive:'
9133         do i=nnt,nct-2
9134           write (iout,'(2i3,50(1x,i3,f5.2))')
9135      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9136      &    j=1,num_cont_hb(i))
9137         enddo
9138         call flush(iout)
9139       endif
9140    30 continue
9141 #endif
9142       if (lprn) then
9143         write (iout,'(a)') 'Contact function values:'
9144         do i=nnt,nct-2
9145           write (iout,'(2i3,50(1x,i3,f5.2))')
9146      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9147      &    j=1,num_cont_hb(i))
9148         enddo
9149         call flush(iout)
9150       endif
9151       ecorr=0.0D0
9152 C Remove the loop below after debugging !!!
9153       do i=nnt,nct
9154         do j=1,3
9155           gradcorr(j,i)=0.0D0
9156           gradxorr(j,i)=0.0D0
9157         enddo
9158       enddo
9159 C Calculate the local-electrostatic correlation terms
9160       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9161         i1=i+1
9162         num_conti=num_cont_hb(i)
9163         num_conti1=num_cont_hb(i+1)
9164         do jj=1,num_conti
9165           j=jcont_hb(jj,i)
9166           jp=iabs(j)
9167           do kk=1,num_conti1
9168             j1=jcont_hb(kk,i1)
9169             jp1=iabs(j1)
9170 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9171 c     &         ' jj=',jj,' kk=',kk
9172 c            call flush(iout)
9173             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9174      &          .or. j.lt.0 .and. j1.gt.0) .and.
9175      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9176 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9177 C The system gains extra energy.
9178               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9179               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9180      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9181               n_corr=n_corr+1
9182             else if (j1.eq.j) then
9183 C Contacts I-J and I-(J+1) occur simultaneously.
9184 C The system loses extra energy.
9185 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9186             endif
9187           enddo ! kk
9188           do kk=1,num_conti
9189             j1=jcont_hb(kk,i)
9190 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9191 c    &         ' jj=',jj,' kk=',kk
9192             if (j1.eq.j+1) then
9193 C Contacts I-J and (I+1)-J occur simultaneously.
9194 C The system loses extra energy.
9195 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9196             endif ! j1==j+1
9197           enddo ! kk
9198         enddo ! jj
9199       enddo ! i
9200       return
9201       end
9202 c------------------------------------------------------------------------------
9203       subroutine add_hb_contact(ii,jj,itask)
9204       implicit real*8 (a-h,o-z)
9205       include "DIMENSIONS"
9206       include "COMMON.IOUNITS"
9207       integer max_cont
9208       integer max_dim
9209       parameter (max_cont=maxconts)
9210       parameter (max_dim=26)
9211       include "COMMON.CONTACTS"
9212       include 'COMMON.CONTMAT'
9213       include 'COMMON.CORRMAT'
9214       double precision zapas(max_dim,maxconts,max_fg_procs),
9215      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9216       common /przechowalnia/ zapas
9217       integer i,j,ii,jj,iproc,itask(4),nn
9218 c      write (iout,*) "itask",itask
9219       do i=1,2
9220         iproc=itask(i)
9221         if (iproc.gt.0) then
9222           do j=1,num_cont_hb(ii)
9223             jjc=jcont_hb(j,ii)
9224 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9225             if (jjc.eq.jj) then
9226               ncont_sent(iproc)=ncont_sent(iproc)+1
9227               nn=ncont_sent(iproc)
9228               zapas(1,nn,iproc)=ii
9229               zapas(2,nn,iproc)=jjc
9230               zapas(3,nn,iproc)=facont_hb(j,ii)
9231               zapas(4,nn,iproc)=ees0p(j,ii)
9232               zapas(5,nn,iproc)=ees0m(j,ii)
9233               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9234               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9235               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9236               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9237               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9238               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9239               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9240               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9241               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9242               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9243               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9244               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9245               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9246               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9247               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9248               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9249               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9250               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9251               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9252               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9253               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9254               exit
9255             endif
9256           enddo
9257         endif
9258       enddo
9259       return
9260       end
9261 c------------------------------------------------------------------------------
9262       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9263      &  n_corr1)
9264 C This subroutine calculates multi-body contributions to hydrogen-bonding
9265       implicit real*8 (a-h,o-z)
9266       include 'DIMENSIONS'
9267       include 'COMMON.IOUNITS'
9268 #ifdef MPI
9269       include "mpif.h"
9270       parameter (max_cont=maxconts)
9271       parameter (max_dim=70)
9272       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9273       double precision zapas(max_dim,maxconts,max_fg_procs),
9274      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9275       common /przechowalnia/ zapas
9276       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9277      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9278 #endif
9279       include 'COMMON.SETUP'
9280       include 'COMMON.FFIELD'
9281       include 'COMMON.DERIV'
9282       include 'COMMON.LOCAL'
9283       include 'COMMON.INTERACT'
9284       include 'COMMON.CONTACTS'
9285       include 'COMMON.CONTMAT'
9286       include 'COMMON.CORRMAT'
9287       include 'COMMON.CHAIN'
9288       include 'COMMON.CONTROL'
9289       include 'COMMON.SHIELD'
9290       double precision gx(3),gx1(3)
9291       integer num_cont_hb_old(maxres)
9292       logical lprn,ldone
9293       double precision eello4,eello5,eelo6,eello_turn6
9294       external eello4,eello5,eello6,eello_turn6
9295 C Set lprn=.true. for debugging
9296       lprn=.false.
9297       eturn6=0.0d0
9298 #ifdef MPI
9299       do i=1,nres
9300         num_cont_hb_old(i)=num_cont_hb(i)
9301       enddo
9302       n_corr=0
9303       n_corr1=0
9304       if (nfgtasks.le.1) goto 30
9305       if (lprn) then
9306         write (iout,'(a)') 'Contact function values before RECEIVE:'
9307         do i=nnt,nct-2
9308           write (iout,'(2i3,50(1x,i2,f5.2))')
9309      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9310      &    j=1,num_cont_hb(i))
9311         enddo
9312       endif
9313       do i=1,ntask_cont_from
9314         ncont_recv(i)=0
9315       enddo
9316       do i=1,ntask_cont_to
9317         ncont_sent(i)=0
9318       enddo
9319 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9320 c     & ntask_cont_to
9321 C Make the list of contacts to send to send to other procesors
9322       do i=iturn3_start,iturn3_end
9323 c        write (iout,*) "make contact list turn3",i," num_cont",
9324 c     &    num_cont_hb(i)
9325         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9326       enddo
9327       do i=iturn4_start,iturn4_end
9328 c        write (iout,*) "make contact list turn4",i," num_cont",
9329 c     &   num_cont_hb(i)
9330         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9331       enddo
9332       do ii=1,nat_sent
9333         i=iat_sent(ii)
9334 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9335 c     &    num_cont_hb(i)
9336         do j=1,num_cont_hb(i)
9337         do k=1,4
9338           jjc=jcont_hb(j,i)
9339           iproc=iint_sent_local(k,jjc,ii)
9340 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9341           if (iproc.ne.0) then
9342             ncont_sent(iproc)=ncont_sent(iproc)+1
9343             nn=ncont_sent(iproc)
9344             zapas(1,nn,iproc)=i
9345             zapas(2,nn,iproc)=jjc
9346             zapas(3,nn,iproc)=d_cont(j,i)
9347             ind=3
9348             do kk=1,3
9349               ind=ind+1
9350               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9351             enddo
9352             do kk=1,2
9353               do ll=1,2
9354                 ind=ind+1
9355                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9356               enddo
9357             enddo
9358             do jj=1,5
9359               do kk=1,3
9360                 do ll=1,2
9361                   do mm=1,2
9362                     ind=ind+1
9363                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9364                   enddo
9365                 enddo
9366               enddo
9367             enddo
9368           endif
9369         enddo
9370         enddo
9371       enddo
9372       if (lprn) then
9373       write (iout,*)
9374      &  "Numbers of contacts to be sent to other processors",
9375      &  (ncont_sent(i),i=1,ntask_cont_to)
9376       write (iout,*) "Contacts sent"
9377       do ii=1,ntask_cont_to
9378         nn=ncont_sent(ii)
9379         iproc=itask_cont_to(ii)
9380         write (iout,*) nn," contacts to processor",iproc,
9381      &   " of CONT_TO_COMM group"
9382         do i=1,nn
9383           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9384         enddo
9385       enddo
9386       call flush(iout)
9387       endif
9388       CorrelType=477
9389       CorrelID=fg_rank+1
9390       CorrelType1=478
9391       CorrelID1=nfgtasks+fg_rank+1
9392       ireq=0
9393 C Receive the numbers of needed contacts from other processors
9394       do ii=1,ntask_cont_from
9395         iproc=itask_cont_from(ii)
9396         ireq=ireq+1
9397         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9398      &    FG_COMM,req(ireq),IERR)
9399       enddo
9400 c      write (iout,*) "IRECV ended"
9401 c      call flush(iout)
9402 C Send the number of contacts needed by other processors
9403       do ii=1,ntask_cont_to
9404         iproc=itask_cont_to(ii)
9405         ireq=ireq+1
9406         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9407      &    FG_COMM,req(ireq),IERR)
9408       enddo
9409 c      write (iout,*) "ISEND ended"
9410 c      write (iout,*) "number of requests (nn)",ireq
9411 c      call flush(iout)
9412       if (ireq.gt.0)
9413      &  call MPI_Waitall(ireq,req,status_array,ierr)
9414 c      write (iout,*)
9415 c     &  "Numbers of contacts to be received from other processors",
9416 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9417 c      call flush(iout)
9418 C Receive contacts
9419       ireq=0
9420       do ii=1,ntask_cont_from
9421         iproc=itask_cont_from(ii)
9422         nn=ncont_recv(ii)
9423 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9424 c     &   " of CONT_TO_COMM group"
9425 c        call flush(iout)
9426         if (nn.gt.0) then
9427           ireq=ireq+1
9428           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9429      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9430 c          write (iout,*) "ireq,req",ireq,req(ireq)
9431         endif
9432       enddo
9433 C Send the contacts to processors that need them
9434       do ii=1,ntask_cont_to
9435         iproc=itask_cont_to(ii)
9436         nn=ncont_sent(ii)
9437 c        write (iout,*) nn," contacts to processor",iproc,
9438 c     &   " of CONT_TO_COMM group"
9439         if (nn.gt.0) then
9440           ireq=ireq+1
9441           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9442      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9443 c          write (iout,*) "ireq,req",ireq,req(ireq)
9444 c          do i=1,nn
9445 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9446 c          enddo
9447         endif
9448       enddo
9449 c      write (iout,*) "number of requests (contacts)",ireq
9450 c      write (iout,*) "req",(req(i),i=1,4)
9451 c      call flush(iout)
9452       if (ireq.gt.0)
9453      & call MPI_Waitall(ireq,req,status_array,ierr)
9454       do iii=1,ntask_cont_from
9455         iproc=itask_cont_from(iii)
9456         nn=ncont_recv(iii)
9457         if (lprn) then
9458         write (iout,*) "Received",nn," contacts from processor",iproc,
9459      &   " of CONT_FROM_COMM group"
9460         call flush(iout)
9461         do i=1,nn
9462           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9463         enddo
9464         call flush(iout)
9465         endif
9466         do i=1,nn
9467           ii=zapas_recv(1,i,iii)
9468 c Flag the received contacts to prevent double-counting
9469           jj=-zapas_recv(2,i,iii)
9470 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9471 c          call flush(iout)
9472           nnn=num_cont_hb(ii)+1
9473           num_cont_hb(ii)=nnn
9474           jcont_hb(nnn,ii)=jj
9475           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9476           ind=3
9477           do kk=1,3
9478             ind=ind+1
9479             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9480           enddo
9481           do kk=1,2
9482             do ll=1,2
9483               ind=ind+1
9484               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9485             enddo
9486           enddo
9487           do jj=1,5
9488             do kk=1,3
9489               do ll=1,2
9490                 do mm=1,2
9491                   ind=ind+1
9492                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9493                 enddo
9494               enddo
9495             enddo
9496           enddo
9497         enddo
9498       enddo
9499       if (lprn) then
9500         write (iout,'(a)') 'Contact function values after receive:'
9501         do i=nnt,nct-2
9502           write (iout,'(2i3,50(1x,i3,5f6.3))')
9503      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9504      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9505         enddo
9506         call flush(iout)
9507       endif
9508    30 continue
9509 #endif
9510       if (lprn) then
9511         write (iout,'(a)') 'Contact function values:'
9512         do i=nnt,nct-2
9513           write (iout,'(2i3,50(1x,i2,5f6.3))')
9514      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9515      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9516         enddo
9517       endif
9518       ecorr=0.0D0
9519       ecorr5=0.0d0
9520       ecorr6=0.0d0
9521 C Remove the loop below after debugging !!!
9522       do i=nnt,nct
9523         do j=1,3
9524           gradcorr(j,i)=0.0D0
9525           gradxorr(j,i)=0.0D0
9526         enddo
9527       enddo
9528 C Calculate the dipole-dipole interaction energies
9529       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9530       do i=iatel_s,iatel_e+1
9531         num_conti=num_cont_hb(i)
9532         do jj=1,num_conti
9533           j=jcont_hb(jj,i)
9534 #ifdef MOMENT
9535           call dipole(i,j,jj)
9536 #endif
9537         enddo
9538       enddo
9539       endif
9540 C Calculate the local-electrostatic correlation terms
9541 c                write (iout,*) "gradcorr5 in eello5 before loop"
9542 c                do iii=1,nres
9543 c                  write (iout,'(i5,3f10.5)')
9544 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9545 c                enddo
9546       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9547 c        write (iout,*) "corr loop i",i
9548         i1=i+1
9549         num_conti=num_cont_hb(i)
9550         num_conti1=num_cont_hb(i+1)
9551         do jj=1,num_conti
9552           j=jcont_hb(jj,i)
9553           jp=iabs(j)
9554           do kk=1,num_conti1
9555             j1=jcont_hb(kk,i1)
9556             jp1=iabs(j1)
9557 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9558 c     &         ' jj=',jj,' kk=',kk
9559 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9560             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9561      &          .or. j.lt.0 .and. j1.gt.0) .and.
9562      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9563 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9564 C The system gains extra energy.
9565               n_corr=n_corr+1
9566               sqd1=dsqrt(d_cont(jj,i))
9567               sqd2=dsqrt(d_cont(kk,i1))
9568               sred_geom = sqd1*sqd2
9569               IF (sred_geom.lt.cutoff_corr) THEN
9570                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9571      &            ekont,fprimcont)
9572 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9573 cd     &         ' jj=',jj,' kk=',kk
9574                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9575                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9576                 do l=1,3
9577                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9578                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9579                 enddo
9580                 n_corr1=n_corr1+1
9581 cd               write (iout,*) 'sred_geom=',sred_geom,
9582 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9583 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9584 cd               write (iout,*) "g_contij",g_contij
9585 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9586 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9587                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9588                 if (wcorr4.gt.0.0d0)
9589      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9590 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9591                   if (energy_dec.and.wcorr4.gt.0.0d0)
9592      1                 write (iout,'(a6,4i5,0pf7.3)')
9593      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9594 c                write (iout,*) "gradcorr5 before eello5"
9595 c                do iii=1,nres
9596 c                  write (iout,'(i5,3f10.5)')
9597 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9598 c                enddo
9599                 if (wcorr5.gt.0.0d0)
9600      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9601 c                write (iout,*) "gradcorr5 after eello5"
9602 c                do iii=1,nres
9603 c                  write (iout,'(i5,3f10.5)')
9604 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9605 c                enddo
9606                   if (energy_dec.and.wcorr5.gt.0.0d0)
9607      1                 write (iout,'(a6,4i5,0pf7.3)')
9608      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9609 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9610 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9611                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9612      &               .or. wturn6.eq.0.0d0))then
9613 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9614                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9615                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9616      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9617 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9618 cd     &            'ecorr6=',ecorr6
9619 cd                write (iout,'(4e15.5)') sred_geom,
9620 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9621 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9622 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9623                 else if (wturn6.gt.0.0d0
9624      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9625 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9626                   eturn6=eturn6+eello_turn6(i,jj,kk)
9627                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9628      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9629 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9630                 endif
9631               ENDIF
9632 1111          continue
9633             endif
9634           enddo ! kk
9635         enddo ! jj
9636       enddo ! i
9637       do i=1,nres
9638         num_cont_hb(i)=num_cont_hb_old(i)
9639       enddo
9640 c                write (iout,*) "gradcorr5 in eello5"
9641 c                do iii=1,nres
9642 c                  write (iout,'(i5,3f10.5)')
9643 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9644 c                enddo
9645       return
9646       end
9647 c------------------------------------------------------------------------------
9648       subroutine add_hb_contact_eello(ii,jj,itask)
9649       implicit real*8 (a-h,o-z)
9650       include "DIMENSIONS"
9651       include "COMMON.IOUNITS"
9652       integer max_cont
9653       integer max_dim
9654       parameter (max_cont=maxconts)
9655       parameter (max_dim=70)
9656       include "COMMON.CONTACTS"
9657       include 'COMMON.CONTMAT'
9658       include 'COMMON.CORRMAT'
9659       double precision zapas(max_dim,maxconts,max_fg_procs),
9660      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9661       common /przechowalnia/ zapas
9662       integer i,j,ii,jj,iproc,itask(4),nn
9663 c      write (iout,*) "itask",itask
9664       do i=1,2
9665         iproc=itask(i)
9666         if (iproc.gt.0) then
9667           do j=1,num_cont_hb(ii)
9668             jjc=jcont_hb(j,ii)
9669 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9670             if (jjc.eq.jj) then
9671               ncont_sent(iproc)=ncont_sent(iproc)+1
9672               nn=ncont_sent(iproc)
9673               zapas(1,nn,iproc)=ii
9674               zapas(2,nn,iproc)=jjc
9675               zapas(3,nn,iproc)=d_cont(j,ii)
9676               ind=3
9677               do kk=1,3
9678                 ind=ind+1
9679                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9680               enddo
9681               do kk=1,2
9682                 do ll=1,2
9683                   ind=ind+1
9684                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9685                 enddo
9686               enddo
9687               do jj=1,5
9688                 do kk=1,3
9689                   do ll=1,2
9690                     do mm=1,2
9691                       ind=ind+1
9692                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9693                     enddo
9694                   enddo
9695                 enddo
9696               enddo
9697               exit
9698             endif
9699           enddo
9700         endif
9701       enddo
9702       return
9703       end
9704 c------------------------------------------------------------------------------
9705       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9706       implicit real*8 (a-h,o-z)
9707       include 'DIMENSIONS'
9708       include 'COMMON.IOUNITS'
9709       include 'COMMON.DERIV'
9710       include 'COMMON.INTERACT'
9711       include 'COMMON.CONTACTS'
9712       include 'COMMON.CONTMAT'
9713       include 'COMMON.CORRMAT'
9714       include 'COMMON.SHIELD'
9715       include 'COMMON.CONTROL'
9716       double precision gx(3),gx1(3)
9717       logical lprn
9718       lprn=.false.
9719 C      print *,"wchodze",fac_shield(i),shield_mode
9720       eij=facont_hb(jj,i)
9721       ekl=facont_hb(kk,k)
9722       ees0pij=ees0p(jj,i)
9723       ees0pkl=ees0p(kk,k)
9724       ees0mij=ees0m(jj,i)
9725       ees0mkl=ees0m(kk,k)
9726       ekont=eij*ekl
9727       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9728 C*
9729 C     & fac_shield(i)**2*fac_shield(j)**2
9730 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9731 C Following 4 lines for diagnostics.
9732 cd    ees0pkl=0.0D0
9733 cd    ees0pij=1.0D0
9734 cd    ees0mkl=0.0D0
9735 cd    ees0mij=1.0D0
9736 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9737 c     & 'Contacts ',i,j,
9738 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9739 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9740 c     & 'gradcorr_long'
9741 C Calculate the multi-body contribution to energy.
9742 C      ecorr=ecorr+ekont*ees
9743 C Calculate multi-body contributions to the gradient.
9744       coeffpees0pij=coeffp*ees0pij
9745       coeffmees0mij=coeffm*ees0mij
9746       coeffpees0pkl=coeffp*ees0pkl
9747       coeffmees0mkl=coeffm*ees0mkl
9748       do ll=1,3
9749 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9750         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9751      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9752      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9753         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9754      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9755      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9756 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9757         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9758      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9759      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9760         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9761      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9762      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9763         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9764      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9765      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9766         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9767         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9768         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9769      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9770      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9771         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9772         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9773 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9774       enddo
9775 c      write (iout,*)
9776 cgrad      do m=i+1,j-1
9777 cgrad        do ll=1,3
9778 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9779 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9780 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9781 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9782 cgrad        enddo
9783 cgrad      enddo
9784 cgrad      do m=k+1,l-1
9785 cgrad        do ll=1,3
9786 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9787 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9788 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9789 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9790 cgrad        enddo
9791 cgrad      enddo
9792 c      write (iout,*) "ehbcorr",ekont*ees
9793 C      print *,ekont,ees,i,k
9794       ehbcorr=ekont*ees
9795 C now gradient over shielding
9796 C      return
9797       if (shield_mode.gt.0) then
9798        j=ees0plist(jj,i)
9799        l=ees0plist(kk,k)
9800 C        print *,i,j,fac_shield(i),fac_shield(j),
9801 C     &fac_shield(k),fac_shield(l)
9802         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9803      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9804           do ilist=1,ishield_list(i)
9805            iresshield=shield_list(ilist,i)
9806            do m=1,3
9807            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9808 C     &      *2.0
9809            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9810      &              rlocshield
9811      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9812             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9813      &+rlocshield
9814            enddo
9815           enddo
9816           do ilist=1,ishield_list(j)
9817            iresshield=shield_list(ilist,j)
9818            do m=1,3
9819            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9820 C     &     *2.0
9821            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9822      &              rlocshield
9823      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9824            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9825      &     +rlocshield
9826            enddo
9827           enddo
9828
9829           do ilist=1,ishield_list(k)
9830            iresshield=shield_list(ilist,k)
9831            do m=1,3
9832            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9833 C     &     *2.0
9834            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9835      &              rlocshield
9836      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9837            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9838      &     +rlocshield
9839            enddo
9840           enddo
9841           do ilist=1,ishield_list(l)
9842            iresshield=shield_list(ilist,l)
9843            do m=1,3
9844            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9845 C     &     *2.0
9846            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9847      &              rlocshield
9848      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9849            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9850      &     +rlocshield
9851            enddo
9852           enddo
9853 C          print *,gshieldx(m,iresshield)
9854           do m=1,3
9855             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9856      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9857             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9858      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9859             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9860      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9861             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9862      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9863
9864             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9865      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9866             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9867      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9868             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9869      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9870             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9871      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9872
9873            enddo
9874       endif
9875       endif
9876       return
9877       end
9878 #ifdef MOMENT
9879 C---------------------------------------------------------------------------
9880       subroutine dipole(i,j,jj)
9881       implicit real*8 (a-h,o-z)
9882       include 'DIMENSIONS'
9883       include 'COMMON.IOUNITS'
9884       include 'COMMON.CHAIN'
9885       include 'COMMON.FFIELD'
9886       include 'COMMON.DERIV'
9887       include 'COMMON.INTERACT'
9888       include 'COMMON.CONTACTS'
9889       include 'COMMON.CONTMAT'
9890       include 'COMMON.CORRMAT'
9891       include 'COMMON.TORSION'
9892       include 'COMMON.VAR'
9893       include 'COMMON.GEO'
9894       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9895      &  auxmat(2,2)
9896       iti1 = itortyp(itype(i+1))
9897       if (j.lt.nres-1) then
9898         itj1 = itype2loc(itype(j+1))
9899       else
9900         itj1=nloctyp
9901       endif
9902       do iii=1,2
9903         dipi(iii,1)=Ub2(iii,i)
9904         dipderi(iii)=Ub2der(iii,i)
9905         dipi(iii,2)=b1(iii,i+1)
9906         dipj(iii,1)=Ub2(iii,j)
9907         dipderj(iii)=Ub2der(iii,j)
9908         dipj(iii,2)=b1(iii,j+1)
9909       enddo
9910       kkk=0
9911       do iii=1,2
9912         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9913         do jjj=1,2
9914           kkk=kkk+1
9915           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9916         enddo
9917       enddo
9918       do kkk=1,5
9919         do lll=1,3
9920           mmm=0
9921           do iii=1,2
9922             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9923      &        auxvec(1))
9924             do jjj=1,2
9925               mmm=mmm+1
9926               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9927             enddo
9928           enddo
9929         enddo
9930       enddo
9931       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9932       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9933       do iii=1,2
9934         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9935       enddo
9936       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9937       do iii=1,2
9938         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9939       enddo
9940       return
9941       end
9942 #endif
9943 C---------------------------------------------------------------------------
9944       subroutine calc_eello(i,j,k,l,jj,kk)
9945 C
9946 C This subroutine computes matrices and vectors needed to calculate
9947 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9948 C
9949       implicit real*8 (a-h,o-z)
9950       include 'DIMENSIONS'
9951       include 'COMMON.IOUNITS'
9952       include 'COMMON.CHAIN'
9953       include 'COMMON.DERIV'
9954       include 'COMMON.INTERACT'
9955       include 'COMMON.CONTACTS'
9956       include 'COMMON.CONTMAT'
9957       include 'COMMON.CORRMAT'
9958       include 'COMMON.TORSION'
9959       include 'COMMON.VAR'
9960       include 'COMMON.GEO'
9961       include 'COMMON.FFIELD'
9962       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9963      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9964       logical lprn
9965       common /kutas/ lprn
9966 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9967 cd     & ' jj=',jj,' kk=',kk
9968 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9969 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9970 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9971       do iii=1,2
9972         do jjj=1,2
9973           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9974           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9975         enddo
9976       enddo
9977       call transpose2(aa1(1,1),aa1t(1,1))
9978       call transpose2(aa2(1,1),aa2t(1,1))
9979       do kkk=1,5
9980         do lll=1,3
9981           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9982      &      aa1tder(1,1,lll,kkk))
9983           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9984      &      aa2tder(1,1,lll,kkk))
9985         enddo
9986       enddo
9987       if (l.eq.j+1) then
9988 C parallel orientation of the two CA-CA-CA frames.
9989         if (i.gt.1) then
9990           iti=itype2loc(itype(i))
9991         else
9992           iti=nloctyp
9993         endif
9994         itk1=itype2loc(itype(k+1))
9995         itj=itype2loc(itype(j))
9996         if (l.lt.nres-1) then
9997           itl1=itype2loc(itype(l+1))
9998         else
9999           itl1=nloctyp
10000         endif
10001 C A1 kernel(j+1) A2T
10002 cd        do iii=1,2
10003 cd          write (iout,'(3f10.5,5x,3f10.5)')
10004 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10005 cd        enddo
10006         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10007      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10008      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10009 C Following matrices are needed only for 6-th order cumulants
10010         IF (wcorr6.gt.0.0d0) THEN
10011         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10012      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10013      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10014         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10015      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10016      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10017      &   ADtEAderx(1,1,1,1,1,1))
10018         lprn=.false.
10019         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10020      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10021      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10022      &   ADtEA1derx(1,1,1,1,1,1))
10023         ENDIF
10024 C End 6-th order cumulants
10025 cd        lprn=.false.
10026 cd        if (lprn) then
10027 cd        write (2,*) 'In calc_eello6'
10028 cd        do iii=1,2
10029 cd          write (2,*) 'iii=',iii
10030 cd          do kkk=1,5
10031 cd            write (2,*) 'kkk=',kkk
10032 cd            do jjj=1,2
10033 cd              write (2,'(3(2f10.5),5x)')
10034 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10035 cd            enddo
10036 cd          enddo
10037 cd        enddo
10038 cd        endif
10039         call transpose2(EUgder(1,1,k),auxmat(1,1))
10040         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10041         call transpose2(EUg(1,1,k),auxmat(1,1))
10042         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10043         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10044 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10045 c    in theta; to be sriten later.
10046 c#ifdef NEWCORR
10047 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
10048 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10049 c        call transpose2(EUg(1,1,k),auxmat(1,1))
10050 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10051 c#endif
10052         do iii=1,2
10053           do kkk=1,5
10054             do lll=1,3
10055               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10056      &          EAEAderx(1,1,lll,kkk,iii,1))
10057             enddo
10058           enddo
10059         enddo
10060 C A1T kernel(i+1) A2
10061         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10062      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10063      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10064 C Following matrices are needed only for 6-th order cumulants
10065         IF (wcorr6.gt.0.0d0) THEN
10066         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10067      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10068      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10069         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10070      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10071      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10072      &   ADtEAderx(1,1,1,1,1,2))
10073         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10074      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10075      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10076      &   ADtEA1derx(1,1,1,1,1,2))
10077         ENDIF
10078 C End 6-th order cumulants
10079         call transpose2(EUgder(1,1,l),auxmat(1,1))
10080         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10081         call transpose2(EUg(1,1,l),auxmat(1,1))
10082         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10083         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10084         do iii=1,2
10085           do kkk=1,5
10086             do lll=1,3
10087               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10088      &          EAEAderx(1,1,lll,kkk,iii,2))
10089             enddo
10090           enddo
10091         enddo
10092 C AEAb1 and AEAb2
10093 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10094 C They are needed only when the fifth- or the sixth-order cumulants are
10095 C indluded.
10096         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10097         call transpose2(AEA(1,1,1),auxmat(1,1))
10098         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10099         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10100         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10101         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10102         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10103         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10104         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10105         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10106         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10107         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10108         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10109         call transpose2(AEA(1,1,2),auxmat(1,1))
10110         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10111         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10112         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10113         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10114         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10115         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10116         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10117         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10118         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10119         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10120         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10121 C Calculate the Cartesian derivatives of the vectors.
10122         do iii=1,2
10123           do kkk=1,5
10124             do lll=1,3
10125               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10126               call matvec2(auxmat(1,1),b1(1,i),
10127      &          AEAb1derx(1,lll,kkk,iii,1,1))
10128               call matvec2(auxmat(1,1),Ub2(1,i),
10129      &          AEAb2derx(1,lll,kkk,iii,1,1))
10130               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10131      &          AEAb1derx(1,lll,kkk,iii,2,1))
10132               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10133      &          AEAb2derx(1,lll,kkk,iii,2,1))
10134               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10135               call matvec2(auxmat(1,1),b1(1,j),
10136      &          AEAb1derx(1,lll,kkk,iii,1,2))
10137               call matvec2(auxmat(1,1),Ub2(1,j),
10138      &          AEAb2derx(1,lll,kkk,iii,1,2))
10139               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10140      &          AEAb1derx(1,lll,kkk,iii,2,2))
10141               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10142      &          AEAb2derx(1,lll,kkk,iii,2,2))
10143             enddo
10144           enddo
10145         enddo
10146         ENDIF
10147 C End vectors
10148       else
10149 C Antiparallel orientation of the two CA-CA-CA frames.
10150         if (i.gt.1) then
10151           iti=itype2loc(itype(i))
10152         else
10153           iti=nloctyp
10154         endif
10155         itk1=itype2loc(itype(k+1))
10156         itl=itype2loc(itype(l))
10157         itj=itype2loc(itype(j))
10158         if (j.lt.nres-1) then
10159           itj1=itype2loc(itype(j+1))
10160         else
10161           itj1=nloctyp
10162         endif
10163 C A2 kernel(j-1)T A1T
10164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10165      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10166      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10167 C Following matrices are needed only for 6-th order cumulants
10168         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10169      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10170         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10171      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10172      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10173         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10174      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10175      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10176      &   ADtEAderx(1,1,1,1,1,1))
10177         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10178      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10179      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10180      &   ADtEA1derx(1,1,1,1,1,1))
10181         ENDIF
10182 C End 6-th order cumulants
10183         call transpose2(EUgder(1,1,k),auxmat(1,1))
10184         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10185         call transpose2(EUg(1,1,k),auxmat(1,1))
10186         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10187         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10188         do iii=1,2
10189           do kkk=1,5
10190             do lll=1,3
10191               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10192      &          EAEAderx(1,1,lll,kkk,iii,1))
10193             enddo
10194           enddo
10195         enddo
10196 C A2T kernel(i+1)T A1
10197         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10198      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10199      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10200 C Following matrices are needed only for 6-th order cumulants
10201         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10202      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10203         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10204      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10205      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10206         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10207      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10208      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10209      &   ADtEAderx(1,1,1,1,1,2))
10210         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10211      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10212      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10213      &   ADtEA1derx(1,1,1,1,1,2))
10214         ENDIF
10215 C End 6-th order cumulants
10216         call transpose2(EUgder(1,1,j),auxmat(1,1))
10217         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10218         call transpose2(EUg(1,1,j),auxmat(1,1))
10219         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10220         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10221         do iii=1,2
10222           do kkk=1,5
10223             do lll=1,3
10224               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10225      &          EAEAderx(1,1,lll,kkk,iii,2))
10226             enddo
10227           enddo
10228         enddo
10229 C AEAb1 and AEAb2
10230 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10231 C They are needed only when the fifth- or the sixth-order cumulants are
10232 C indluded.
10233         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10234      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10235         call transpose2(AEA(1,1,1),auxmat(1,1))
10236         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10237         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10238         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10239         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10240         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10241         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10242         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10243         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10244         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10245         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10246         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10247         call transpose2(AEA(1,1,2),auxmat(1,1))
10248         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10249         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10250         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10251         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10252         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10253         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10254         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10255         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10256         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10257         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10258         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10259 C Calculate the Cartesian derivatives of the vectors.
10260         do iii=1,2
10261           do kkk=1,5
10262             do lll=1,3
10263               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10264               call matvec2(auxmat(1,1),b1(1,i),
10265      &          AEAb1derx(1,lll,kkk,iii,1,1))
10266               call matvec2(auxmat(1,1),Ub2(1,i),
10267      &          AEAb2derx(1,lll,kkk,iii,1,1))
10268               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10269      &          AEAb1derx(1,lll,kkk,iii,2,1))
10270               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10271      &          AEAb2derx(1,lll,kkk,iii,2,1))
10272               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10273               call matvec2(auxmat(1,1),b1(1,l),
10274      &          AEAb1derx(1,lll,kkk,iii,1,2))
10275               call matvec2(auxmat(1,1),Ub2(1,l),
10276      &          AEAb2derx(1,lll,kkk,iii,1,2))
10277               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10278      &          AEAb1derx(1,lll,kkk,iii,2,2))
10279               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10280      &          AEAb2derx(1,lll,kkk,iii,2,2))
10281             enddo
10282           enddo
10283         enddo
10284         ENDIF
10285 C End vectors
10286       endif
10287       return
10288       end
10289 C---------------------------------------------------------------------------
10290       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10291      &  KK,KKderg,AKA,AKAderg,AKAderx)
10292       implicit none
10293       integer nderg
10294       logical transp
10295       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10296      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10297      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10298       integer iii,kkk,lll
10299       integer jjj,mmm
10300       logical lprn
10301       common /kutas/ lprn
10302       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10303       do iii=1,nderg
10304         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10305      &    AKAderg(1,1,iii))
10306       enddo
10307 cd      if (lprn) write (2,*) 'In kernel'
10308       do kkk=1,5
10309 cd        if (lprn) write (2,*) 'kkk=',kkk
10310         do lll=1,3
10311           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10312      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10313 cd          if (lprn) then
10314 cd            write (2,*) 'lll=',lll
10315 cd            write (2,*) 'iii=1'
10316 cd            do jjj=1,2
10317 cd              write (2,'(3(2f10.5),5x)')
10318 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10319 cd            enddo
10320 cd          endif
10321           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10322      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10323 cd          if (lprn) then
10324 cd            write (2,*) 'lll=',lll
10325 cd            write (2,*) 'iii=2'
10326 cd            do jjj=1,2
10327 cd              write (2,'(3(2f10.5),5x)')
10328 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10329 cd            enddo
10330 cd          endif
10331         enddo
10332       enddo
10333       return
10334       end
10335 C---------------------------------------------------------------------------
10336       double precision function eello4(i,j,k,l,jj,kk)
10337       implicit real*8 (a-h,o-z)
10338       include 'DIMENSIONS'
10339       include 'COMMON.IOUNITS'
10340       include 'COMMON.CHAIN'
10341       include 'COMMON.DERIV'
10342       include 'COMMON.INTERACT'
10343       include 'COMMON.CONTACTS'
10344       include 'COMMON.CONTMAT'
10345       include 'COMMON.CORRMAT'
10346       include 'COMMON.TORSION'
10347       include 'COMMON.VAR'
10348       include 'COMMON.GEO'
10349       double precision pizda(2,2),ggg1(3),ggg2(3)
10350 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10351 cd        eello4=0.0d0
10352 cd        return
10353 cd      endif
10354 cd      print *,'eello4:',i,j,k,l,jj,kk
10355 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10356 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10357 cold      eij=facont_hb(jj,i)
10358 cold      ekl=facont_hb(kk,k)
10359 cold      ekont=eij*ekl
10360       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10361 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10362       gcorr_loc(k-1)=gcorr_loc(k-1)
10363      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10364       if (l.eq.j+1) then
10365         gcorr_loc(l-1)=gcorr_loc(l-1)
10366      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10367 C Al 4/16/16: Derivatives in theta, to be added later.
10368 c#ifdef NEWCORR
10369 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10370 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10371 c#endif
10372       else
10373         gcorr_loc(j-1)=gcorr_loc(j-1)
10374      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10375 c#ifdef NEWCORR
10376 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10377 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10378 c#endif
10379       endif
10380       do iii=1,2
10381         do kkk=1,5
10382           do lll=1,3
10383             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10384      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10385 cd            derx(lll,kkk,iii)=0.0d0
10386           enddo
10387         enddo
10388       enddo
10389 cd      gcorr_loc(l-1)=0.0d0
10390 cd      gcorr_loc(j-1)=0.0d0
10391 cd      gcorr_loc(k-1)=0.0d0
10392 cd      eel4=1.0d0
10393 cd      write (iout,*)'Contacts have occurred for peptide groups',
10394 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10395 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10396       if (j.lt.nres-1) then
10397         j1=j+1
10398         j2=j-1
10399       else
10400         j1=j-1
10401         j2=j-2
10402       endif
10403       if (l.lt.nres-1) then
10404         l1=l+1
10405         l2=l-1
10406       else
10407         l1=l-1
10408         l2=l-2
10409       endif
10410       do ll=1,3
10411 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10412 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10413         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10414         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10415 cgrad        ghalf=0.5d0*ggg1(ll)
10416         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10417         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10418         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10419         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10420         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10421         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10422 cgrad        ghalf=0.5d0*ggg2(ll)
10423         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10424         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10425         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10426         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10427         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10428         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10429       enddo
10430 cgrad      do m=i+1,j-1
10431 cgrad        do ll=1,3
10432 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10433 cgrad        enddo
10434 cgrad      enddo
10435 cgrad      do m=k+1,l-1
10436 cgrad        do ll=1,3
10437 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10438 cgrad        enddo
10439 cgrad      enddo
10440 cgrad      do m=i+2,j2
10441 cgrad        do ll=1,3
10442 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10443 cgrad        enddo
10444 cgrad      enddo
10445 cgrad      do m=k+2,l2
10446 cgrad        do ll=1,3
10447 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10448 cgrad        enddo
10449 cgrad      enddo
10450 cd      do iii=1,nres-3
10451 cd        write (2,*) iii,gcorr_loc(iii)
10452 cd      enddo
10453       eello4=ekont*eel4
10454 cd      write (2,*) 'ekont',ekont
10455 cd      write (iout,*) 'eello4',ekont*eel4
10456       return
10457       end
10458 C---------------------------------------------------------------------------
10459       double precision function eello5(i,j,k,l,jj,kk)
10460       implicit real*8 (a-h,o-z)
10461       include 'DIMENSIONS'
10462       include 'COMMON.IOUNITS'
10463       include 'COMMON.CHAIN'
10464       include 'COMMON.DERIV'
10465       include 'COMMON.INTERACT'
10466       include 'COMMON.CONTACTS'
10467       include 'COMMON.CONTMAT'
10468       include 'COMMON.CORRMAT'
10469       include 'COMMON.TORSION'
10470       include 'COMMON.VAR'
10471       include 'COMMON.GEO'
10472       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10473       double precision ggg1(3),ggg2(3)
10474 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10475 C                                                                              C
10476 C                            Parallel chains                                   C
10477 C                                                                              C
10478 C          o             o                   o             o                   C
10479 C         /l\           / \             \   / \           / \   /              C
10480 C        /   \         /   \             \ /   \         /   \ /               C
10481 C       j| o |l1       | o |              o| o |         | o |o                C
10482 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10483 C      \i/   \         /   \ /             /   \         /   \                 C
10484 C       o    k1             o                                                  C
10485 C         (I)          (II)                (III)          (IV)                 C
10486 C                                                                              C
10487 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10488 C                                                                              C
10489 C                            Antiparallel chains                               C
10490 C                                                                              C
10491 C          o             o                   o             o                   C
10492 C         /j\           / \             \   / \           / \   /              C
10493 C        /   \         /   \             \ /   \         /   \ /               C
10494 C      j1| o |l        | o |              o| o |         | o |o                C
10495 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10496 C      \i/   \         /   \ /             /   \         /   \                 C
10497 C       o     k1            o                                                  C
10498 C         (I)          (II)                (III)          (IV)                 C
10499 C                                                                              C
10500 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10501 C                                                                              C
10502 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10503 C                                                                              C
10504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10505 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10506 cd        eello5=0.0d0
10507 cd        return
10508 cd      endif
10509 cd      write (iout,*)
10510 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10511 cd     &   ' and',k,l
10512       itk=itype2loc(itype(k))
10513       itl=itype2loc(itype(l))
10514       itj=itype2loc(itype(j))
10515       eello5_1=0.0d0
10516       eello5_2=0.0d0
10517       eello5_3=0.0d0
10518       eello5_4=0.0d0
10519 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10520 cd     &   eel5_3_num,eel5_4_num)
10521       do iii=1,2
10522         do kkk=1,5
10523           do lll=1,3
10524             derx(lll,kkk,iii)=0.0d0
10525           enddo
10526         enddo
10527       enddo
10528 cd      eij=facont_hb(jj,i)
10529 cd      ekl=facont_hb(kk,k)
10530 cd      ekont=eij*ekl
10531 cd      write (iout,*)'Contacts have occurred for peptide groups',
10532 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10533 cd      goto 1111
10534 C Contribution from the graph I.
10535 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10536 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10537       call transpose2(EUg(1,1,k),auxmat(1,1))
10538       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10539       vv(1)=pizda(1,1)-pizda(2,2)
10540       vv(2)=pizda(1,2)+pizda(2,1)
10541       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10542      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10543 C Explicit gradient in virtual-dihedral angles.
10544       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10545      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10546      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10547       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10548       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10549       vv(1)=pizda(1,1)-pizda(2,2)
10550       vv(2)=pizda(1,2)+pizda(2,1)
10551       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10552      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10553      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10554       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10555       vv(1)=pizda(1,1)-pizda(2,2)
10556       vv(2)=pizda(1,2)+pizda(2,1)
10557       if (l.eq.j+1) then
10558         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10559      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10560      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10561       else
10562         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10563      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10564      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10565       endif
10566 C Cartesian gradient
10567       do iii=1,2
10568         do kkk=1,5
10569           do lll=1,3
10570             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10571      &        pizda(1,1))
10572             vv(1)=pizda(1,1)-pizda(2,2)
10573             vv(2)=pizda(1,2)+pizda(2,1)
10574             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10575      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10576      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10577           enddo
10578         enddo
10579       enddo
10580 c      goto 1112
10581 c1111  continue
10582 C Contribution from graph II
10583       call transpose2(EE(1,1,k),auxmat(1,1))
10584       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10585       vv(1)=pizda(1,1)+pizda(2,2)
10586       vv(2)=pizda(2,1)-pizda(1,2)
10587       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10588      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10589 C Explicit gradient in virtual-dihedral angles.
10590       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10591      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10592       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10593       vv(1)=pizda(1,1)+pizda(2,2)
10594       vv(2)=pizda(2,1)-pizda(1,2)
10595       if (l.eq.j+1) then
10596         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10597      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10598      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10599       else
10600         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10601      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10602      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10603       endif
10604 C Cartesian gradient
10605       do iii=1,2
10606         do kkk=1,5
10607           do lll=1,3
10608             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10609      &        pizda(1,1))
10610             vv(1)=pizda(1,1)+pizda(2,2)
10611             vv(2)=pizda(2,1)-pizda(1,2)
10612             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10613      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10614      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10615           enddo
10616         enddo
10617       enddo
10618 cd      goto 1112
10619 cd1111  continue
10620       if (l.eq.j+1) then
10621 cd        goto 1110
10622 C Parallel orientation
10623 C Contribution from graph III
10624         call transpose2(EUg(1,1,l),auxmat(1,1))
10625         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10626         vv(1)=pizda(1,1)-pizda(2,2)
10627         vv(2)=pizda(1,2)+pizda(2,1)
10628         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10629      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10630 C Explicit gradient in virtual-dihedral angles.
10631         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10632      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10633      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10634         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10635         vv(1)=pizda(1,1)-pizda(2,2)
10636         vv(2)=pizda(1,2)+pizda(2,1)
10637         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10638      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10639      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10640         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10641         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10642         vv(1)=pizda(1,1)-pizda(2,2)
10643         vv(2)=pizda(1,2)+pizda(2,1)
10644         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10645      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10646      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10647 C Cartesian gradient
10648         do iii=1,2
10649           do kkk=1,5
10650             do lll=1,3
10651               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10652      &          pizda(1,1))
10653               vv(1)=pizda(1,1)-pizda(2,2)
10654               vv(2)=pizda(1,2)+pizda(2,1)
10655               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10656      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10657      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10658             enddo
10659           enddo
10660         enddo
10661 cd        goto 1112
10662 C Contribution from graph IV
10663 cd1110    continue
10664         call transpose2(EE(1,1,l),auxmat(1,1))
10665         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10666         vv(1)=pizda(1,1)+pizda(2,2)
10667         vv(2)=pizda(2,1)-pizda(1,2)
10668         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10669      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10670 C Explicit gradient in virtual-dihedral angles.
10671         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10672      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10673         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10674         vv(1)=pizda(1,1)+pizda(2,2)
10675         vv(2)=pizda(2,1)-pizda(1,2)
10676         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10677      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10678      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10679 C Cartesian gradient
10680         do iii=1,2
10681           do kkk=1,5
10682             do lll=1,3
10683               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10684      &          pizda(1,1))
10685               vv(1)=pizda(1,1)+pizda(2,2)
10686               vv(2)=pizda(2,1)-pizda(1,2)
10687               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10688      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10689      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10690             enddo
10691           enddo
10692         enddo
10693       else
10694 C Antiparallel orientation
10695 C Contribution from graph III
10696 c        goto 1110
10697         call transpose2(EUg(1,1,j),auxmat(1,1))
10698         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10699         vv(1)=pizda(1,1)-pizda(2,2)
10700         vv(2)=pizda(1,2)+pizda(2,1)
10701         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10702      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10703 C Explicit gradient in virtual-dihedral angles.
10704         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10705      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10706      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10707         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10708         vv(1)=pizda(1,1)-pizda(2,2)
10709         vv(2)=pizda(1,2)+pizda(2,1)
10710         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10711      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10712      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10713         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10714         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10715         vv(1)=pizda(1,1)-pizda(2,2)
10716         vv(2)=pizda(1,2)+pizda(2,1)
10717         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10718      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10719      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10720 C Cartesian gradient
10721         do iii=1,2
10722           do kkk=1,5
10723             do lll=1,3
10724               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10725      &          pizda(1,1))
10726               vv(1)=pizda(1,1)-pizda(2,2)
10727               vv(2)=pizda(1,2)+pizda(2,1)
10728               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10729      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10730      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10731             enddo
10732           enddo
10733         enddo
10734 cd        goto 1112
10735 C Contribution from graph IV
10736 1110    continue
10737         call transpose2(EE(1,1,j),auxmat(1,1))
10738         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10739         vv(1)=pizda(1,1)+pizda(2,2)
10740         vv(2)=pizda(2,1)-pizda(1,2)
10741         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10742      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10743 C Explicit gradient in virtual-dihedral angles.
10744         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10745      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10746         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10747         vv(1)=pizda(1,1)+pizda(2,2)
10748         vv(2)=pizda(2,1)-pizda(1,2)
10749         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10750      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10751      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10752 C Cartesian gradient
10753         do iii=1,2
10754           do kkk=1,5
10755             do lll=1,3
10756               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10757      &          pizda(1,1))
10758               vv(1)=pizda(1,1)+pizda(2,2)
10759               vv(2)=pizda(2,1)-pizda(1,2)
10760               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10761      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10762      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10763             enddo
10764           enddo
10765         enddo
10766       endif
10767 1112  continue
10768       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10769 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10770 cd        write (2,*) 'ijkl',i,j,k,l
10771 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10772 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10773 cd      endif
10774 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10775 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10776 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10777 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10778       if (j.lt.nres-1) then
10779         j1=j+1
10780         j2=j-1
10781       else
10782         j1=j-1
10783         j2=j-2
10784       endif
10785       if (l.lt.nres-1) then
10786         l1=l+1
10787         l2=l-1
10788       else
10789         l1=l-1
10790         l2=l-2
10791       endif
10792 cd      eij=1.0d0
10793 cd      ekl=1.0d0
10794 cd      ekont=1.0d0
10795 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10796 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10797 C        summed up outside the subrouine as for the other subroutines
10798 C        handling long-range interactions. The old code is commented out
10799 C        with "cgrad" to keep track of changes.
10800       do ll=1,3
10801 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10802 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10803         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10804         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10805 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10806 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10807 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10808 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10809 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10810 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10811 c     &   gradcorr5ij,
10812 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10813 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10814 cgrad        ghalf=0.5d0*ggg1(ll)
10815 cd        ghalf=0.0d0
10816         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10817         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10818         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10819         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10820         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10821         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10822 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10823 cgrad        ghalf=0.5d0*ggg2(ll)
10824 cd        ghalf=0.0d0
10825         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10826         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10827         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10828         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10829         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10830         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10831       enddo
10832 cd      goto 1112
10833 cgrad      do m=i+1,j-1
10834 cgrad        do ll=1,3
10835 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10836 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10837 cgrad        enddo
10838 cgrad      enddo
10839 cgrad      do m=k+1,l-1
10840 cgrad        do ll=1,3
10841 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10842 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10843 cgrad        enddo
10844 cgrad      enddo
10845 c1112  continue
10846 cgrad      do m=i+2,j2
10847 cgrad        do ll=1,3
10848 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10849 cgrad        enddo
10850 cgrad      enddo
10851 cgrad      do m=k+2,l2
10852 cgrad        do ll=1,3
10853 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10854 cgrad        enddo
10855 cgrad      enddo
10856 cd      do iii=1,nres-3
10857 cd        write (2,*) iii,g_corr5_loc(iii)
10858 cd      enddo
10859       eello5=ekont*eel5
10860 cd      write (2,*) 'ekont',ekont
10861 cd      write (iout,*) 'eello5',ekont*eel5
10862       return
10863       end
10864 c--------------------------------------------------------------------------
10865       double precision function eello6(i,j,k,l,jj,kk)
10866       implicit real*8 (a-h,o-z)
10867       include 'DIMENSIONS'
10868       include 'COMMON.IOUNITS'
10869       include 'COMMON.CHAIN'
10870       include 'COMMON.DERIV'
10871       include 'COMMON.INTERACT'
10872       include 'COMMON.CONTACTS'
10873       include 'COMMON.CONTMAT'
10874       include 'COMMON.CORRMAT'
10875       include 'COMMON.TORSION'
10876       include 'COMMON.VAR'
10877       include 'COMMON.GEO'
10878       include 'COMMON.FFIELD'
10879       double precision ggg1(3),ggg2(3)
10880 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10881 cd        eello6=0.0d0
10882 cd        return
10883 cd      endif
10884 cd      write (iout,*)
10885 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10886 cd     &   ' and',k,l
10887       eello6_1=0.0d0
10888       eello6_2=0.0d0
10889       eello6_3=0.0d0
10890       eello6_4=0.0d0
10891       eello6_5=0.0d0
10892       eello6_6=0.0d0
10893 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10894 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10895       do iii=1,2
10896         do kkk=1,5
10897           do lll=1,3
10898             derx(lll,kkk,iii)=0.0d0
10899           enddo
10900         enddo
10901       enddo
10902 cd      eij=facont_hb(jj,i)
10903 cd      ekl=facont_hb(kk,k)
10904 cd      ekont=eij*ekl
10905 cd      eij=1.0d0
10906 cd      ekl=1.0d0
10907 cd      ekont=1.0d0
10908       if (l.eq.j+1) then
10909         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10910         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10911         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10912         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10913         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10914         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10915       else
10916         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10917         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10918         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10919         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10920         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10921           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10922         else
10923           eello6_5=0.0d0
10924         endif
10925         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10926       endif
10927 C If turn contributions are considered, they will be handled separately.
10928       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10929 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10930 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10931 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10932 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10933 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10934 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10935 cd      goto 1112
10936       if (j.lt.nres-1) then
10937         j1=j+1
10938         j2=j-1
10939       else
10940         j1=j-1
10941         j2=j-2
10942       endif
10943       if (l.lt.nres-1) then
10944         l1=l+1
10945         l2=l-1
10946       else
10947         l1=l-1
10948         l2=l-2
10949       endif
10950       do ll=1,3
10951 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10952 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10953 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10954 cgrad        ghalf=0.5d0*ggg1(ll)
10955 cd        ghalf=0.0d0
10956         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10957         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10958         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10959         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10960         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10961         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10962         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10963         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10964 cgrad        ghalf=0.5d0*ggg2(ll)
10965 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10966 cd        ghalf=0.0d0
10967         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10968         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10969         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10970         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10971         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10972         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10973       enddo
10974 cd      goto 1112
10975 cgrad      do m=i+1,j-1
10976 cgrad        do ll=1,3
10977 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10978 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10979 cgrad        enddo
10980 cgrad      enddo
10981 cgrad      do m=k+1,l-1
10982 cgrad        do ll=1,3
10983 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10984 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10985 cgrad        enddo
10986 cgrad      enddo
10987 cgrad1112  continue
10988 cgrad      do m=i+2,j2
10989 cgrad        do ll=1,3
10990 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10991 cgrad        enddo
10992 cgrad      enddo
10993 cgrad      do m=k+2,l2
10994 cgrad        do ll=1,3
10995 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10996 cgrad        enddo
10997 cgrad      enddo
10998 cd      do iii=1,nres-3
10999 cd        write (2,*) iii,g_corr6_loc(iii)
11000 cd      enddo
11001       eello6=ekont*eel6
11002 cd      write (2,*) 'ekont',ekont
11003 cd      write (iout,*) 'eello6',ekont*eel6
11004       return
11005       end
11006 c--------------------------------------------------------------------------
11007       double precision function eello6_graph1(i,j,k,l,imat,swap)
11008       implicit real*8 (a-h,o-z)
11009       include 'DIMENSIONS'
11010       include 'COMMON.IOUNITS'
11011       include 'COMMON.CHAIN'
11012       include 'COMMON.DERIV'
11013       include 'COMMON.INTERACT'
11014       include 'COMMON.CONTACTS'
11015       include 'COMMON.CONTMAT'
11016       include 'COMMON.CORRMAT'
11017       include 'COMMON.TORSION'
11018       include 'COMMON.VAR'
11019       include 'COMMON.GEO'
11020       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11021       logical swap
11022       logical lprn
11023       common /kutas/ lprn
11024 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11025 C                                                                              C
11026 C      Parallel       Antiparallel                                             C
11027 C                                                                              C
11028 C          o             o                                                     C
11029 C         /l\           /j\                                                    C
11030 C        /   \         /   \                                                   C
11031 C       /| o |         | o |\                                                  C
11032 C     \ j|/k\|  /   \  |/k\|l /                                                C
11033 C      \ /   \ /     \ /   \ /                                                 C
11034 C       o     o       o     o                                                  C
11035 C       i             i                                                        C
11036 C                                                                              C
11037 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11038       itk=itype2loc(itype(k))
11039       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11040       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11041       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11042       call transpose2(EUgC(1,1,k),auxmat(1,1))
11043       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11044       vv1(1)=pizda1(1,1)-pizda1(2,2)
11045       vv1(2)=pizda1(1,2)+pizda1(2,1)
11046       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11047       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11048       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11049       s5=scalar2(vv(1),Dtobr2(1,i))
11050 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11051       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11052       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11053      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11054      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11055      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11056      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11057      & +scalar2(vv(1),Dtobr2der(1,i)))
11058       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11059       vv1(1)=pizda1(1,1)-pizda1(2,2)
11060       vv1(2)=pizda1(1,2)+pizda1(2,1)
11061       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11062       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11063       if (l.eq.j+1) then
11064         g_corr6_loc(l-1)=g_corr6_loc(l-1)
11065      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11066      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11067      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11068      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11069       else
11070         g_corr6_loc(j-1)=g_corr6_loc(j-1)
11071      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11072      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11073      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11074      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11075       endif
11076       call transpose2(EUgCder(1,1,k),auxmat(1,1))
11077       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11078       vv1(1)=pizda1(1,1)-pizda1(2,2)
11079       vv1(2)=pizda1(1,2)+pizda1(2,1)
11080       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11081      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11082      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11083      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11084       do iii=1,2
11085         if (swap) then
11086           ind=3-iii
11087         else
11088           ind=iii
11089         endif
11090         do kkk=1,5
11091           do lll=1,3
11092             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11093             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11094             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11095             call transpose2(EUgC(1,1,k),auxmat(1,1))
11096             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11097      &        pizda1(1,1))
11098             vv1(1)=pizda1(1,1)-pizda1(2,2)
11099             vv1(2)=pizda1(1,2)+pizda1(2,1)
11100             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11101             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11102      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11103             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11104      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11105             s5=scalar2(vv(1),Dtobr2(1,i))
11106             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11107           enddo
11108         enddo
11109       enddo
11110       return
11111       end
11112 c----------------------------------------------------------------------------
11113       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11114       implicit real*8 (a-h,o-z)
11115       include 'DIMENSIONS'
11116       include 'COMMON.IOUNITS'
11117       include 'COMMON.CHAIN'
11118       include 'COMMON.DERIV'
11119       include 'COMMON.INTERACT'
11120       include 'COMMON.CONTACTS'
11121       include 'COMMON.CONTMAT'
11122       include 'COMMON.CORRMAT'
11123       include 'COMMON.TORSION'
11124       include 'COMMON.VAR'
11125       include 'COMMON.GEO'
11126       logical swap
11127       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11128      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11129       logical lprn
11130       common /kutas/ lprn
11131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11132 C                                                                              C
11133 C      Parallel       Antiparallel                                             C
11134 C                                                                              C
11135 C          o             o                                                     C
11136 C     \   /l\           /j\   /                                                C
11137 C      \ /   \         /   \ /                                                 C
11138 C       o| o |         | o |o                                                  C
11139 C     \ j|/k\|      \  |/k\|l                                                  C
11140 C      \ /   \       \ /   \                                                   C
11141 C       o             o                                                        C
11142 C       i             i                                                        C
11143 C                                                                              C
11144 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11145 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11146 C AL 7/4/01 s1 would occur in the sixth-order moment,
11147 C           but not in a cluster cumulant
11148 #ifdef MOMENT
11149       s1=dip(1,jj,i)*dip(1,kk,k)
11150 #endif
11151       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11152       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11153       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11154       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11155       call transpose2(EUg(1,1,k),auxmat(1,1))
11156       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11157       vv(1)=pizda(1,1)-pizda(2,2)
11158       vv(2)=pizda(1,2)+pizda(2,1)
11159       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11160 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11161 #ifdef MOMENT
11162       eello6_graph2=-(s1+s2+s3+s4)
11163 #else
11164       eello6_graph2=-(s2+s3+s4)
11165 #endif
11166 c      eello6_graph2=-s3
11167 C Derivatives in gamma(i-1)
11168       if (i.gt.1) then
11169 #ifdef MOMENT
11170         s1=dipderg(1,jj,i)*dip(1,kk,k)
11171 #endif
11172         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11173         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11174         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11175         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11176 #ifdef MOMENT
11177         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11178 #else
11179         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11180 #endif
11181 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11182       endif
11183 C Derivatives in gamma(k-1)
11184 #ifdef MOMENT
11185       s1=dip(1,jj,i)*dipderg(1,kk,k)
11186 #endif
11187       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11188       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11189       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11190       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11191       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11192       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11193       vv(1)=pizda(1,1)-pizda(2,2)
11194       vv(2)=pizda(1,2)+pizda(2,1)
11195       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11196 #ifdef MOMENT
11197       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11198 #else
11199       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11200 #endif
11201 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11202 C Derivatives in gamma(j-1) or gamma(l-1)
11203       if (j.gt.1) then
11204 #ifdef MOMENT
11205         s1=dipderg(3,jj,i)*dip(1,kk,k)
11206 #endif
11207         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11208         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11209         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11210         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11211         vv(1)=pizda(1,1)-pizda(2,2)
11212         vv(2)=pizda(1,2)+pizda(2,1)
11213         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11214 #ifdef MOMENT
11215         if (swap) then
11216           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11217         else
11218           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11219         endif
11220 #endif
11221         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11222 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11223       endif
11224 C Derivatives in gamma(l-1) or gamma(j-1)
11225       if (l.gt.1) then
11226 #ifdef MOMENT
11227         s1=dip(1,jj,i)*dipderg(3,kk,k)
11228 #endif
11229         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11230         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11231         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11232         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11233         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11234         vv(1)=pizda(1,1)-pizda(2,2)
11235         vv(2)=pizda(1,2)+pizda(2,1)
11236         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11237 #ifdef MOMENT
11238         if (swap) then
11239           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11240         else
11241           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11242         endif
11243 #endif
11244         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11245 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11246       endif
11247 C Cartesian derivatives.
11248       if (lprn) then
11249         write (2,*) 'In eello6_graph2'
11250         do iii=1,2
11251           write (2,*) 'iii=',iii
11252           do kkk=1,5
11253             write (2,*) 'kkk=',kkk
11254             do jjj=1,2
11255               write (2,'(3(2f10.5),5x)')
11256      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11257             enddo
11258           enddo
11259         enddo
11260       endif
11261       do iii=1,2
11262         do kkk=1,5
11263           do lll=1,3
11264 #ifdef MOMENT
11265             if (iii.eq.1) then
11266               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11267             else
11268               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11269             endif
11270 #endif
11271             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11272      &        auxvec(1))
11273             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11274             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11275      &        auxvec(1))
11276             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11277             call transpose2(EUg(1,1,k),auxmat(1,1))
11278             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11279      &        pizda(1,1))
11280             vv(1)=pizda(1,1)-pizda(2,2)
11281             vv(2)=pizda(1,2)+pizda(2,1)
11282             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11283 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11284 #ifdef MOMENT
11285             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11286 #else
11287             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11288 #endif
11289             if (swap) then
11290               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11291             else
11292               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11293             endif
11294           enddo
11295         enddo
11296       enddo
11297       return
11298       end
11299 c----------------------------------------------------------------------------
11300       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11301       implicit real*8 (a-h,o-z)
11302       include 'DIMENSIONS'
11303       include 'COMMON.IOUNITS'
11304       include 'COMMON.CHAIN'
11305       include 'COMMON.DERIV'
11306       include 'COMMON.INTERACT'
11307       include 'COMMON.CONTACTS'
11308       include 'COMMON.CONTMAT'
11309       include 'COMMON.CORRMAT'
11310       include 'COMMON.TORSION'
11311       include 'COMMON.VAR'
11312       include 'COMMON.GEO'
11313       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11314       logical swap
11315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11316 C                                                                              C
11317 C      Parallel       Antiparallel                                             C
11318 C                                                                              C
11319 C          o             o                                                     C
11320 C         /l\   /   \   /j\                                                    C
11321 C        /   \ /     \ /   \                                                   C
11322 C       /| o |o       o| o |\                                                  C
11323 C       j|/k\|  /      |/k\|l /                                                C
11324 C        /   \ /       /   \ /                                                 C
11325 C       /     o       /     o                                                  C
11326 C       i             i                                                        C
11327 C                                                                              C
11328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11329 C
11330 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11331 C           energy moment and not to the cluster cumulant.
11332       iti=itortyp(itype(i))
11333       if (j.lt.nres-1) then
11334         itj1=itype2loc(itype(j+1))
11335       else
11336         itj1=nloctyp
11337       endif
11338       itk=itype2loc(itype(k))
11339       itk1=itype2loc(itype(k+1))
11340       if (l.lt.nres-1) then
11341         itl1=itype2loc(itype(l+1))
11342       else
11343         itl1=nloctyp
11344       endif
11345 #ifdef MOMENT
11346       s1=dip(4,jj,i)*dip(4,kk,k)
11347 #endif
11348       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11349       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11350       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11351       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11352       call transpose2(EE(1,1,k),auxmat(1,1))
11353       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11354       vv(1)=pizda(1,1)+pizda(2,2)
11355       vv(2)=pizda(2,1)-pizda(1,2)
11356       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11357 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11358 cd     & "sum",-(s2+s3+s4)
11359 #ifdef MOMENT
11360       eello6_graph3=-(s1+s2+s3+s4)
11361 #else
11362       eello6_graph3=-(s2+s3+s4)
11363 #endif
11364 c      eello6_graph3=-s4
11365 C Derivatives in gamma(k-1)
11366       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11367       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11368       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11369       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11370 C Derivatives in gamma(l-1)
11371       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11372       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11373       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11374       vv(1)=pizda(1,1)+pizda(2,2)
11375       vv(2)=pizda(2,1)-pizda(1,2)
11376       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11377       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11378 C Cartesian derivatives.
11379       do iii=1,2
11380         do kkk=1,5
11381           do lll=1,3
11382 #ifdef MOMENT
11383             if (iii.eq.1) then
11384               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11385             else
11386               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11387             endif
11388 #endif
11389             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11390      &        auxvec(1))
11391             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11392             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11393      &        auxvec(1))
11394             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11395             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11396      &        pizda(1,1))
11397             vv(1)=pizda(1,1)+pizda(2,2)
11398             vv(2)=pizda(2,1)-pizda(1,2)
11399             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11400 #ifdef MOMENT
11401             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11402 #else
11403             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11404 #endif
11405             if (swap) then
11406               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11407             else
11408               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11409             endif
11410 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11411           enddo
11412         enddo
11413       enddo
11414       return
11415       end
11416 c----------------------------------------------------------------------------
11417       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11418       implicit real*8 (a-h,o-z)
11419       include 'DIMENSIONS'
11420       include 'COMMON.IOUNITS'
11421       include 'COMMON.CHAIN'
11422       include 'COMMON.DERIV'
11423       include 'COMMON.INTERACT'
11424       include 'COMMON.CONTACTS'
11425       include 'COMMON.CONTMAT'
11426       include 'COMMON.CORRMAT'
11427       include 'COMMON.TORSION'
11428       include 'COMMON.VAR'
11429       include 'COMMON.GEO'
11430       include 'COMMON.FFIELD'
11431       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11432      & auxvec1(2),auxmat1(2,2)
11433       logical swap
11434 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11435 C                                                                              C
11436 C      Parallel       Antiparallel                                             C
11437 C                                                                              C
11438 C          o             o                                                     C
11439 C         /l\   /   \   /j\                                                    C
11440 C        /   \ /     \ /   \                                                   C
11441 C       /| o |o       o| o |\                                                  C
11442 C     \ j|/k\|      \  |/k\|l                                                  C
11443 C      \ /   \       \ /   \                                                   C
11444 C       o     \       o     \                                                  C
11445 C       i             i                                                        C
11446 C                                                                              C
11447 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11448 C
11449 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11450 C           energy moment and not to the cluster cumulant.
11451 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11452       iti=itype2loc(itype(i))
11453       itj=itype2loc(itype(j))
11454       if (j.lt.nres-1) then
11455         itj1=itype2loc(itype(j+1))
11456       else
11457         itj1=nloctyp
11458       endif
11459       itk=itype2loc(itype(k))
11460       if (k.lt.nres-1) then
11461         itk1=itype2loc(itype(k+1))
11462       else
11463         itk1=nloctyp
11464       endif
11465       itl=itype2loc(itype(l))
11466       if (l.lt.nres-1) then
11467         itl1=itype2loc(itype(l+1))
11468       else
11469         itl1=nloctyp
11470       endif
11471 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11472 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11473 cd     & ' itl',itl,' itl1',itl1
11474 #ifdef MOMENT
11475       if (imat.eq.1) then
11476         s1=dip(3,jj,i)*dip(3,kk,k)
11477       else
11478         s1=dip(2,jj,j)*dip(2,kk,l)
11479       endif
11480 #endif
11481       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11482       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11483       if (j.eq.l+1) then
11484         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11485         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11486       else
11487         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11488         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11489       endif
11490       call transpose2(EUg(1,1,k),auxmat(1,1))
11491       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11492       vv(1)=pizda(1,1)-pizda(2,2)
11493       vv(2)=pizda(2,1)+pizda(1,2)
11494       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11495 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11496 #ifdef MOMENT
11497       eello6_graph4=-(s1+s2+s3+s4)
11498 #else
11499       eello6_graph4=-(s2+s3+s4)
11500 #endif
11501 C Derivatives in gamma(i-1)
11502       if (i.gt.1) then
11503 #ifdef MOMENT
11504         if (imat.eq.1) then
11505           s1=dipderg(2,jj,i)*dip(3,kk,k)
11506         else
11507           s1=dipderg(4,jj,j)*dip(2,kk,l)
11508         endif
11509 #endif
11510         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11511         if (j.eq.l+1) then
11512           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11513           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11514         else
11515           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11516           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11517         endif
11518         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11519         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11520 cd          write (2,*) 'turn6 derivatives'
11521 #ifdef MOMENT
11522           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11523 #else
11524           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11525 #endif
11526         else
11527 #ifdef MOMENT
11528           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11529 #else
11530           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11531 #endif
11532         endif
11533       endif
11534 C Derivatives in gamma(k-1)
11535 #ifdef MOMENT
11536       if (imat.eq.1) then
11537         s1=dip(3,jj,i)*dipderg(2,kk,k)
11538       else
11539         s1=dip(2,jj,j)*dipderg(4,kk,l)
11540       endif
11541 #endif
11542       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11543       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11544       if (j.eq.l+1) then
11545         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11546         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11547       else
11548         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11549         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11550       endif
11551       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11552       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11553       vv(1)=pizda(1,1)-pizda(2,2)
11554       vv(2)=pizda(2,1)+pizda(1,2)
11555       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11556       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11557 #ifdef MOMENT
11558         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11559 #else
11560         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11561 #endif
11562       else
11563 #ifdef MOMENT
11564         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11565 #else
11566         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11567 #endif
11568       endif
11569 C Derivatives in gamma(j-1) or gamma(l-1)
11570       if (l.eq.j+1 .and. l.gt.1) then
11571         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11572         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11573         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11574         vv(1)=pizda(1,1)-pizda(2,2)
11575         vv(2)=pizda(2,1)+pizda(1,2)
11576         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11577         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11578       else if (j.gt.1) then
11579         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11580         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11581         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11582         vv(1)=pizda(1,1)-pizda(2,2)
11583         vv(2)=pizda(2,1)+pizda(1,2)
11584         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11585         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11586           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11587         else
11588           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11589         endif
11590       endif
11591 C Cartesian derivatives.
11592       do iii=1,2
11593         do kkk=1,5
11594           do lll=1,3
11595 #ifdef MOMENT
11596             if (iii.eq.1) then
11597               if (imat.eq.1) then
11598                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11599               else
11600                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11601               endif
11602             else
11603               if (imat.eq.1) then
11604                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11605               else
11606                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11607               endif
11608             endif
11609 #endif
11610             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11611      &        auxvec(1))
11612             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11613             if (j.eq.l+1) then
11614               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11615      &          b1(1,j+1),auxvec(1))
11616               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11617             else
11618               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11619      &          b1(1,l+1),auxvec(1))
11620               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11621             endif
11622             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11623      &        pizda(1,1))
11624             vv(1)=pizda(1,1)-pizda(2,2)
11625             vv(2)=pizda(2,1)+pizda(1,2)
11626             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11627             if (swap) then
11628               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11629 #ifdef MOMENT
11630                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11631      &             -(s1+s2+s4)
11632 #else
11633                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11634      &             -(s2+s4)
11635 #endif
11636                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11637               else
11638 #ifdef MOMENT
11639                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11640 #else
11641                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11642 #endif
11643                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11644               endif
11645             else
11646 #ifdef MOMENT
11647               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11648 #else
11649               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11650 #endif
11651               if (l.eq.j+1) then
11652                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11653               else
11654                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11655               endif
11656             endif
11657           enddo
11658         enddo
11659       enddo
11660       return
11661       end
11662 c----------------------------------------------------------------------------
11663       double precision function eello_turn6(i,jj,kk)
11664       implicit real*8 (a-h,o-z)
11665       include 'DIMENSIONS'
11666       include 'COMMON.IOUNITS'
11667       include 'COMMON.CHAIN'
11668       include 'COMMON.DERIV'
11669       include 'COMMON.INTERACT'
11670       include 'COMMON.CONTACTS'
11671       include 'COMMON.CONTMAT'
11672       include 'COMMON.CORRMAT'
11673       include 'COMMON.TORSION'
11674       include 'COMMON.VAR'
11675       include 'COMMON.GEO'
11676       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11677      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11678      &  ggg1(3),ggg2(3)
11679       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11680      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11681 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11682 C           the respective energy moment and not to the cluster cumulant.
11683       s1=0.0d0
11684       s8=0.0d0
11685       s13=0.0d0
11686 c
11687       eello_turn6=0.0d0
11688       j=i+4
11689       k=i+1
11690       l=i+3
11691       iti=itype2loc(itype(i))
11692       itk=itype2loc(itype(k))
11693       itk1=itype2loc(itype(k+1))
11694       itl=itype2loc(itype(l))
11695       itj=itype2loc(itype(j))
11696 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11697 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11698 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11699 cd        eello6=0.0d0
11700 cd        return
11701 cd      endif
11702 cd      write (iout,*)
11703 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11704 cd     &   ' and',k,l
11705 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11706       do iii=1,2
11707         do kkk=1,5
11708           do lll=1,3
11709             derx_turn(lll,kkk,iii)=0.0d0
11710           enddo
11711         enddo
11712       enddo
11713 cd      eij=1.0d0
11714 cd      ekl=1.0d0
11715 cd      ekont=1.0d0
11716       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11717 cd      eello6_5=0.0d0
11718 cd      write (2,*) 'eello6_5',eello6_5
11719 #ifdef MOMENT
11720       call transpose2(AEA(1,1,1),auxmat(1,1))
11721       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11722       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11723       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11724 #endif
11725       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11726       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11727       s2 = scalar2(b1(1,k),vtemp1(1))
11728 #ifdef MOMENT
11729       call transpose2(AEA(1,1,2),atemp(1,1))
11730       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11731       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11732       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11733 #endif
11734       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11735       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11736       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11737 #ifdef MOMENT
11738       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11739       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11740       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11741       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11742       ss13 = scalar2(b1(1,k),vtemp4(1))
11743       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11744 #endif
11745 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11746 c      s1=0.0d0
11747 c      s2=0.0d0
11748 c      s8=0.0d0
11749 c      s12=0.0d0
11750 c      s13=0.0d0
11751       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11752 C Derivatives in gamma(i+2)
11753       s1d =0.0d0
11754       s8d =0.0d0
11755 #ifdef MOMENT
11756       call transpose2(AEA(1,1,1),auxmatd(1,1))
11757       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11758       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11759       call transpose2(AEAderg(1,1,2),atempd(1,1))
11760       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11761       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11762 #endif
11763       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11764       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11765       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11766 c      s1d=0.0d0
11767 c      s2d=0.0d0
11768 c      s8d=0.0d0
11769 c      s12d=0.0d0
11770 c      s13d=0.0d0
11771       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11772 C Derivatives in gamma(i+3)
11773 #ifdef MOMENT
11774       call transpose2(AEA(1,1,1),auxmatd(1,1))
11775       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11776       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11777       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11778 #endif
11779       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11780       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11781       s2d = scalar2(b1(1,k),vtemp1d(1))
11782 #ifdef MOMENT
11783       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11784       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11785 #endif
11786       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11787 #ifdef MOMENT
11788       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11789       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11790       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11791 #endif
11792 c      s1d=0.0d0
11793 c      s2d=0.0d0
11794 c      s8d=0.0d0
11795 c      s12d=0.0d0
11796 c      s13d=0.0d0
11797 #ifdef MOMENT
11798       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11799      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11800 #else
11801       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11802      &               -0.5d0*ekont*(s2d+s12d)
11803 #endif
11804 C Derivatives in gamma(i+4)
11805       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11806       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11807       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11808 #ifdef MOMENT
11809       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11810       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11811       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11812 #endif
11813 c      s1d=0.0d0
11814 c      s2d=0.0d0
11815 c      s8d=0.0d0
11816 C      s12d=0.0d0
11817 c      s13d=0.0d0
11818 #ifdef MOMENT
11819       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11820 #else
11821       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11822 #endif
11823 C Derivatives in gamma(i+5)
11824 #ifdef MOMENT
11825       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11826       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11827       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11828 #endif
11829       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11830       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11831       s2d = scalar2(b1(1,k),vtemp1d(1))
11832 #ifdef MOMENT
11833       call transpose2(AEA(1,1,2),atempd(1,1))
11834       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11835       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11836 #endif
11837       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11838       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11839 #ifdef MOMENT
11840       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11841       ss13d = scalar2(b1(1,k),vtemp4d(1))
11842       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11843 #endif
11844 c      s1d=0.0d0
11845 c      s2d=0.0d0
11846 c      s8d=0.0d0
11847 c      s12d=0.0d0
11848 c      s13d=0.0d0
11849 #ifdef MOMENT
11850       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11851      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11852 #else
11853       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11854      &               -0.5d0*ekont*(s2d+s12d)
11855 #endif
11856 C Cartesian derivatives
11857       do iii=1,2
11858         do kkk=1,5
11859           do lll=1,3
11860 #ifdef MOMENT
11861             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11862             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11863             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11864 #endif
11865             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11866             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11867      &          vtemp1d(1))
11868             s2d = scalar2(b1(1,k),vtemp1d(1))
11869 #ifdef MOMENT
11870             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11871             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11872             s8d = -(atempd(1,1)+atempd(2,2))*
11873      &           scalar2(cc(1,1,l),vtemp2(1))
11874 #endif
11875             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11876      &           auxmatd(1,1))
11877             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11878             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11879 c      s1d=0.0d0
11880 c      s2d=0.0d0
11881 c      s8d=0.0d0
11882 c      s12d=0.0d0
11883 c      s13d=0.0d0
11884 #ifdef MOMENT
11885             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11886      &        - 0.5d0*(s1d+s2d)
11887 #else
11888             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11889      &        - 0.5d0*s2d
11890 #endif
11891 #ifdef MOMENT
11892             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11893      &        - 0.5d0*(s8d+s12d)
11894 #else
11895             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11896      &        - 0.5d0*s12d
11897 #endif
11898           enddo
11899         enddo
11900       enddo
11901 #ifdef MOMENT
11902       do kkk=1,5
11903         do lll=1,3
11904           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11905      &      achuj_tempd(1,1))
11906           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11907           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11908           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11909           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11910           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11911      &      vtemp4d(1))
11912           ss13d = scalar2(b1(1,k),vtemp4d(1))
11913           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11914           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11915         enddo
11916       enddo
11917 #endif
11918 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11919 cd     &  16*eel_turn6_num
11920 cd      goto 1112
11921       if (j.lt.nres-1) then
11922         j1=j+1
11923         j2=j-1
11924       else
11925         j1=j-1
11926         j2=j-2
11927       endif
11928       if (l.lt.nres-1) then
11929         l1=l+1
11930         l2=l-1
11931       else
11932         l1=l-1
11933         l2=l-2
11934       endif
11935       do ll=1,3
11936 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11937 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11938 cgrad        ghalf=0.5d0*ggg1(ll)
11939 cd        ghalf=0.0d0
11940         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11941         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11942         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11943      &    +ekont*derx_turn(ll,2,1)
11944         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11945         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11946      &    +ekont*derx_turn(ll,4,1)
11947         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11948         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11949         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11950 cgrad        ghalf=0.5d0*ggg2(ll)
11951 cd        ghalf=0.0d0
11952         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11953      &    +ekont*derx_turn(ll,2,2)
11954         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11955         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11956      &    +ekont*derx_turn(ll,4,2)
11957         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11958         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11959         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11960       enddo
11961 cd      goto 1112
11962 cgrad      do m=i+1,j-1
11963 cgrad        do ll=1,3
11964 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11965 cgrad        enddo
11966 cgrad      enddo
11967 cgrad      do m=k+1,l-1
11968 cgrad        do ll=1,3
11969 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11970 cgrad        enddo
11971 cgrad      enddo
11972 cgrad1112  continue
11973 cgrad      do m=i+2,j2
11974 cgrad        do ll=1,3
11975 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11976 cgrad        enddo
11977 cgrad      enddo
11978 cgrad      do m=k+2,l2
11979 cgrad        do ll=1,3
11980 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11981 cgrad        enddo
11982 cgrad      enddo
11983 cd      do iii=1,nres-3
11984 cd        write (2,*) iii,g_corr6_loc(iii)
11985 cd      enddo
11986       eello_turn6=ekont*eel_turn6
11987 cd      write (2,*) 'ekont',ekont
11988 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11989       return
11990       end
11991 C-----------------------------------------------------------------------------
11992 #endif
11993       double precision function scalar(u,v)
11994 !DIR$ INLINEALWAYS scalar
11995 #ifndef OSF
11996 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11997 #endif
11998       implicit none
11999       double precision u(3),v(3)
12000 cd      double precision sc
12001 cd      integer i
12002 cd      sc=0.0d0
12003 cd      do i=1,3
12004 cd        sc=sc+u(i)*v(i)
12005 cd      enddo
12006 cd      scalar=sc
12007
12008       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12009       return
12010       end
12011 crc-------------------------------------------------
12012       SUBROUTINE MATVEC2(A1,V1,V2)
12013 !DIR$ INLINEALWAYS MATVEC2
12014 #ifndef OSF
12015 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12016 #endif
12017       implicit real*8 (a-h,o-z)
12018       include 'DIMENSIONS'
12019       DIMENSION A1(2,2),V1(2),V2(2)
12020 c      DO 1 I=1,2
12021 c        VI=0.0
12022 c        DO 3 K=1,2
12023 c    3     VI=VI+A1(I,K)*V1(K)
12024 c        Vaux(I)=VI
12025 c    1 CONTINUE
12026
12027       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12028       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12029
12030       v2(1)=vaux1
12031       v2(2)=vaux2
12032       END
12033 C---------------------------------------
12034       SUBROUTINE MATMAT2(A1,A2,A3)
12035 #ifndef OSF
12036 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12037 #endif
12038       implicit real*8 (a-h,o-z)
12039       include 'DIMENSIONS'
12040       DIMENSION A1(2,2),A2(2,2),A3(2,2)
12041 c      DIMENSION AI3(2,2)
12042 c        DO  J=1,2
12043 c          A3IJ=0.0
12044 c          DO K=1,2
12045 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
12046 c          enddo
12047 c          A3(I,J)=A3IJ
12048 c       enddo
12049 c      enddo
12050
12051       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12052       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12053       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12054       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12055
12056       A3(1,1)=AI3_11
12057       A3(2,1)=AI3_21
12058       A3(1,2)=AI3_12
12059       A3(2,2)=AI3_22
12060       END
12061
12062 c-------------------------------------------------------------------------
12063       double precision function scalar2(u,v)
12064 !DIR$ INLINEALWAYS scalar2
12065       implicit none
12066       double precision u(2),v(2)
12067       double precision sc
12068       integer i
12069       scalar2=u(1)*v(1)+u(2)*v(2)
12070       return
12071       end
12072
12073 C-----------------------------------------------------------------------------
12074
12075       subroutine transpose2(a,at)
12076 !DIR$ INLINEALWAYS transpose2
12077 #ifndef OSF
12078 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12079 #endif
12080       implicit none
12081       double precision a(2,2),at(2,2)
12082       at(1,1)=a(1,1)
12083       at(1,2)=a(2,1)
12084       at(2,1)=a(1,2)
12085       at(2,2)=a(2,2)
12086       return
12087       end
12088 c--------------------------------------------------------------------------
12089       subroutine transpose(n,a,at)
12090       implicit none
12091       integer n,i,j
12092       double precision a(n,n),at(n,n)
12093       do i=1,n
12094         do j=1,n
12095           at(j,i)=a(i,j)
12096         enddo
12097       enddo
12098       return
12099       end
12100 C---------------------------------------------------------------------------
12101       subroutine prodmat3(a1,a2,kk,transp,prod)
12102 !DIR$ INLINEALWAYS prodmat3
12103 #ifndef OSF
12104 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12105 #endif
12106       implicit none
12107       integer i,j
12108       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12109       logical transp
12110 crc      double precision auxmat(2,2),prod_(2,2)
12111
12112       if (transp) then
12113 crc        call transpose2(kk(1,1),auxmat(1,1))
12114 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12115 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12116
12117            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12118      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12119            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12120      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12121            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12122      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12123            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12124      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12125
12126       else
12127 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12128 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12129
12130            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12131      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12132            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12133      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12134            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12135      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12136            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12137      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12138
12139       endif
12140 c      call transpose2(a2(1,1),a2t(1,1))
12141
12142 crc      print *,transp
12143 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12144 crc      print *,((prod(i,j),i=1,2),j=1,2)
12145
12146       return
12147       end
12148 CCC----------------------------------------------
12149       subroutine Eliptransfer(eliptran)
12150       implicit real*8 (a-h,o-z)
12151       include 'DIMENSIONS'
12152       include 'COMMON.GEO'
12153       include 'COMMON.VAR'
12154       include 'COMMON.LOCAL'
12155       include 'COMMON.CHAIN'
12156       include 'COMMON.DERIV'
12157       include 'COMMON.NAMES'
12158       include 'COMMON.INTERACT'
12159       include 'COMMON.IOUNITS'
12160       include 'COMMON.CALC'
12161       include 'COMMON.CONTROL'
12162       include 'COMMON.SPLITELE'
12163       include 'COMMON.SBRIDGE'
12164 C this is done by Adasko
12165 C      print *,"wchodze"
12166 C structure of box:
12167 C      water
12168 C--bordliptop-- buffore starts
12169 C--bufliptop--- here true lipid starts
12170 C      lipid
12171 C--buflipbot--- lipid ends buffore starts
12172 C--bordlipbot--buffore ends
12173       eliptran=0.0
12174       do i=ilip_start,ilip_end
12175 C       do i=1,1
12176         if (itype(i).eq.ntyp1) cycle
12177
12178         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12179         if (positi.le.0.0) positi=positi+boxzsize
12180 C        print *,i
12181 C first for peptide groups
12182 c for each residue check if it is in lipid or lipid water border area
12183        if ((positi.gt.bordlipbot)
12184      &.and.(positi.lt.bordliptop)) then
12185 C the energy transfer exist
12186         if (positi.lt.buflipbot) then
12187 C what fraction I am in
12188          fracinbuf=1.0d0-
12189      &        ((positi-bordlipbot)/lipbufthick)
12190 C lipbufthick is thickenes of lipid buffore
12191          sslip=sscalelip(fracinbuf)
12192          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12193          eliptran=eliptran+sslip*pepliptran
12194          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12195          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12196 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12197
12198 C        print *,"doing sccale for lower part"
12199 C         print *,i,sslip,fracinbuf,ssgradlip
12200         elseif (positi.gt.bufliptop) then
12201          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12202          sslip=sscalelip(fracinbuf)
12203          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12204          eliptran=eliptran+sslip*pepliptran
12205          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12206          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12207 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12208 C          print *, "doing sscalefor top part"
12209 C         print *,i,sslip,fracinbuf,ssgradlip
12210         else
12211          eliptran=eliptran+pepliptran
12212 C         print *,"I am in true lipid"
12213         endif
12214 C       else
12215 C       eliptran=elpitran+0.0 ! I am in water
12216        endif
12217        enddo
12218 C       print *, "nic nie bylo w lipidzie?"
12219 C now multiply all by the peptide group transfer factor
12220 C       eliptran=eliptran*pepliptran
12221 C now the same for side chains
12222 CV       do i=1,1
12223        do i=ilip_start,ilip_end
12224         if (itype(i).eq.ntyp1) cycle
12225         positi=(mod(c(3,i+nres),boxzsize))
12226         if (positi.le.0) positi=positi+boxzsize
12227 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12228 c for each residue check if it is in lipid or lipid water border area
12229 C       respos=mod(c(3,i+nres),boxzsize)
12230 C       print *,positi,bordlipbot,buflipbot
12231        if ((positi.gt.bordlipbot)
12232      & .and.(positi.lt.bordliptop)) then
12233 C the energy transfer exist
12234         if (positi.lt.buflipbot) then
12235          fracinbuf=1.0d0-
12236      &     ((positi-bordlipbot)/lipbufthick)
12237 C lipbufthick is thickenes of lipid buffore
12238          sslip=sscalelip(fracinbuf)
12239          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12240          eliptran=eliptran+sslip*liptranene(itype(i))
12241          gliptranx(3,i)=gliptranx(3,i)
12242      &+ssgradlip*liptranene(itype(i))
12243          gliptranc(3,i-1)= gliptranc(3,i-1)
12244      &+ssgradlip*liptranene(itype(i))
12245 C         print *,"doing sccale for lower part"
12246         elseif (positi.gt.bufliptop) then
12247          fracinbuf=1.0d0-
12248      &((bordliptop-positi)/lipbufthick)
12249          sslip=sscalelip(fracinbuf)
12250          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12251          eliptran=eliptran+sslip*liptranene(itype(i))
12252          gliptranx(3,i)=gliptranx(3,i)
12253      &+ssgradlip*liptranene(itype(i))
12254          gliptranc(3,i-1)= gliptranc(3,i-1)
12255      &+ssgradlip*liptranene(itype(i))
12256 C          print *, "doing sscalefor top part",sslip,fracinbuf
12257         else
12258          eliptran=eliptran+liptranene(itype(i))
12259 C         print *,"I am in true lipid"
12260         endif
12261         endif ! if in lipid or buffor
12262 C       else
12263 C       eliptran=elpitran+0.0 ! I am in water
12264        enddo
12265        return
12266        end
12267 C---------------------------------------------------------
12268 C AFM soubroutine for constant force
12269        subroutine AFMforce(Eafmforce)
12270        implicit real*8 (a-h,o-z)
12271       include 'DIMENSIONS'
12272       include 'COMMON.GEO'
12273       include 'COMMON.VAR'
12274       include 'COMMON.LOCAL'
12275       include 'COMMON.CHAIN'
12276       include 'COMMON.DERIV'
12277       include 'COMMON.NAMES'
12278       include 'COMMON.INTERACT'
12279       include 'COMMON.IOUNITS'
12280       include 'COMMON.CALC'
12281       include 'COMMON.CONTROL'
12282       include 'COMMON.SPLITELE'
12283       include 'COMMON.SBRIDGE'
12284       real*8 diffafm(3)
12285       dist=0.0d0
12286       Eafmforce=0.0d0
12287       do i=1,3
12288       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12289       dist=dist+diffafm(i)**2
12290       enddo
12291       dist=dsqrt(dist)
12292       Eafmforce=-forceAFMconst*(dist-distafminit)
12293       do i=1,3
12294       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12295       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12296       enddo
12297 C      print *,'AFM',Eafmforce
12298       return
12299       end
12300 C---------------------------------------------------------
12301 C AFM subroutine with pseudoconstant velocity
12302        subroutine AFMvel(Eafmforce)
12303        implicit real*8 (a-h,o-z)
12304       include 'DIMENSIONS'
12305       include 'COMMON.GEO'
12306       include 'COMMON.VAR'
12307       include 'COMMON.LOCAL'
12308       include 'COMMON.CHAIN'
12309       include 'COMMON.DERIV'
12310       include 'COMMON.NAMES'
12311       include 'COMMON.INTERACT'
12312       include 'COMMON.IOUNITS'
12313       include 'COMMON.CALC'
12314       include 'COMMON.CONTROL'
12315       include 'COMMON.SPLITELE'
12316       include 'COMMON.SBRIDGE'
12317       real*8 diffafm(3)
12318 C Only for check grad COMMENT if not used for checkgrad
12319 C      totT=3.0d0
12320 C--------------------------------------------------------
12321 C      print *,"wchodze"
12322       dist=0.0d0
12323       Eafmforce=0.0d0
12324       do i=1,3
12325       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12326       dist=dist+diffafm(i)**2
12327       enddo
12328       dist=dsqrt(dist)
12329       Eafmforce=0.5d0*forceAFMconst
12330      & *(distafminit+totTafm*velAFMconst-dist)**2
12331 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12332       do i=1,3
12333       gradafm(i,afmend-1)=-forceAFMconst*
12334      &(distafminit+totTafm*velAFMconst-dist)
12335      &*diffafm(i)/dist
12336       gradafm(i,afmbeg-1)=forceAFMconst*
12337      &(distafminit+totTafm*velAFMconst-dist)
12338      &*diffafm(i)/dist
12339       enddo
12340 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12341       return
12342       end
12343 C-----------------------------------------------------------
12344 C first for shielding is setting of function of side-chains
12345        subroutine set_shield_fac
12346       implicit real*8 (a-h,o-z)
12347       include 'DIMENSIONS'
12348       include 'COMMON.CHAIN'
12349       include 'COMMON.DERIV'
12350       include 'COMMON.IOUNITS'
12351       include 'COMMON.SHIELD'
12352       include 'COMMON.INTERACT'
12353 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12354       double precision div77_81/0.974996043d0/,
12355      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12356
12357 C the vector between center of side_chain and peptide group
12358        double precision pep_side(3),long,side_calf(3),
12359      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12360      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12361 C the line belowe needs to be changed for FGPROC>1
12362       do i=1,nres-1
12363       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12364       ishield_list(i)=0
12365 Cif there two consequtive dummy atoms there is no peptide group between them
12366 C the line below has to be changed for FGPROC>1
12367       VolumeTotal=0.0
12368       do k=1,nres
12369        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12370        dist_pep_side=0.0
12371        dist_side_calf=0.0
12372        do j=1,3
12373 C first lets set vector conecting the ithe side-chain with kth side-chain
12374       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12375 C      pep_side(j)=2.0d0
12376 C and vector conecting the side-chain with its proper calfa
12377       side_calf(j)=c(j,k+nres)-c(j,k)
12378 C      side_calf(j)=2.0d0
12379       pept_group(j)=c(j,i)-c(j,i+1)
12380 C lets have their lenght
12381       dist_pep_side=pep_side(j)**2+dist_pep_side
12382       dist_side_calf=dist_side_calf+side_calf(j)**2
12383       dist_pept_group=dist_pept_group+pept_group(j)**2
12384       enddo
12385        dist_pep_side=dsqrt(dist_pep_side)
12386        dist_pept_group=dsqrt(dist_pept_group)
12387        dist_side_calf=dsqrt(dist_side_calf)
12388       do j=1,3
12389         pep_side_norm(j)=pep_side(j)/dist_pep_side
12390         side_calf_norm(j)=dist_side_calf
12391       enddo
12392 C now sscale fraction
12393        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12394 C       print *,buff_shield,"buff"
12395 C now sscale
12396         if (sh_frac_dist.le.0.0) cycle
12397 C If we reach here it means that this side chain reaches the shielding sphere
12398 C Lets add him to the list for gradient
12399         ishield_list(i)=ishield_list(i)+1
12400 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12401 C this list is essential otherwise problem would be O3
12402         shield_list(ishield_list(i),i)=k
12403 C Lets have the sscale value
12404         if (sh_frac_dist.gt.1.0) then
12405          scale_fac_dist=1.0d0
12406          do j=1,3
12407          sh_frac_dist_grad(j)=0.0d0
12408          enddo
12409         else
12410          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12411      &                   *(2.0*sh_frac_dist-3.0d0)
12412          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12413      &                  /dist_pep_side/buff_shield*0.5
12414 C remember for the final gradient multiply sh_frac_dist_grad(j)
12415 C for side_chain by factor -2 !
12416          do j=1,3
12417          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12418 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12419 C     &                    sh_frac_dist_grad(j)
12420          enddo
12421         endif
12422 C        if ((i.eq.3).and.(k.eq.2)) then
12423 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12424 C     & ,"TU"
12425 C        endif
12426
12427 C this is what is now we have the distance scaling now volume...
12428       short=short_r_sidechain(itype(k))
12429       long=long_r_sidechain(itype(k))
12430       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12431 C now costhet_grad
12432 C       costhet=0.0d0
12433        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12434 C       costhet_fac=0.0d0
12435        do j=1,3
12436          costhet_grad(j)=costhet_fac*pep_side(j)
12437        enddo
12438 C remember for the final gradient multiply costhet_grad(j)
12439 C for side_chain by factor -2 !
12440 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12441 C pep_side0pept_group is vector multiplication
12442       pep_side0pept_group=0.0
12443       do j=1,3
12444       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12445       enddo
12446       cosalfa=(pep_side0pept_group/
12447      & (dist_pep_side*dist_side_calf))
12448       fac_alfa_sin=1.0-cosalfa**2
12449       fac_alfa_sin=dsqrt(fac_alfa_sin)
12450       rkprim=fac_alfa_sin*(long-short)+short
12451 C now costhet_grad
12452        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12453        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12454
12455        do j=1,3
12456          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12457      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12458      &*(long-short)/fac_alfa_sin*cosalfa/
12459      &((dist_pep_side*dist_side_calf))*
12460      &((side_calf(j))-cosalfa*
12461      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12462
12463         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12464      &*(long-short)/fac_alfa_sin*cosalfa
12465      &/((dist_pep_side*dist_side_calf))*
12466      &(pep_side(j)-
12467      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12468        enddo
12469
12470       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12471      &                    /VSolvSphere_div
12472      &                    *wshield
12473 C now the gradient...
12474 C grad_shield is gradient of Calfa for peptide groups
12475 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12476 C     &               costhet,cosphi
12477 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12478 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12479       do j=1,3
12480       grad_shield(j,i)=grad_shield(j,i)
12481 C gradient po skalowaniu
12482      &                +(sh_frac_dist_grad(j)
12483 C  gradient po costhet
12484      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12485      &-scale_fac_dist*(cosphi_grad_long(j))
12486      &/(1.0-cosphi) )*div77_81
12487      &*VofOverlap
12488 C grad_shield_side is Cbeta sidechain gradient
12489       grad_shield_side(j,ishield_list(i),i)=
12490      &        (sh_frac_dist_grad(j)*(-2.0d0)
12491      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12492      &       +scale_fac_dist*(cosphi_grad_long(j))
12493      &        *2.0d0/(1.0-cosphi))
12494      &        *div77_81*VofOverlap
12495
12496        grad_shield_loc(j,ishield_list(i),i)=
12497      &   scale_fac_dist*cosphi_grad_loc(j)
12498      &        *2.0d0/(1.0-cosphi)
12499      &        *div77_81*VofOverlap
12500       enddo
12501       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12502       enddo
12503       fac_shield(i)=VolumeTotal*div77_81+div4_81
12504 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12505       enddo
12506       return
12507       end
12508 C--------------------------------------------------------------------------
12509       double precision function tschebyshev(m,n,x,y)
12510       implicit none
12511       include "DIMENSIONS"
12512       integer i,m,n
12513       double precision x(n),y,yy(0:maxvar),aux
12514 c Tschebyshev polynomial. Note that the first term is omitted
12515 c m=0: the constant term is included
12516 c m=1: the constant term is not included
12517       yy(0)=1.0d0
12518       yy(1)=y
12519       do i=2,n
12520         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12521       enddo
12522       aux=0.0d0
12523       do i=m,n
12524         aux=aux+x(i)*yy(i)
12525       enddo
12526       tschebyshev=aux
12527       return
12528       end
12529 C--------------------------------------------------------------------------
12530       double precision function gradtschebyshev(m,n,x,y)
12531       implicit none
12532       include "DIMENSIONS"
12533       integer i,m,n
12534       double precision x(n+1),y,yy(0:maxvar),aux
12535 c Tschebyshev polynomial. Note that the first term is omitted
12536 c m=0: the constant term is included
12537 c m=1: the constant term is not included
12538       yy(0)=1.0d0
12539       yy(1)=2.0d0*y
12540       do i=2,n
12541         yy(i)=2*y*yy(i-1)-yy(i-2)
12542       enddo
12543       aux=0.0d0
12544       do i=m,n
12545         aux=aux+x(i+1)*yy(i)*(i+1)
12546 C        print *, x(i+1),yy(i),i
12547       enddo
12548       gradtschebyshev=aux
12549       return
12550       end
12551 C------------------------------------------------------------------------
12552 C first for shielding is setting of function of side-chains
12553        subroutine set_shield_fac2
12554       implicit real*8 (a-h,o-z)
12555       include 'DIMENSIONS'
12556       include 'COMMON.CHAIN'
12557       include 'COMMON.DERIV'
12558       include 'COMMON.IOUNITS'
12559       include 'COMMON.SHIELD'
12560       include 'COMMON.INTERACT'
12561 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12562       double precision div77_81/0.974996043d0/,
12563      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12564
12565 C the vector between center of side_chain and peptide group
12566        double precision pep_side(3),long,side_calf(3),
12567      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12568      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12569 C the line belowe needs to be changed for FGPROC>1
12570       do i=1,nres-1
12571       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12572       ishield_list(i)=0
12573 Cif there two consequtive dummy atoms there is no peptide group between them
12574 C the line below has to be changed for FGPROC>1
12575       VolumeTotal=0.0
12576       do k=1,nres
12577        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12578        dist_pep_side=0.0
12579        dist_side_calf=0.0
12580        do j=1,3
12581 C first lets set vector conecting the ithe side-chain with kth side-chain
12582       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12583 C      pep_side(j)=2.0d0
12584 C and vector conecting the side-chain with its proper calfa
12585       side_calf(j)=c(j,k+nres)-c(j,k)
12586 C      side_calf(j)=2.0d0
12587       pept_group(j)=c(j,i)-c(j,i+1)
12588 C lets have their lenght
12589       dist_pep_side=pep_side(j)**2+dist_pep_side
12590       dist_side_calf=dist_side_calf+side_calf(j)**2
12591       dist_pept_group=dist_pept_group+pept_group(j)**2
12592       enddo
12593        dist_pep_side=dsqrt(dist_pep_side)
12594        dist_pept_group=dsqrt(dist_pept_group)
12595        dist_side_calf=dsqrt(dist_side_calf)
12596       do j=1,3
12597         pep_side_norm(j)=pep_side(j)/dist_pep_side
12598         side_calf_norm(j)=dist_side_calf
12599       enddo
12600 C now sscale fraction
12601        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12602 C       print *,buff_shield,"buff"
12603 C now sscale
12604         if (sh_frac_dist.le.0.0) cycle
12605 C If we reach here it means that this side chain reaches the shielding sphere
12606 C Lets add him to the list for gradient
12607         ishield_list(i)=ishield_list(i)+1
12608 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12609 C this list is essential otherwise problem would be O3
12610         shield_list(ishield_list(i),i)=k
12611 C Lets have the sscale value
12612         if (sh_frac_dist.gt.1.0) then
12613          scale_fac_dist=1.0d0
12614          do j=1,3
12615          sh_frac_dist_grad(j)=0.0d0
12616          enddo
12617         else
12618          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12619      &                   *(2.0d0*sh_frac_dist-3.0d0)
12620          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12621      &                  /dist_pep_side/buff_shield*0.5d0
12622 C remember for the final gradient multiply sh_frac_dist_grad(j)
12623 C for side_chain by factor -2 !
12624          do j=1,3
12625          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12626 C         sh_frac_dist_grad(j)=0.0d0
12627 C         scale_fac_dist=1.0d0
12628 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12629 C     &                    sh_frac_dist_grad(j)
12630          enddo
12631         endif
12632 C this is what is now we have the distance scaling now volume...
12633       short=short_r_sidechain(itype(k))
12634       long=long_r_sidechain(itype(k))
12635       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12636       sinthet=short/dist_pep_side*costhet
12637 C now costhet_grad
12638 C       costhet=0.6d0
12639 C       sinthet=0.8
12640        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12641 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12642 C     &             -short/dist_pep_side**2/costhet)
12643 C       costhet_fac=0.0d0
12644        do j=1,3
12645          costhet_grad(j)=costhet_fac*pep_side(j)
12646        enddo
12647 C remember for the final gradient multiply costhet_grad(j)
12648 C for side_chain by factor -2 !
12649 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12650 C pep_side0pept_group is vector multiplication
12651       pep_side0pept_group=0.0d0
12652       do j=1,3
12653       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12654       enddo
12655       cosalfa=(pep_side0pept_group/
12656      & (dist_pep_side*dist_side_calf))
12657       fac_alfa_sin=1.0d0-cosalfa**2
12658       fac_alfa_sin=dsqrt(fac_alfa_sin)
12659       rkprim=fac_alfa_sin*(long-short)+short
12660 C      rkprim=short
12661
12662 C now costhet_grad
12663        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12664 C       cosphi=0.6
12665        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12666        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12667      &      dist_pep_side**2)
12668 C       sinphi=0.8
12669        do j=1,3
12670          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12671      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12672      &*(long-short)/fac_alfa_sin*cosalfa/
12673      &((dist_pep_side*dist_side_calf))*
12674      &((side_calf(j))-cosalfa*
12675      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12676 C       cosphi_grad_long(j)=0.0d0
12677         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12678      &*(long-short)/fac_alfa_sin*cosalfa
12679      &/((dist_pep_side*dist_side_calf))*
12680      &(pep_side(j)-
12681      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12682 C       cosphi_grad_loc(j)=0.0d0
12683        enddo
12684 C      print *,sinphi,sinthet
12685 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12686 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12687       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12688      &                    /VSolvSphere_div
12689 C     &                    *wshield
12690 C now the gradient...
12691       do j=1,3
12692       grad_shield(j,i)=grad_shield(j,i)
12693 C gradient po skalowaniu
12694      &                +(sh_frac_dist_grad(j)*VofOverlap
12695 C  gradient po costhet
12696      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12697      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12698      &       sinphi/sinthet*costhet*costhet_grad(j)
12699      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12700      & )*wshield
12701 C grad_shield_side is Cbeta sidechain gradient
12702       grad_shield_side(j,ishield_list(i),i)=
12703      &        (sh_frac_dist_grad(j)*(-2.0d0)
12704      &        *VofOverlap
12705      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12706      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12707      &       sinphi/sinthet*costhet*costhet_grad(j)
12708      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12709      &       )*wshield
12710
12711        grad_shield_loc(j,ishield_list(i),i)=
12712      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12713      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12714      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12715      &        ))
12716      &        *wshield
12717       enddo
12718 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12719 c     & scale_fac_dist
12720       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12721       enddo
12722       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12723 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12724 c     &  " wshield",wshield
12725 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12726       enddo
12727       return
12728       end
12729 C-----------------------------------------------------------------------
12730 C-----------------------------------------------------------
12731 C This subroutine is to mimic the histone like structure but as well can be
12732 C utilizet to nanostructures (infinit) small modification has to be used to
12733 C make it finite (z gradient at the ends has to be changes as well as the x,y
12734 C gradient has to be modified at the ends
12735 C The energy function is Kihara potential
12736 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12737 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12738 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12739 C simple Kihara potential
12740       subroutine calctube(Etube)
12741        implicit real*8 (a-h,o-z)
12742       include 'DIMENSIONS'
12743       include 'COMMON.GEO'
12744       include 'COMMON.VAR'
12745       include 'COMMON.LOCAL'
12746       include 'COMMON.CHAIN'
12747       include 'COMMON.DERIV'
12748       include 'COMMON.NAMES'
12749       include 'COMMON.INTERACT'
12750       include 'COMMON.IOUNITS'
12751       include 'COMMON.CALC'
12752       include 'COMMON.CONTROL'
12753       include 'COMMON.SPLITELE'
12754       include 'COMMON.SBRIDGE'
12755       double precision tub_r,vectube(3),enetube(maxres*2)
12756       Etube=0.0d0
12757       do i=1,2*nres
12758         enetube(i)=0.0d0
12759       enddo
12760 C first we calculate the distance from tube center
12761 C first sugare-phosphate group for NARES this would be peptide group
12762 C for UNRES
12763       do i=1,nres
12764 C lets ommit dummy atoms for now
12765        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12766 C now calculate distance from center of tube and direction vectors
12767       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12768           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12769       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12770           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12771       vectube(1)=vectube(1)-tubecenter(1)
12772       vectube(2)=vectube(2)-tubecenter(2)
12773
12774 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12775 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12776
12777 C as the tube is infinity we do not calculate the Z-vector use of Z
12778 C as chosen axis
12779       vectube(3)=0.0d0
12780 C now calculte the distance
12781        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12782 C now normalize vector
12783       vectube(1)=vectube(1)/tub_r
12784       vectube(2)=vectube(2)/tub_r
12785 C calculte rdiffrence between r and r0
12786       rdiff=tub_r-tubeR0
12787 C and its 6 power
12788       rdiff6=rdiff**6.0d0
12789 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12790        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12791 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12792 C       print *,rdiff,rdiff6,pep_aa_tube
12793 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12794 C now we calculate gradient
12795        fac=(-12.0d0*pep_aa_tube/rdiff6+
12796      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12797 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12798 C     &rdiff,fac
12799
12800 C now direction of gg_tube vector
12801         do j=1,3
12802         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12803         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12804         enddo
12805         enddo
12806 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12807         do i=1,nres
12808 C Lets not jump over memory as we use many times iti
12809          iti=itype(i)
12810 C lets ommit dummy atoms for now
12811          if ((iti.eq.ntyp1)
12812 C in UNRES uncomment the line below as GLY has no side-chain...
12813 C      .or.(iti.eq.10)
12814      &   ) cycle
12815           vectube(1)=c(1,i+nres)
12816           vectube(1)=mod(vectube(1),boxxsize)
12817           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12818           vectube(2)=c(2,i+nres)
12819           vectube(2)=mod(vectube(2),boxxsize)
12820           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12821
12822       vectube(1)=vectube(1)-tubecenter(1)
12823       vectube(2)=vectube(2)-tubecenter(2)
12824
12825 C as the tube is infinity we do not calculate the Z-vector use of Z
12826 C as chosen axis
12827       vectube(3)=0.0d0
12828 C now calculte the distance
12829        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12830 C now normalize vector
12831       vectube(1)=vectube(1)/tub_r
12832       vectube(2)=vectube(2)/tub_r
12833 C calculte rdiffrence between r and r0
12834       rdiff=tub_r-tubeR0
12835 C and its 6 power
12836       rdiff6=rdiff**6.0d0
12837 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12838        sc_aa_tube=sc_aa_tube_par(iti)
12839        sc_bb_tube=sc_bb_tube_par(iti)
12840        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12841 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12842 C now we calculate gradient
12843        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12844      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12845 C now direction of gg_tube vector
12846          do j=1,3
12847           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12848           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12849          enddo
12850         enddo
12851         do i=1,2*nres
12852           Etube=Etube+enetube(i)
12853         enddo
12854 C        print *,"ETUBE", etube
12855         return
12856         end
12857 C TO DO 1) add to total energy
12858 C       2) add to gradient summation
12859 C       3) add reading parameters (AND of course oppening of PARAM file)
12860 C       4) add reading the center of tube
12861 C       5) add COMMONs
12862 C       6) add to zerograd
12863
12864 C-----------------------------------------------------------------------
12865 C-----------------------------------------------------------
12866 C This subroutine is to mimic the histone like structure but as well can be
12867 C utilizet to nanostructures (infinit) small modification has to be used to
12868 C make it finite (z gradient at the ends has to be changes as well as the x,y
12869 C gradient has to be modified at the ends
12870 C The energy function is Kihara potential
12871 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12872 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12873 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12874 C simple Kihara potential
12875       subroutine calctube2(Etube)
12876        implicit real*8 (a-h,o-z)
12877       include 'DIMENSIONS'
12878       include 'COMMON.GEO'
12879       include 'COMMON.VAR'
12880       include 'COMMON.LOCAL'
12881       include 'COMMON.CHAIN'
12882       include 'COMMON.DERIV'
12883       include 'COMMON.NAMES'
12884       include 'COMMON.INTERACT'
12885       include 'COMMON.IOUNITS'
12886       include 'COMMON.CALC'
12887       include 'COMMON.CONTROL'
12888       include 'COMMON.SPLITELE'
12889       include 'COMMON.SBRIDGE'
12890       double precision tub_r,vectube(3),enetube(maxres*2)
12891       Etube=0.0d0
12892       do i=1,2*nres
12893         enetube(i)=0.0d0
12894       enddo
12895 C first we calculate the distance from tube center
12896 C first sugare-phosphate group for NARES this would be peptide group
12897 C for UNRES
12898       do i=1,nres
12899 C lets ommit dummy atoms for now
12900        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12901 C now calculate distance from center of tube and direction vectors
12902       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12903           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12904       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12905           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12906       vectube(1)=vectube(1)-tubecenter(1)
12907       vectube(2)=vectube(2)-tubecenter(2)
12908
12909 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12910 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12911
12912 C as the tube is infinity we do not calculate the Z-vector use of Z
12913 C as chosen axis
12914       vectube(3)=0.0d0
12915 C now calculte the distance
12916        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12917 C now normalize vector
12918       vectube(1)=vectube(1)/tub_r
12919       vectube(2)=vectube(2)/tub_r
12920 C calculte rdiffrence between r and r0
12921       rdiff=tub_r-tubeR0
12922 C and its 6 power
12923       rdiff6=rdiff**6.0d0
12924 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12925        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12926 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12927 C       print *,rdiff,rdiff6,pep_aa_tube
12928 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12929 C now we calculate gradient
12930        fac=(-12.0d0*pep_aa_tube/rdiff6+
12931      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12932 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12933 C     &rdiff,fac
12934
12935 C now direction of gg_tube vector
12936         do j=1,3
12937         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12938         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12939         enddo
12940         enddo
12941 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12942         do i=1,nres
12943 C Lets not jump over memory as we use many times iti
12944          iti=itype(i)
12945 C lets ommit dummy atoms for now
12946          if ((iti.eq.ntyp1)
12947 C in UNRES uncomment the line below as GLY has no side-chain...
12948      &      .or.(iti.eq.10)
12949      &   ) cycle
12950           vectube(1)=c(1,i+nres)
12951           vectube(1)=mod(vectube(1),boxxsize)
12952           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12953           vectube(2)=c(2,i+nres)
12954           vectube(2)=mod(vectube(2),boxxsize)
12955           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12956
12957       vectube(1)=vectube(1)-tubecenter(1)
12958       vectube(2)=vectube(2)-tubecenter(2)
12959 C THIS FRAGMENT MAKES TUBE FINITE
12960         positi=(mod(c(3,i+nres),boxzsize))
12961         if (positi.le.0) positi=positi+boxzsize
12962 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12963 c for each residue check if it is in lipid or lipid water border area
12964 C       respos=mod(c(3,i+nres),boxzsize)
12965        print *,positi,bordtubebot,buftubebot,bordtubetop
12966        if ((positi.gt.bordtubebot)
12967      & .and.(positi.lt.bordtubetop)) then
12968 C the energy transfer exist
12969         if (positi.lt.buftubebot) then
12970          fracinbuf=1.0d0-
12971      &     ((positi-bordtubebot)/tubebufthick)
12972 C lipbufthick is thickenes of lipid buffore
12973          sstube=sscalelip(fracinbuf)
12974          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12975          print *,ssgradtube, sstube,tubetranene(itype(i))
12976          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12977          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12978      &+ssgradtube*tubetranene(itype(i))
12979          gg_tube(3,i-1)= gg_tube(3,i-1)
12980      &+ssgradtube*tubetranene(itype(i))
12981 C         print *,"doing sccale for lower part"
12982         elseif (positi.gt.buftubetop) then
12983          fracinbuf=1.0d0-
12984      &((bordtubetop-positi)/tubebufthick)
12985          sstube=sscalelip(fracinbuf)
12986          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12987          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12988 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12989 C     &+ssgradtube*tubetranene(itype(i))
12990 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12991 C     &+ssgradtube*tubetranene(itype(i))
12992 C          print *, "doing sscalefor top part",sslip,fracinbuf
12993         else
12994          sstube=1.0d0
12995          ssgradtube=0.0d0
12996          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12997 C         print *,"I am in true lipid"
12998         endif
12999         else
13000 C          sstube=0.0d0
13001 C          ssgradtube=0.0d0
13002         cycle
13003         endif ! if in lipid or buffor
13004 CEND OF FINITE FRAGMENT
13005 C as the tube is infinity we do not calculate the Z-vector use of Z
13006 C as chosen axis
13007       vectube(3)=0.0d0
13008 C now calculte the distance
13009        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13010 C now normalize vector
13011       vectube(1)=vectube(1)/tub_r
13012       vectube(2)=vectube(2)/tub_r
13013 C calculte rdiffrence between r and r0
13014       rdiff=tub_r-tubeR0
13015 C and its 6 power
13016       rdiff6=rdiff**6.0d0
13017 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13018        sc_aa_tube=sc_aa_tube_par(iti)
13019        sc_bb_tube=sc_bb_tube_par(iti)
13020        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13021      &                 *sstube+enetube(i+nres)
13022 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13023 C now we calculate gradient
13024        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13025      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13026 C now direction of gg_tube vector
13027          do j=1,3
13028           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13029           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13030          enddo
13031          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13032      &+ssgradtube*enetube(i+nres)/sstube
13033          gg_tube(3,i-1)= gg_tube(3,i-1)
13034      &+ssgradtube*enetube(i+nres)/sstube
13035
13036         enddo
13037         do i=1,2*nres
13038           Etube=Etube+enetube(i)
13039         enddo
13040 C        print *,"ETUBE", etube
13041         return
13042         end
13043 C TO DO 1) add to total energy
13044 C       2) add to gradient summation
13045 C       3) add reading parameters (AND of course oppening of PARAM file)
13046 C       4) add reading the center of tube
13047 C       5) add COMMONs
13048 C       6) add to zerograd
13049 c----------------------------------------------------------------------------
13050       subroutine e_saxs(Esaxs_constr)
13051       implicit none
13052       include 'DIMENSIONS'
13053 #ifdef MPI
13054       include "mpif.h"
13055       include "COMMON.SETUP"
13056       integer IERR
13057 #endif
13058       include 'COMMON.SBRIDGE'
13059       include 'COMMON.CHAIN'
13060       include 'COMMON.GEO'
13061       include 'COMMON.DERIV'
13062       include 'COMMON.LOCAL'
13063       include 'COMMON.INTERACT'
13064       include 'COMMON.VAR'
13065       include 'COMMON.IOUNITS'
13066 c      include 'COMMON.MD'
13067 #ifdef LANG0
13068 #ifdef FIVEDIAG
13069       include 'COMMON.LANGEVIN.lang0.5diag'
13070 #else
13071       include 'COMMON.LANGEVIN.lang0'
13072 #endif
13073 #else
13074       include 'COMMON.LANGEVIN'
13075 #endif
13076       include 'COMMON.CONTROL'
13077       include 'COMMON.SAXS'
13078       include 'COMMON.NAMES'
13079       include 'COMMON.TIME1'
13080       include 'COMMON.FFIELD'
13081 c
13082       double precision Esaxs_constr
13083       integer i,iint,j,k,l
13084       double precision PgradC(maxSAXS,3,maxres),
13085      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13086 #ifdef MPI
13087       double precision PgradC_(maxSAXS,3,maxres),
13088      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13089 #endif
13090       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13091      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13092      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13093      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13094       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13095       double precision dist,mygauss,mygaussder
13096       external dist
13097       integer llicz,lllicz
13098       double precision time01
13099 c  SAXS restraint penalty function
13100 #ifdef DEBUG
13101       write(iout,*) "------- SAXS penalty function start -------"
13102       write (iout,*) "nsaxs",nsaxs
13103       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13104       write (iout,*) "Psaxs"
13105       do i=1,nsaxs
13106         write (iout,'(i5,e15.5)') i, Psaxs(i)
13107       enddo
13108 #endif
13109 #ifdef TIMING
13110       time01=MPI_Wtime()
13111 #endif
13112       Esaxs_constr = 0.0d0
13113       do k=1,nsaxs
13114         Pcalc(k)=0.0d0
13115         do j=1,nres
13116           do l=1,3
13117             PgradC(k,l,j)=0.0d0
13118             PgradX(k,l,j)=0.0d0
13119           enddo
13120         enddo
13121       enddo
13122 c      lllicz=0
13123       do i=iatsc_s,iatsc_e
13124        if (itype(i).eq.ntyp1) cycle
13125        do iint=1,nint_gr(i)
13126          do j=istart(i,iint),iend(i,iint)
13127            if (itype(j).eq.ntyp1) cycle
13128 #ifdef ALLSAXS
13129            dijCACA=dist(i,j)
13130            dijCASC=dist(i,j+nres)
13131            dijSCCA=dist(i+nres,j)
13132            dijSCSC=dist(i+nres,j+nres)
13133            sigma2CACA=2.0d0/(pstok**2)
13134            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13135            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13136            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13137            do k=1,nsaxs
13138              dk = distsaxs(k)
13139              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13140              if (itype(j).ne.10) then
13141              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13142              else
13143              endif
13144              expCASC = 0.0d0
13145              if (itype(i).ne.10) then
13146              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13147              else
13148              expSCCA = 0.0d0
13149              endif
13150              if (itype(i).ne.10 .and. itype(j).ne.10) then
13151              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13152              else
13153              expSCSC = 0.0d0
13154              endif
13155              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13156 #ifdef DEBUG
13157              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13158 #endif
13159              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13160              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13161              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13162              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13163              do l=1,3
13164 c CA CA
13165                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13166                PgradC(k,l,i) = PgradC(k,l,i)-aux
13167                PgradC(k,l,j) = PgradC(k,l,j)+aux
13168 c CA SC
13169                if (itype(j).ne.10) then
13170                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13171                PgradC(k,l,i) = PgradC(k,l,i)-aux
13172                PgradC(k,l,j) = PgradC(k,l,j)+aux
13173                PgradX(k,l,j) = PgradX(k,l,j)+aux
13174                endif
13175 c SC CA
13176                if (itype(i).ne.10) then
13177                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13178                PgradX(k,l,i) = PgradX(k,l,i)-aux
13179                PgradC(k,l,i) = PgradC(k,l,i)-aux
13180                PgradC(k,l,j) = PgradC(k,l,j)+aux
13181                endif
13182 c SC SC
13183                if (itype(i).ne.10 .and. itype(j).ne.10) then
13184                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13185                PgradC(k,l,i) = PgradC(k,l,i)-aux
13186                PgradC(k,l,j) = PgradC(k,l,j)+aux
13187                PgradX(k,l,i) = PgradX(k,l,i)-aux
13188                PgradX(k,l,j) = PgradX(k,l,j)+aux
13189                endif
13190              enddo ! l
13191            enddo ! k
13192 #else
13193            dijCACA=dist(i,j)
13194            sigma2CACA=scal_rad**2*0.25d0/
13195      &        (restok(itype(j))**2+restok(itype(i))**2)
13196 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13197 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13198 #ifdef MYGAUSS
13199            sigmaCACA=dsqrt(sigma2CACA)
13200            threesig=3.0d0/sigmaCACA
13201 c           llicz=0
13202            do k=1,nsaxs
13203              dk = distsaxs(k)
13204              if (dabs(dijCACA-dk).ge.threesig) cycle
13205 c             llicz=llicz+1
13206 c             lllicz=lllicz+1
13207              aux = sigmaCACA*(dijCACA-dk)
13208              expCACA = mygauss(aux)
13209 c             if (expcaca.eq.0.0d0) cycle
13210              Pcalc(k) = Pcalc(k)+expCACA
13211              CACAgrad = -sigmaCACA*mygaussder(aux)
13212 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13213              do l=1,3
13214                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13215                PgradC(k,l,i) = PgradC(k,l,i)-aux
13216                PgradC(k,l,j) = PgradC(k,l,j)+aux
13217              enddo ! l
13218            enddo ! k
13219 c           write (iout,*) "i",i," j",j," llicz",llicz
13220 #else
13221            IF (saxs_cutoff.eq.0) THEN
13222            do k=1,nsaxs
13223              dk = distsaxs(k)
13224              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13225              Pcalc(k) = Pcalc(k)+expCACA
13226              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13227              do l=1,3
13228                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13229                PgradC(k,l,i) = PgradC(k,l,i)-aux
13230                PgradC(k,l,j) = PgradC(k,l,j)+aux
13231              enddo ! l
13232            enddo ! k
13233            ELSE
13234            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13235            do k=1,nsaxs
13236              dk = distsaxs(k)
13237 c             write (2,*) "ijk",i,j,k
13238              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13239              if (sss2.eq.0.0d0) cycle
13240              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13241              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13242      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13243      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13244      &           sss2,ssgrad2
13245              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13246              Pcalc(k) = Pcalc(k)+expCACA
13247 #ifdef DEBUG
13248              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13249 #endif
13250              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13251      &             ssgrad2*expCACA/sss2
13252              do l=1,3
13253 c CA CA
13254                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13255                PgradC(k,l,i) = PgradC(k,l,i)+aux
13256                PgradC(k,l,j) = PgradC(k,l,j)-aux
13257              enddo ! l
13258            enddo ! k
13259            ENDIF
13260 #endif
13261 #endif
13262          enddo ! j
13263        enddo ! iint
13264       enddo ! i
13265 c#ifdef TIMING
13266 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13267 c#endif
13268 c      write (iout,*) "lllicz",lllicz
13269 c#ifdef TIMING
13270 c      time01=MPI_Wtime()
13271 c#endif
13272 #ifdef MPI
13273       if (nfgtasks.gt.1) then
13274        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13275      &    MPI_SUM,FG_COMM,IERR)
13276 c        if (fg_rank.eq.king) then
13277           do k=1,nsaxs
13278             Pcalc(k) = Pcalc_(k)
13279           enddo
13280 c        endif
13281 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13282 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13283 c        if (fg_rank.eq.king) then
13284 c          do i=1,nres
13285 c            do l=1,3
13286 c              do k=1,nsaxs
13287 c                PgradC(k,l,i) = PgradC_(k,l,i)
13288 c              enddo
13289 c            enddo
13290 c          enddo
13291 c        endif
13292 #ifdef ALLSAXS
13293 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13294 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13295 c        if (fg_rank.eq.king) then
13296 c          do i=1,nres
13297 c            do l=1,3
13298 c              do k=1,nsaxs
13299 c                PgradX(k,l,i) = PgradX_(k,l,i)
13300 c              enddo
13301 c            enddo
13302 c          enddo
13303 c        endif
13304 #endif
13305       endif
13306 #endif
13307       Cnorm = 0.0d0
13308       do k=1,nsaxs
13309         Cnorm = Cnorm + Pcalc(k)
13310       enddo
13311 #ifdef MPI
13312       if (fg_rank.eq.king) then
13313 #endif
13314       Esaxs_constr = dlog(Cnorm)-wsaxs0
13315       do k=1,nsaxs
13316         if (Pcalc(k).gt.0.0d0)
13317      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13318 #ifdef DEBUG
13319         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13320 #endif
13321       enddo
13322 #ifdef DEBUG
13323       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13324 #endif
13325 #ifdef MPI
13326       endif
13327 #endif
13328       gsaxsC=0.0d0
13329       gsaxsX=0.0d0
13330       do i=nnt,nct
13331         do l=1,3
13332           auxC=0.0d0
13333           auxC1=0.0d0
13334           auxX=0.0d0
13335           auxX1=0.d0
13336           do k=1,nsaxs
13337             if (Pcalc(k).gt.0)
13338      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13339             auxC1 = auxC1+PgradC(k,l,i)
13340 #ifdef ALLSAXS
13341             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13342             auxX1 = auxX1+PgradX(k,l,i)
13343 #endif
13344           enddo
13345           gsaxsC(l,i) = auxC - auxC1/Cnorm
13346 #ifdef ALLSAXS
13347           gsaxsX(l,i) = auxX - auxX1/Cnorm
13348 #endif
13349 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13350 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13351 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13352 c     *     " gradX",wsaxs*gsaxsX(l,i)
13353         enddo
13354       enddo
13355 #ifdef TIMING
13356       time_SAXS=time_SAXS+MPI_Wtime()-time01
13357 #endif
13358 #ifdef DEBUG
13359       write (iout,*) "gsaxsc"
13360       do i=nnt,nct
13361         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13362       enddo
13363 #endif
13364 #ifdef MPI
13365 c      endif
13366 #endif
13367       return
13368       end
13369 c----------------------------------------------------------------------------
13370       subroutine e_saxsC(Esaxs_constr)
13371       implicit none
13372       include 'DIMENSIONS'
13373 #ifdef MPI
13374       include "mpif.h"
13375       include "COMMON.SETUP"
13376       integer IERR
13377 #endif
13378       include 'COMMON.SBRIDGE'
13379       include 'COMMON.CHAIN'
13380       include 'COMMON.GEO'
13381       include 'COMMON.DERIV'
13382       include 'COMMON.LOCAL'
13383       include 'COMMON.INTERACT'
13384       include 'COMMON.VAR'
13385       include 'COMMON.IOUNITS'
13386 c      include 'COMMON.MD'
13387 #ifdef LANG0
13388 #ifdef FIVEDIAG
13389       include 'COMMON.LANGEVIN.lang0.5diag'
13390 #else
13391       include 'COMMON.LANGEVIN.lang0'
13392 #endif
13393 #else
13394       include 'COMMON.LANGEVIN'
13395 #endif
13396       include 'COMMON.CONTROL'
13397       include 'COMMON.SAXS'
13398       include 'COMMON.NAMES'
13399       include 'COMMON.TIME1'
13400       include 'COMMON.FFIELD'
13401 c
13402       double precision Esaxs_constr
13403       integer i,iint,j,k,l
13404       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13405 #ifdef MPI
13406       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13407 #endif
13408       double precision dk,dijCASPH,dijSCSPH,
13409      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13410      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13411      & auxX,auxX1,Cnorm
13412 c  SAXS restraint penalty function
13413 #ifdef DEBUG
13414       write(iout,*) "------- SAXS penalty function start -------"
13415       write (iout,*) "nsaxs",nsaxs
13416
13417       do i=nnt,nct
13418         print *,MyRank,"C",i,(C(j,i),j=1,3)
13419       enddo
13420       do i=nnt,nct
13421         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13422       enddo
13423 #endif
13424       Esaxs_constr = 0.0d0
13425       logPtot=0.0d0
13426       do j=isaxs_start,isaxs_end
13427         Pcalc=0.0d0
13428         do i=1,nres
13429           do l=1,3
13430             PgradC(l,i)=0.0d0
13431             PgradX(l,i)=0.0d0
13432           enddo
13433         enddo
13434         do i=nnt,nct
13435           if (itype(i).eq.ntyp1) cycle
13436           dijCASPH=0.0d0
13437           dijSCSPH=0.0d0
13438           do l=1,3
13439             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13440           enddo
13441           if (itype(i).ne.10) then
13442           do l=1,3
13443             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13444           enddo
13445           endif
13446           sigma2CA=2.0d0/pstok**2
13447           sigma2SC=4.0d0/restok(itype(i))**2
13448           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13449           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13450           Pcalc = Pcalc+expCASPH+expSCSPH
13451 #ifdef DEBUG
13452           write(*,*) "processor i j Pcalc",
13453      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13454 #endif
13455           CASPHgrad = sigma2CA*expCASPH
13456           SCSPHgrad = sigma2SC*expSCSPH
13457           do l=1,3
13458             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13459             PgradX(l,i) = PgradX(l,i) + aux
13460             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13461           enddo ! l
13462         enddo ! i
13463         do i=nnt,nct
13464           do l=1,3
13465             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13466             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13467           enddo
13468         enddo
13469         logPtot = logPtot - dlog(Pcalc)
13470 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13471 c     &    " logPtot",logPtot
13472       enddo ! j
13473 #ifdef MPI
13474       if (nfgtasks.gt.1) then
13475 c        write (iout,*) "logPtot before reduction",logPtot
13476         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13477      &    MPI_SUM,king,FG_COMM,IERR)
13478         logPtot = logPtot_
13479 c        write (iout,*) "logPtot after reduction",logPtot
13480         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13481      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13482         if (fg_rank.eq.king) then
13483           do i=1,nres
13484             do l=1,3
13485               gsaxsC(l,i) = gsaxsC_(l,i)
13486             enddo
13487           enddo
13488         endif
13489         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13490      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13491         if (fg_rank.eq.king) then
13492           do i=1,nres
13493             do l=1,3
13494               gsaxsX(l,i) = gsaxsX_(l,i)
13495             enddo
13496           enddo
13497         endif
13498       endif
13499 #endif
13500       Esaxs_constr = logPtot
13501       return
13502       end
13503 c----------------------------------------------------------------------------
13504       double precision function sscale2(r,r_cut,r0,rlamb)
13505       implicit none
13506       double precision r,gamm,r_cut,r0,rlamb,rr
13507       rr = dabs(r-r0)
13508 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13509 c      write (2,*) "rr",rr
13510       if(rr.lt.r_cut-rlamb) then
13511         sscale2=1.0d0
13512       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13513         gamm=(rr-(r_cut-rlamb))/rlamb
13514         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13515       else
13516         sscale2=0d0
13517       endif
13518       return
13519       end
13520 C-----------------------------------------------------------------------
13521       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13522       implicit none
13523       double precision r,gamm,r_cut,r0,rlamb,rr
13524       rr = dabs(r-r0)
13525       if(rr.lt.r_cut-rlamb) then
13526         sscalgrad2=0.0d0
13527       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13528         gamm=(rr-(r_cut-rlamb))/rlamb
13529         if (r.ge.r0) then
13530           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13531         else
13532           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13533         endif
13534       else
13535         sscalgrad2=0.0d0
13536       endif
13537       return
13538       end