source/unres/src_MD-M-SAXS/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       include 'COMMON.SPLITELE'
1453 #ifdef FOURBODY
1454       include 'COMMON.CONTACTS'
1455       include 'COMMON.CONTMAT'
1456 #endif
1457       double precision gg(3)
1458       double precision evdw,evdwij
1459       integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1460       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1461      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1462       double precision fcont,fprimcont
1463       double precision sscale,sscagrad
1464 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1465       evdw=0.0D0
1466       do i=iatsc_s,iatsc_e
1467         itypi=iabs(itype(i))
1468         if (itypi.eq.ntyp1) cycle
1469         itypi1=iabs(itype(i+1))
1470         xi=c(1,nres+i)
1471         yi=c(2,nres+i)
1472         zi=c(3,nres+i)
1473 C Change 12/1/95
1474         num_conti=0
1475 C
1476 C Calculate SC interaction energy.
1477 C
1478         do iint=1,nint_gr(i)
1479 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1480 cd   &                  'iend=',iend(i,iint)
1481           do j=istart(i,iint),iend(i,iint)
1482             itypj=iabs(itype(j))
1483             if (itypj.eq.ntyp1) cycle
1484             xj=c(1,nres+j)-xi
1485             yj=c(2,nres+j)-yi
1486             zj=c(3,nres+j)-zi
1487 C Change 12/1/95 to calculate four-body interactions
1488             rij=xj*xj+yj*yj+zj*zj
1489             rrij=1.0D0/rij
1490             sqrij=dsqrt(rij)
1491             sss1=sscale(sqrij,r_cut_int)
1492             if (sss1.eq.0.0d0) cycle
1493             sssgrad1=sscagrad(sqrij,r_cut_int)
1494
1495 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1496             eps0ij=eps(itypi,itypj)
1497             fac=rrij**expon2
1498 C have you changed here?
1499             e1=fac*fac*aa
1500             e2=fac*bb
1501             evdwij=e1+e2
1502 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1503 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1504 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1505 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1506 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1507 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1508             evdw=evdw+sss1*evdwij
1509 C
1510 C Calculate the components of the gradient in DC and X
1511 C
1512             fac=-rrij*(e1+evdwij)
1513      &          +evdwij*sssgrad1/sqrij
1514             gg(1)=xj*fac
1515             gg(2)=yj*fac
1516             gg(3)=zj*fac
1517             do k=1,3
1518               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1519               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1520               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1521               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1522             enddo
1523 cgrad            do k=i,j-1
1524 cgrad              do l=1,3
1525 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1526 cgrad              enddo
1527 cgrad            enddo
1528 C
1529 #ifdef FOURBODY
1530 C 12/1/95, revised on 5/20/97
1531 C
1532 C Calculate the contact function. The ith column of the array JCONT will
1533 C contain the numbers of atoms that make contacts with the atom I (of numbers
1534 C greater than I). The arrays FACONT and GACONT will contain the values of
1535 C the contact function and its derivative.
1536 C
1537 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1538 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1539 C Uncomment next line, if the correlation interactions are contact function only
1540             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1541               rij=dsqrt(rij)
1542               sigij=sigma(itypi,itypj)
1543               r0ij=rs0(itypi,itypj)
1544 C
1545 C Check whether the SC's are not too far to make a contact.
1546 C
1547               rcut=1.5d0*r0ij
1548               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1549 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1550 C
1551               if (fcont.gt.0.0D0) then
1552 C If the SC-SC distance if close to sigma, apply spline.
1553 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1554 cAdam &             fcont1,fprimcont1)
1555 cAdam           fcont1=1.0d0-fcont1
1556 cAdam           if (fcont1.gt.0.0d0) then
1557 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1558 cAdam             fcont=fcont*fcont1
1559 cAdam           endif
1560 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1561 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1562 cga             do k=1,3
1563 cga               gg(k)=gg(k)*eps0ij
1564 cga             enddo
1565 cga             eps0ij=-evdwij*eps0ij
1566 C Uncomment for AL's type of SC correlation interactions.
1567 cadam           eps0ij=-evdwij
1568                 num_conti=num_conti+1
1569                 jcont(num_conti,i)=j
1570                 facont(num_conti,i)=fcont*eps0ij
1571                 fprimcont=eps0ij*fprimcont/rij
1572                 fcont=expon*fcont
1573 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1574 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1575 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1576 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1577                 gacont(1,num_conti,i)=-fprimcont*xj
1578                 gacont(2,num_conti,i)=-fprimcont*yj
1579                 gacont(3,num_conti,i)=-fprimcont*zj
1580 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1581 cd              write (iout,'(2i3,3f10.5)')
1582 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1583               endif
1584             endif
1585 #endif
1586           enddo      ! j
1587         enddo        ! iint
1588 C Change 12/1/95
1589 #ifdef FOURBODY
1590         num_cont(i)=num_conti
1591 #endif
1592       enddo          ! i
1593       do i=1,nct
1594         do j=1,3
1595           gvdwc(j,i)=expon*gvdwc(j,i)
1596           gvdwx(j,i)=expon*gvdwx(j,i)
1597         enddo
1598       enddo
1599 C******************************************************************************
1600 C
1601 C                              N O T E !!!
1602 C
1603 C To save time, the factor of EXPON has been extracted from ALL components
1604 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1605 C use!
1606 C
1607 C******************************************************************************
1608       return
1609       end
1610 C-----------------------------------------------------------------------------
1611       subroutine eljk(evdw)
1612 C
1613 C This subroutine calculates the interaction energy of nonbonded side chains
1614 C assuming the LJK potential of interaction.
1615 C
1616       implicit none
1617       include 'DIMENSIONS'
1618       include 'COMMON.GEO'
1619       include 'COMMON.VAR'
1620       include 'COMMON.LOCAL'
1621       include 'COMMON.CHAIN'
1622       include 'COMMON.DERIV'
1623       include 'COMMON.INTERACT'
1624       include 'COMMON.IOUNITS'
1625       include 'COMMON.NAMES'
1626       include 'COMMON.SPLITELE'
1627       double precision gg(3)
1628       double precision evdw,evdwij
1629       integer i,j,k,itypi,itypj,itypi1,iint
1630       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1631      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1632       logical scheck
1633       double precision sscale,sscagrad
1634 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1635       evdw=0.0D0
1636       do i=iatsc_s,iatsc_e
1637         itypi=iabs(itype(i))
1638         if (itypi.eq.ntyp1) cycle
1639         itypi1=iabs(itype(i+1))
1640         xi=c(1,nres+i)
1641         yi=c(2,nres+i)
1642         zi=c(3,nres+i)
1643 C
1644 C Calculate SC interaction energy.
1645 C
1646         do iint=1,nint_gr(i)
1647           do j=istart(i,iint),iend(i,iint)
1648             itypj=iabs(itype(j))
1649             if (itypj.eq.ntyp1) cycle
1650             xj=c(1,nres+j)-xi
1651             yj=c(2,nres+j)-yi
1652             zj=c(3,nres+j)-zi
1653             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1654             fac_augm=rrij**expon
1655             e_augm=augm(itypi,itypj)*fac_augm
1656             r_inv_ij=dsqrt(rrij)
1657             rij=1.0D0/r_inv_ij
1658             sss1=sscale(rij,r_cut_int)
1659             if (sss1.eq.0.0d0) cycle
1660             sssgrad1=sscagrad(rij,r_cut_int)
1661             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1662             fac=r_shift_inv**expon
1663 C have you changed here?
1664             e1=fac*fac*aa
1665             e2=fac*bb
1666             evdwij=e_augm+e1+e2
1667 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1668 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1669 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1670 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1671 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1672 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1673 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1674             evdw=evdw+evdwij
1675 C
1676 C Calculate the components of the gradient in DC and X
1677 C
1678             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1679      &          +evdwij*sssgrad1*r_inv_ij
1680             gg(1)=xj*fac
1681             gg(2)=yj*fac
1682             gg(3)=zj*fac
1683             do k=1,3
1684               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1685               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1686               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1687               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1688             enddo
1689 cgrad            do k=i,j-1
1690 cgrad              do l=1,3
1691 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1692 cgrad              enddo
1693 cgrad            enddo
1694           enddo      ! j
1695         enddo        ! iint
1696       enddo          ! i
1697       do i=1,nct
1698         do j=1,3
1699           gvdwc(j,i)=expon*gvdwc(j,i)
1700           gvdwx(j,i)=expon*gvdwx(j,i)
1701         enddo
1702       enddo
1703       return
1704       end
1705 C-----------------------------------------------------------------------------
1706       subroutine ebp(evdw)
1707 C
1708 C This subroutine calculates the interaction energy of nonbonded side chains
1709 C assuming the Berne-Pechukas potential of interaction.
1710 C
1711       implicit none
1712       include 'DIMENSIONS'
1713       include 'COMMON.GEO'
1714       include 'COMMON.VAR'
1715       include 'COMMON.LOCAL'
1716       include 'COMMON.CHAIN'
1717       include 'COMMON.DERIV'
1718       include 'COMMON.NAMES'
1719       include 'COMMON.INTERACT'
1720       include 'COMMON.IOUNITS'
1721       include 'COMMON.CALC'
1722       include 'COMMON.SPLITELE'
1723       integer icall
1724       common /srutu/ icall
1725       double precision evdw
1726       integer itypi,itypj,itypi1,iint,ind
1727       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1728      & sss1,sssgrad1
1729       double precision sscale,sscagrad
1730 c     double precision rrsave(maxdim)
1731       logical lprn
1732       evdw=0.0D0
1733 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1734       evdw=0.0D0
1735 c     if (icall.eq.0) then
1736 c       lprn=.true.
1737 c     else
1738         lprn=.false.
1739 c     endif
1740       ind=0
1741       do i=iatsc_s,iatsc_e
1742         itypi=iabs(itype(i))
1743         if (itypi.eq.ntyp1) cycle
1744         itypi1=iabs(itype(i+1))
1745         xi=c(1,nres+i)
1746         yi=c(2,nres+i)
1747         zi=c(3,nres+i)
1748         dxi=dc_norm(1,nres+i)
1749         dyi=dc_norm(2,nres+i)
1750         dzi=dc_norm(3,nres+i)
1751 c        dsci_inv=dsc_inv(itypi)
1752         dsci_inv=vbld_inv(i+nres)
1753 C
1754 C Calculate SC interaction energy.
1755 C
1756         do iint=1,nint_gr(i)
1757           do j=istart(i,iint),iend(i,iint)
1758             ind=ind+1
1759             itypj=iabs(itype(j))
1760             if (itypj.eq.ntyp1) cycle
1761 c            dscj_inv=dsc_inv(itypj)
1762             dscj_inv=vbld_inv(j+nres)
1763             chi1=chi(itypi,itypj)
1764             chi2=chi(itypj,itypi)
1765             chi12=chi1*chi2
1766             chip1=chip(itypi)
1767             chip2=chip(itypj)
1768             chip12=chip1*chip2
1769             alf1=alp(itypi)
1770             alf2=alp(itypj)
1771             alf12=0.5D0*(alf1+alf2)
1772 C For diagnostics only!!!
1773 c           chi1=0.0D0
1774 c           chi2=0.0D0
1775 c           chi12=0.0D0
1776 c           chip1=0.0D0
1777 c           chip2=0.0D0
1778 c           chip12=0.0D0
1779 c           alf1=0.0D0
1780 c           alf2=0.0D0
1781 c           alf12=0.0D0
1782             xj=c(1,nres+j)-xi
1783             yj=c(2,nres+j)-yi
1784             zj=c(3,nres+j)-zi
1785             dxj=dc_norm(1,nres+j)
1786             dyj=dc_norm(2,nres+j)
1787             dzj=dc_norm(3,nres+j)
1788             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1789 cd          if (icall.eq.0) then
1790 cd            rrsave(ind)=rrij
1791 cd          else
1792 cd            rrij=rrsave(ind)
1793 cd          endif
1794             rij=dsqrt(rrij)
1795             sss1=sscale(1.0d0/rij,r_cut_int)
1796             if (sss1.eq.0.0d0) cycle
1797             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1798 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1799             call sc_angular
1800 C Calculate whole angle-dependent part of epsilon and contributions
1801 C to its derivatives
1802 C have you changed here?
1803             fac=(rrij*sigsq)**expon2
1804             e1=fac*fac*aa
1805             e2=fac*bb
1806             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1807             eps2der=evdwij*eps3rt
1808             eps3der=evdwij*eps2rt
1809             evdwij=evdwij*eps2rt*eps3rt
1810             evdw=evdw+evdwij
1811             if (lprn) then
1812             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1813             epsi=bb**2/aa
1814 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1815 cd     &        restyp(itypi),i,restyp(itypj),j,
1816 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1817 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1818 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1819 cd     &        evdwij
1820             endif
1821 C Calculate gradient components.
1822             e1=e1*eps1*eps2rt**2*eps3rt**2
1823             fac=-expon*(e1+evdwij)
1824             sigder=fac/sigsq
1825             fac=rrij*fac
1826      &          +evdwij*sssgrad1*rij
1827 C Calculate radial part of the gradient
1828             gg(1)=xj*fac
1829             gg(2)=yj*fac
1830             gg(3)=zj*fac
1831 C Calculate the angular part of the gradient and sum add the contributions
1832 C to the appropriate components of the Cartesian gradient.
1833             call sc_grad_scale(sss1)
1834           enddo      ! j
1835         enddo        ! iint
1836       enddo          ! i
1837 c     stop
1838       return
1839       end
1840 C-----------------------------------------------------------------------------
1841       subroutine egb(evdw)
1842 C
1843 C This subroutine calculates the interaction energy of nonbonded side chains
1844 C assuming the Gay-Berne potential of interaction.
1845 C
1846       implicit none
1847       include 'DIMENSIONS'
1848       include 'COMMON.GEO'
1849       include 'COMMON.VAR'
1850       include 'COMMON.LOCAL'
1851       include 'COMMON.CHAIN'
1852       include 'COMMON.DERIV'
1853       include 'COMMON.NAMES'
1854       include 'COMMON.INTERACT'
1855       include 'COMMON.IOUNITS'
1856       include 'COMMON.CALC'
1857       include 'COMMON.CONTROL'
1858       include 'COMMON.SPLITELE'
1859       include 'COMMON.SBRIDGE'
1860       logical lprn
1861       integer xshift,yshift,zshift,subchap
1862       double precision evdw
1863       integer itypi,itypj,itypi1,iint,ind
1864       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1865       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1866      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1867      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1868       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1869       evdw=0.0D0
1870 ccccc      energy_dec=.false.
1871 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1872       evdw=0.0D0
1873       lprn=.false.
1874 c     if (icall.eq.0) lprn=.false.
1875       ind=0
1876 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1877 C we have the original box)
1878 C      do xshift=-1,1
1879 C      do yshift=-1,1
1880 C      do zshift=-1,1
1881       do i=iatsc_s,iatsc_e
1882         itypi=iabs(itype(i))
1883         if (itypi.eq.ntyp1) cycle
1884         itypi1=iabs(itype(i+1))
1885         xi=c(1,nres+i)
1886         yi=c(2,nres+i)
1887         zi=c(3,nres+i)
1888 C Return atom into box, boxxsize is size of box in x dimension
1889 c  134   continue
1890 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1891 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1892 C Condition for being inside the proper box
1893 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1894 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1895 c        go to 134
1896 c        endif
1897 c  135   continue
1898 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1899 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1900 C Condition for being inside the proper box
1901 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1902 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1903 c        go to 135
1904 c        endif
1905 c  136   continue
1906 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1907 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1908 C Condition for being inside the proper box
1909 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1910 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1911 c        go to 136
1912 c        endif
1913           xi=mod(xi,boxxsize)
1914           if (xi.lt.0) xi=xi+boxxsize
1915           yi=mod(yi,boxysize)
1916           if (yi.lt.0) yi=yi+boxysize
1917           zi=mod(zi,boxzsize)
1918           if (zi.lt.0) zi=zi+boxzsize
1919 C define scaling factor for lipids
1920
1921 C        if (positi.le.0) positi=positi+boxzsize
1922 C        print *,i
1923 C first for peptide groups
1924 c for each residue check if it is in lipid or lipid water border area
1925        if ((zi.gt.bordlipbot)
1926      &.and.(zi.lt.bordliptop)) then
1927 C the energy transfer exist
1928         if (zi.lt.buflipbot) then
1929 C what fraction I am in
1930          fracinbuf=1.0d0-
1931      &        ((zi-bordlipbot)/lipbufthick)
1932 C lipbufthick is thickenes of lipid buffore
1933          sslipi=sscalelip(fracinbuf)
1934          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1935         elseif (zi.gt.bufliptop) then
1936          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1937          sslipi=sscalelip(fracinbuf)
1938          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1939         else
1940          sslipi=1.0d0
1941          ssgradlipi=0.0
1942         endif
1943        else
1944          sslipi=0.0d0
1945          ssgradlipi=0.0
1946        endif
1947
1948 C          xi=xi+xshift*boxxsize
1949 C          yi=yi+yshift*boxysize
1950 C          zi=zi+zshift*boxzsize
1951
1952         dxi=dc_norm(1,nres+i)
1953         dyi=dc_norm(2,nres+i)
1954         dzi=dc_norm(3,nres+i)
1955 c        dsci_inv=dsc_inv(itypi)
1956         dsci_inv=vbld_inv(i+nres)
1957 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1958 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1959 C
1960 C Calculate SC interaction energy.
1961 C
1962         do iint=1,nint_gr(i)
1963           do j=istart(i,iint),iend(i,iint)
1964             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1965
1966 c              write(iout,*) "PRZED ZWYKLE", evdwij
1967               call dyn_ssbond_ene(i,j,evdwij)
1968 c              write(iout,*) "PO ZWYKLE", evdwij
1969
1970               evdw=evdw+evdwij
1971               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1972      &                        'evdw',i,j,evdwij,' ss'
1973 C triple bond artifac removal
1974              do k=j+1,iend(i,iint)
1975 C search over all next residues
1976               if (dyn_ss_mask(k)) then
1977 C check if they are cysteins
1978 C              write(iout,*) 'k=',k
1979
1980 c              write(iout,*) "PRZED TRI", evdwij
1981                evdwij_przed_tri=evdwij
1982               call triple_ssbond_ene(i,j,k,evdwij)
1983 c               if(evdwij_przed_tri.ne.evdwij) then
1984 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1985 c               endif
1986
1987 c              write(iout,*) "PO TRI", evdwij
1988 C call the energy function that removes the artifical triple disulfide
1989 C bond the soubroutine is located in ssMD.F
1990               evdw=evdw+evdwij
1991               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1992      &                        'evdw',i,j,evdwij,'tss'
1993               endif!dyn_ss_mask(k)
1994              enddo! k
1995             ELSE
1996             ind=ind+1
1997             itypj=iabs(itype(j))
1998             if (itypj.eq.ntyp1) cycle
1999 c            dscj_inv=dsc_inv(itypj)
2000             dscj_inv=vbld_inv(j+nres)
2001 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2002 c     &       1.0d0/vbld(j+nres)
2003 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2004             sig0ij=sigma(itypi,itypj)
2005             chi1=chi(itypi,itypj)
2006             chi2=chi(itypj,itypi)
2007             chi12=chi1*chi2
2008             chip1=chip(itypi)
2009             chip2=chip(itypj)
2010             chip12=chip1*chip2
2011             alf1=alp(itypi)
2012             alf2=alp(itypj)
2013             alf12=0.5D0*(alf1+alf2)
2014 C For diagnostics only!!!
2015 c           chi1=0.0D0
2016 c           chi2=0.0D0
2017 c           chi12=0.0D0
2018 c           chip1=0.0D0
2019 c           chip2=0.0D0
2020 c           chip12=0.0D0
2021 c           alf1=0.0D0
2022 c           alf2=0.0D0
2023 c           alf12=0.0D0
2024             xj=c(1,nres+j)
2025             yj=c(2,nres+j)
2026             zj=c(3,nres+j)
2027 C Return atom J into box the original box
2028 c  137   continue
2029 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2030 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2031 C Condition for being inside the proper box
2032 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2033 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2034 c        go to 137
2035 c        endif
2036 c  138   continue
2037 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2038 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2039 C Condition for being inside the proper box
2040 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2041 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2042 c        go to 138
2043 c        endif
2044 c  139   continue
2045 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2046 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2047 C Condition for being inside the proper box
2048 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2049 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2050 c        go to 139
2051 c        endif
2052           xj=mod(xj,boxxsize)
2053           if (xj.lt.0) xj=xj+boxxsize
2054           yj=mod(yj,boxysize)
2055           if (yj.lt.0) yj=yj+boxysize
2056           zj=mod(zj,boxzsize)
2057           if (zj.lt.0) zj=zj+boxzsize
2058        if ((zj.gt.bordlipbot)
2059      &.and.(zj.lt.bordliptop)) then
2060 C the energy transfer exist
2061         if (zj.lt.buflipbot) then
2062 C what fraction I am in
2063          fracinbuf=1.0d0-
2064      &        ((zj-bordlipbot)/lipbufthick)
2065 C lipbufthick is thickenes of lipid buffore
2066          sslipj=sscalelip(fracinbuf)
2067          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2068         elseif (zj.gt.bufliptop) then
2069          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2070          sslipj=sscalelip(fracinbuf)
2071          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2072         else
2073          sslipj=1.0d0
2074          ssgradlipj=0.0
2075         endif
2076        else
2077          sslipj=0.0d0
2078          ssgradlipj=0.0
2079        endif
2080       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2081      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2082       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2083      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2084 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2085 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2086 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2087 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2088 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2089       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2090       xj_safe=xj
2091       yj_safe=yj
2092       zj_safe=zj
2093       subchap=0
2094       do xshift=-1,1
2095       do yshift=-1,1
2096       do zshift=-1,1
2097           xj=xj_safe+xshift*boxxsize
2098           yj=yj_safe+yshift*boxysize
2099           zj=zj_safe+zshift*boxzsize
2100           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2101           if(dist_temp.lt.dist_init) then
2102             dist_init=dist_temp
2103             xj_temp=xj
2104             yj_temp=yj
2105             zj_temp=zj
2106             subchap=1
2107           endif
2108        enddo
2109        enddo
2110        enddo
2111        if (subchap.eq.1) then
2112           xj=xj_temp-xi
2113           yj=yj_temp-yi
2114           zj=zj_temp-zi
2115        else
2116           xj=xj_safe-xi
2117           yj=yj_safe-yi
2118           zj=zj_safe-zi
2119        endif
2120             dxj=dc_norm(1,nres+j)
2121             dyj=dc_norm(2,nres+j)
2122             dzj=dc_norm(3,nres+j)
2123 C            xj=xj-xi
2124 C            yj=yj-yi
2125 C            zj=zj-zi
2126 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2127 c            write (iout,*) "j",j," dc_norm",
2128 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2129             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2130             rij=dsqrt(rrij)
2131             sss=sscale(1.0d0/rij,r_cut_int)
2132 c            write (iout,'(a7,4f8.3)')
2133 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2134             if (sss.eq.0.0d0) cycle
2135             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2136 C Calculate angle-dependent terms of energy and contributions to their
2137 C derivatives.
2138             call sc_angular
2139             sigsq=1.0D0/sigsq
2140             sig=sig0ij*dsqrt(sigsq)
2141             rij_shift=1.0D0/rij-sig+sig0ij
2142 c for diagnostics; uncomment
2143 c            rij_shift=1.2*sig0ij
2144 C I hate to put IF's in the loops, but here don't have another choice!!!!
2145             if (rij_shift.le.0.0D0) then
2146               evdw=1.0D20
2147 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2148 cd     &        restyp(itypi),i,restyp(itypj),j,
2149 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2150               return
2151             endif
2152             sigder=-sig*sigsq
2153 c---------------------------------------------------------------
2154             rij_shift=1.0D0/rij_shift
2155             fac=rij_shift**expon
2156 C here to start with
2157 C            if (c(i,3).gt.
2158             faclip=fac
2159             e1=fac*fac*aa
2160             e2=fac*bb
2161             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2162             eps2der=evdwij*eps3rt
2163             eps3der=evdwij*eps2rt
2164 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2165 C     &((sslipi+sslipj)/2.0d0+
2166 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2167 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2168 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2169             evdwij=evdwij*eps2rt*eps3rt
2170             evdw=evdw+evdwij*sss
2171             if (lprn) then
2172             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2173             epsi=bb**2/aa
2174             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2175      &        restyp(itypi),i,restyp(itypj),j,
2176      &        epsi,sigm,chi1,chi2,chip1,chip2,
2177      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2178      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2179      &        evdwij
2180             endif
2181
2182             if (energy_dec) write (iout,'(a,2i5,3f10.5)')
2183      &                    'r sss evdw',i,j,rij,sss,evdwij
2184
2185 C Calculate gradient components.
2186             e1=e1*eps1*eps2rt**2*eps3rt**2
2187             fac=-expon*(e1+evdwij)*rij_shift
2188             sigder=fac*sigder
2189             fac=rij*fac
2190 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2191 c     &      evdwij,fac,sigma(itypi,itypj),expon
2192             fac=fac+evdwij*sssgrad*rij
2193 c            fac=0.0d0
2194 C Calculate the radial part of the gradient
2195             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2196      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2197      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2198      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2199             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2200             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2201 C            gg_lipi(3)=0.0d0
2202 C            gg_lipj(3)=0.0d0
2203             gg(1)=xj*fac
2204             gg(2)=yj*fac
2205             gg(3)=zj*fac
2206 C Calculate angular part of the gradient.
2207             call sc_grad_scale(sss)
2208             ENDIF    ! dyn_ss
2209           enddo      ! j
2210         enddo        ! iint
2211       enddo          ! i
2212 C      enddo          ! zshift
2213 C      enddo          ! yshift
2214 C      enddo          ! xshift
2215 c      write (iout,*) "Number of loop steps in EGB:",ind
2216 cccc      energy_dec=.false.
2217       return
2218       end
2219 C-----------------------------------------------------------------------------
2220       subroutine egbv(evdw)
2221 C
2222 C This subroutine calculates the interaction energy of nonbonded side chains
2223 C assuming the Gay-Berne-Vorobjev potential of interaction.
2224 C
2225       implicit none
2226       include 'DIMENSIONS'
2227       include 'COMMON.GEO'
2228       include 'COMMON.VAR'
2229       include 'COMMON.LOCAL'
2230       include 'COMMON.CHAIN'
2231       include 'COMMON.DERIV'
2232       include 'COMMON.NAMES'
2233       include 'COMMON.INTERACT'
2234       include 'COMMON.IOUNITS'
2235       include 'COMMON.CALC'
2236       include 'COMMON.SPLITELE'
2237       integer xshift,yshift,zshift,subchap
2238       integer icall
2239       common /srutu/ icall
2240       logical lprn
2241       double precision evdw
2242       integer itypi,itypj,itypi1,iint,ind
2243       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2244      & xi,yi,zi,fac_augm,e_augm
2245       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2246      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2247      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip,sssgrad1
2248       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2249       evdw=0.0D0
2250 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2251       evdw=0.0D0
2252       lprn=.false.
2253 c     if (icall.eq.0) lprn=.true.
2254       ind=0
2255       do i=iatsc_s,iatsc_e
2256         itypi=iabs(itype(i))
2257         if (itypi.eq.ntyp1) cycle
2258         itypi1=iabs(itype(i+1))
2259         xi=c(1,nres+i)
2260         yi=c(2,nres+i)
2261         zi=c(3,nres+i)
2262           xi=mod(xi,boxxsize)
2263           if (xi.lt.0) xi=xi+boxxsize
2264           yi=mod(yi,boxysize)
2265           if (yi.lt.0) yi=yi+boxysize
2266           zi=mod(zi,boxzsize)
2267           if (zi.lt.0) zi=zi+boxzsize
2268 C define scaling factor for lipids
2269
2270 C        if (positi.le.0) positi=positi+boxzsize
2271 C        print *,i
2272 C first for peptide groups
2273 c for each residue check if it is in lipid or lipid water border area
2274        if ((zi.gt.bordlipbot)
2275      &.and.(zi.lt.bordliptop)) then
2276 C the energy transfer exist
2277         if (zi.lt.buflipbot) then
2278 C what fraction I am in
2279          fracinbuf=1.0d0-
2280      &        ((zi-bordlipbot)/lipbufthick)
2281 C lipbufthick is thickenes of lipid buffore
2282          sslipi=sscalelip(fracinbuf)
2283          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2284         elseif (zi.gt.bufliptop) then
2285          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2286          sslipi=sscalelip(fracinbuf)
2287          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2288         else
2289          sslipi=1.0d0
2290          ssgradlipi=0.0
2291         endif
2292        else
2293          sslipi=0.0d0
2294          ssgradlipi=0.0
2295        endif
2296
2297         dxi=dc_norm(1,nres+i)
2298         dyi=dc_norm(2,nres+i)
2299         dzi=dc_norm(3,nres+i)
2300 c        dsci_inv=dsc_inv(itypi)
2301         dsci_inv=vbld_inv(i+nres)
2302 C
2303 C Calculate SC interaction energy.
2304 C
2305         do iint=1,nint_gr(i)
2306           do j=istart(i,iint),iend(i,iint)
2307             ind=ind+1
2308             itypj=iabs(itype(j))
2309             if (itypj.eq.ntyp1) cycle
2310 c            dscj_inv=dsc_inv(itypj)
2311             dscj_inv=vbld_inv(j+nres)
2312             sig0ij=sigma(itypi,itypj)
2313             r0ij=r0(itypi,itypj)
2314             chi1=chi(itypi,itypj)
2315             chi2=chi(itypj,itypi)
2316             chi12=chi1*chi2
2317             chip1=chip(itypi)
2318             chip2=chip(itypj)
2319             chip12=chip1*chip2
2320             alf1=alp(itypi)
2321             alf2=alp(itypj)
2322             alf12=0.5D0*(alf1+alf2)
2323 C For diagnostics only!!!
2324 c           chi1=0.0D0
2325 c           chi2=0.0D0
2326 c           chi12=0.0D0
2327 c           chip1=0.0D0
2328 c           chip2=0.0D0
2329 c           chip12=0.0D0
2330 c           alf1=0.0D0
2331 c           alf2=0.0D0
2332 c           alf12=0.0D0
2333 C            xj=c(1,nres+j)-xi
2334 C            yj=c(2,nres+j)-yi
2335 C            zj=c(3,nres+j)-zi
2336           xj=mod(xj,boxxsize)
2337           if (xj.lt.0) xj=xj+boxxsize
2338           yj=mod(yj,boxysize)
2339           if (yj.lt.0) yj=yj+boxysize
2340           zj=mod(zj,boxzsize)
2341           if (zj.lt.0) zj=zj+boxzsize
2342        if ((zj.gt.bordlipbot)
2343      &.and.(zj.lt.bordliptop)) then
2344 C the energy transfer exist
2345         if (zj.lt.buflipbot) then
2346 C what fraction I am in
2347          fracinbuf=1.0d0-
2348      &        ((zj-bordlipbot)/lipbufthick)
2349 C lipbufthick is thickenes of lipid buffore
2350          sslipj=sscalelip(fracinbuf)
2351          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2352         elseif (zj.gt.bufliptop) then
2353          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2354          sslipj=sscalelip(fracinbuf)
2355          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2356         else
2357          sslipj=1.0d0
2358          ssgradlipj=0.0
2359         endif
2360        else
2361          sslipj=0.0d0
2362          ssgradlipj=0.0
2363        endif
2364       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2365      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2366       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2367      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2368 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2369 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2370 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2371       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2372       xj_safe=xj
2373       yj_safe=yj
2374       zj_safe=zj
2375       subchap=0
2376       do xshift=-1,1
2377       do yshift=-1,1
2378       do zshift=-1,1
2379           xj=xj_safe+xshift*boxxsize
2380           yj=yj_safe+yshift*boxysize
2381           zj=zj_safe+zshift*boxzsize
2382           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2383           if(dist_temp.lt.dist_init) then
2384             dist_init=dist_temp
2385             xj_temp=xj
2386             yj_temp=yj
2387             zj_temp=zj
2388             subchap=1
2389           endif
2390        enddo
2391        enddo
2392        enddo
2393        if (subchap.eq.1) then
2394           xj=xj_temp-xi
2395           yj=yj_temp-yi
2396           zj=zj_temp-zi
2397        else
2398           xj=xj_safe-xi
2399           yj=yj_safe-yi
2400           zj=zj_safe-zi
2401        endif
2402             dxj=dc_norm(1,nres+j)
2403             dyj=dc_norm(2,nres+j)
2404             dzj=dc_norm(3,nres+j)
2405             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2406             rij=dsqrt(rrij)
2407             sss=sscale(1.0d0/rij,r_cut_int)
2408             if (sss.eq.0.0d0) cycle
2409             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2410 C Calculate angle-dependent terms of energy and contributions to their
2411 C derivatives.
2412             call sc_angular
2413             sigsq=1.0D0/sigsq
2414             sig=sig0ij*dsqrt(sigsq)
2415             rij_shift=1.0D0/rij-sig+r0ij
2416 C I hate to put IF's in the loops, but here don't have another choice!!!!
2417             if (rij_shift.le.0.0D0) then
2418               evdw=1.0D20
2419               return
2420             endif
2421             sigder=-sig*sigsq
2422 c---------------------------------------------------------------
2423             rij_shift=1.0D0/rij_shift
2424             fac=rij_shift**expon
2425             e1=fac*fac*aa
2426             e2=fac*bb
2427             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2428             eps2der=evdwij*eps3rt
2429             eps3der=evdwij*eps2rt
2430             fac_augm=rrij**expon
2431             e_augm=augm(itypi,itypj)*fac_augm
2432             evdwij=evdwij*eps2rt*eps3rt
2433             evdw=evdw+evdwij+e_augm
2434             if (lprn) then
2435             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2436             epsi=bb**2/aa
2437             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2438      &        restyp(itypi),i,restyp(itypj),j,
2439      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2440      &        chi1,chi2,chip1,chip2,
2441      &        eps1,eps2rt**2,eps3rt**2,
2442      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2443      &        evdwij+e_augm
2444             endif
2445 C Calculate gradient components.
2446             e1=e1*eps1*eps2rt**2*eps3rt**2
2447             fac=-expon*(e1+evdwij)*rij_shift
2448             sigder=fac*sigder
2449             fac=rij*fac-2*expon*rrij*e_augm
2450             fac=fac+(evdwij+e_augm)*sssgrad*rij
2451 C Calculate the radial part of the gradient
2452             gg(1)=xj*fac
2453             gg(2)=yj*fac
2454             gg(3)=zj*fac
2455 C Calculate angular part of the gradient.
2456             call sc_grad_scale(sss)
2457           enddo      ! j
2458         enddo        ! iint
2459       enddo          ! i
2460       end
2461 C-----------------------------------------------------------------------------
2462       subroutine sc_angular
2463 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2464 C om12. Called by ebp, egb, and egbv.
2465       implicit none
2466       include 'COMMON.CALC'
2467       include 'COMMON.IOUNITS'
2468       erij(1)=xj*rij
2469       erij(2)=yj*rij
2470       erij(3)=zj*rij
2471       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2472       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2473       om12=dxi*dxj+dyi*dyj+dzi*dzj
2474       chiom12=chi12*om12
2475 C Calculate eps1(om12) and its derivative in om12
2476       faceps1=1.0D0-om12*chiom12
2477       faceps1_inv=1.0D0/faceps1
2478       eps1=dsqrt(faceps1_inv)
2479 C Following variable is eps1*deps1/dom12
2480       eps1_om12=faceps1_inv*chiom12
2481 c diagnostics only
2482 c      faceps1_inv=om12
2483 c      eps1=om12
2484 c      eps1_om12=1.0d0
2485 c      write (iout,*) "om12",om12," eps1",eps1
2486 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2487 C and om12.
2488       om1om2=om1*om2
2489       chiom1=chi1*om1
2490       chiom2=chi2*om2
2491       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2492       sigsq=1.0D0-facsig*faceps1_inv
2493       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2494       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2495       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2496 c diagnostics only
2497 c      sigsq=1.0d0
2498 c      sigsq_om1=0.0d0
2499 c      sigsq_om2=0.0d0
2500 c      sigsq_om12=0.0d0
2501 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2502 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2503 c     &    " eps1",eps1
2504 C Calculate eps2 and its derivatives in om1, om2, and om12.
2505       chipom1=chip1*om1
2506       chipom2=chip2*om2
2507       chipom12=chip12*om12
2508       facp=1.0D0-om12*chipom12
2509       facp_inv=1.0D0/facp
2510       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2511 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2512 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2513 C Following variable is the square root of eps2
2514       eps2rt=1.0D0-facp1*facp_inv
2515 C Following three variables are the derivatives of the square root of eps
2516 C in om1, om2, and om12.
2517       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2518       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2519       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2520 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2521       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2522 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2523 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2524 c     &  " eps2rt_om12",eps2rt_om12
2525 C Calculate whole angle-dependent part of epsilon and contributions
2526 C to its derivatives
2527       return
2528       end
2529 C----------------------------------------------------------------------------
2530       subroutine sc_grad
2531       implicit real*8 (a-h,o-z)
2532       include 'DIMENSIONS'
2533       include 'COMMON.CHAIN'
2534       include 'COMMON.DERIV'
2535       include 'COMMON.CALC'
2536       include 'COMMON.IOUNITS'
2537       double precision dcosom1(3),dcosom2(3)
2538 cc      print *,'sss=',sss
2539       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2540       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2541       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2542      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2543 c diagnostics only
2544 c      eom1=0.0d0
2545 c      eom2=0.0d0
2546 c      eom12=evdwij*eps1_om12
2547 c end diagnostics
2548 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2549 c     &  " sigder",sigder
2550 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2551 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2552       do k=1,3
2553         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2554         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2555       enddo
2556       do k=1,3
2557         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2558       enddo
2559 c      write (iout,*) "gg",(gg(k),k=1,3)
2560       do k=1,3
2561         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2562      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2563      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2564         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2565      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2566      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2567 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2568 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2569 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2570 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2571       enddo
2572 C
2573 C Calculate the components of the gradient in DC and X
2574 C
2575 cgrad      do k=i,j-1
2576 cgrad        do l=1,3
2577 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2578 cgrad        enddo
2579 cgrad      enddo
2580       do l=1,3
2581         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2582         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2583       enddo
2584       return
2585       end
2586 C-----------------------------------------------------------------------
2587       subroutine e_softsphere(evdw)
2588 C
2589 C This subroutine calculates the interaction energy of nonbonded side chains
2590 C assuming the LJ potential of interaction.
2591 C
2592       implicit real*8 (a-h,o-z)
2593       include 'DIMENSIONS'
2594       parameter (accur=1.0d-10)
2595       include 'COMMON.GEO'
2596       include 'COMMON.VAR'
2597       include 'COMMON.LOCAL'
2598       include 'COMMON.CHAIN'
2599       include 'COMMON.DERIV'
2600       include 'COMMON.INTERACT'
2601       include 'COMMON.TORSION'
2602       include 'COMMON.SBRIDGE'
2603       include 'COMMON.NAMES'
2604       include 'COMMON.IOUNITS'
2605 c      include 'COMMON.CONTACTS'
2606       dimension gg(3)
2607 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2608       evdw=0.0D0
2609       do i=iatsc_s,iatsc_e
2610         itypi=iabs(itype(i))
2611         if (itypi.eq.ntyp1) cycle
2612         itypi1=iabs(itype(i+1))
2613         xi=c(1,nres+i)
2614         yi=c(2,nres+i)
2615         zi=c(3,nres+i)
2616 C
2617 C Calculate SC interaction energy.
2618 C
2619         do iint=1,nint_gr(i)
2620 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2621 cd   &                  'iend=',iend(i,iint)
2622           do j=istart(i,iint),iend(i,iint)
2623             itypj=iabs(itype(j))
2624             if (itypj.eq.ntyp1) cycle
2625             xj=c(1,nres+j)-xi
2626             yj=c(2,nres+j)-yi
2627             zj=c(3,nres+j)-zi
2628             rij=xj*xj+yj*yj+zj*zj
2629 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2630             r0ij=r0(itypi,itypj)
2631             r0ijsq=r0ij*r0ij
2632 c            print *,i,j,r0ij,dsqrt(rij)
2633             if (rij.lt.r0ijsq) then
2634               evdwij=0.25d0*(rij-r0ijsq)**2
2635               fac=rij-r0ijsq
2636             else
2637               evdwij=0.0d0
2638               fac=0.0d0
2639             endif
2640             evdw=evdw+evdwij
2641 C
2642 C Calculate the components of the gradient in DC and X
2643 C
2644             gg(1)=xj*fac
2645             gg(2)=yj*fac
2646             gg(3)=zj*fac
2647             do k=1,3
2648               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2649               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2650               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2651               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2652             enddo
2653 cgrad            do k=i,j-1
2654 cgrad              do l=1,3
2655 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2656 cgrad              enddo
2657 cgrad            enddo
2658           enddo ! j
2659         enddo ! iint
2660       enddo ! i
2661       return
2662       end
2663 C--------------------------------------------------------------------------
2664       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2665      &              eello_turn4)
2666 C
2667 C Soft-sphere potential of p-p interaction
2668 C
2669       implicit real*8 (a-h,o-z)
2670       include 'DIMENSIONS'
2671       include 'COMMON.CONTROL'
2672       include 'COMMON.IOUNITS'
2673       include 'COMMON.GEO'
2674       include 'COMMON.VAR'
2675       include 'COMMON.LOCAL'
2676       include 'COMMON.CHAIN'
2677       include 'COMMON.DERIV'
2678       include 'COMMON.INTERACT'
2679 c      include 'COMMON.CONTACTS'
2680       include 'COMMON.TORSION'
2681       include 'COMMON.VECTORS'
2682       include 'COMMON.FFIELD'
2683       dimension ggg(3)
2684       integer xshift,yshift,zshift
2685 C      write(iout,*) 'In EELEC_soft_sphere'
2686       ees=0.0D0
2687       evdw1=0.0D0
2688       eel_loc=0.0d0
2689       eello_turn3=0.0d0
2690       eello_turn4=0.0d0
2691       ind=0
2692       do i=iatel_s,iatel_e
2693         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2694         dxi=dc(1,i)
2695         dyi=dc(2,i)
2696         dzi=dc(3,i)
2697         xmedi=c(1,i)+0.5d0*dxi
2698         ymedi=c(2,i)+0.5d0*dyi
2699         zmedi=c(3,i)+0.5d0*dzi
2700           xmedi=mod(xmedi,boxxsize)
2701           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2702           ymedi=mod(ymedi,boxysize)
2703           if (ymedi.lt.0) ymedi=ymedi+boxysize
2704           zmedi=mod(zmedi,boxzsize)
2705           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2706         num_conti=0
2707 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2708         do j=ielstart(i),ielend(i)
2709           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2710           ind=ind+1
2711           iteli=itel(i)
2712           itelj=itel(j)
2713           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2714           r0ij=rpp(iteli,itelj)
2715           r0ijsq=r0ij*r0ij
2716           dxj=dc(1,j)
2717           dyj=dc(2,j)
2718           dzj=dc(3,j)
2719           xj=c(1,j)+0.5D0*dxj
2720           yj=c(2,j)+0.5D0*dyj
2721           zj=c(3,j)+0.5D0*dzj
2722           xj=mod(xj,boxxsize)
2723           if (xj.lt.0) xj=xj+boxxsize
2724           yj=mod(yj,boxysize)
2725           if (yj.lt.0) yj=yj+boxysize
2726           zj=mod(zj,boxzsize)
2727           if (zj.lt.0) zj=zj+boxzsize
2728       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2729       xj_safe=xj
2730       yj_safe=yj
2731       zj_safe=zj
2732       isubchap=0
2733       do xshift=-1,1
2734       do yshift=-1,1
2735       do zshift=-1,1
2736           xj=xj_safe+xshift*boxxsize
2737           yj=yj_safe+yshift*boxysize
2738           zj=zj_safe+zshift*boxzsize
2739           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2740           if(dist_temp.lt.dist_init) then
2741             dist_init=dist_temp
2742             xj_temp=xj
2743             yj_temp=yj
2744             zj_temp=zj
2745             isubchap=1
2746           endif
2747        enddo
2748        enddo
2749        enddo
2750        if (isubchap.eq.1) then
2751           xj=xj_temp-xmedi
2752           yj=yj_temp-ymedi
2753           zj=zj_temp-zmedi
2754        else
2755           xj=xj_safe-xmedi
2756           yj=yj_safe-ymedi
2757           zj=zj_safe-zmedi
2758        endif
2759           rij=xj*xj+yj*yj+zj*zj
2760             sss=sscale(sqrt(rij),r_cut_int)
2761             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2762           if (rij.lt.r0ijsq) then
2763             evdw1ij=0.25d0*(rij-r0ijsq)**2
2764             fac=rij-r0ijsq
2765           else
2766             evdw1ij=0.0d0
2767             fac=0.0d0
2768           endif
2769           evdw1=evdw1+evdw1ij*sss
2770 C
2771 C Calculate contributions to the Cartesian gradient.
2772 C
2773           ggg(1)=fac*xj*sssgrad
2774           ggg(2)=fac*yj*sssgrad
2775           ggg(3)=fac*zj*sssgrad
2776           do k=1,3
2777             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2778             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2779           enddo
2780 *
2781 * Loop over residues i+1 thru j-1.
2782 *
2783 cgrad          do k=i+1,j-1
2784 cgrad            do l=1,3
2785 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2786 cgrad            enddo
2787 cgrad          enddo
2788         enddo ! j
2789       enddo   ! i
2790 cgrad      do i=nnt,nct-1
2791 cgrad        do k=1,3
2792 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2793 cgrad        enddo
2794 cgrad        do j=i+1,nct-1
2795 cgrad          do k=1,3
2796 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2797 cgrad          enddo
2798 cgrad        enddo
2799 cgrad      enddo
2800       return
2801       end
2802 c------------------------------------------------------------------------------
2803       subroutine vec_and_deriv
2804       implicit real*8 (a-h,o-z)
2805       include 'DIMENSIONS'
2806 #ifdef MPI
2807       include 'mpif.h'
2808 #endif
2809       include 'COMMON.IOUNITS'
2810       include 'COMMON.GEO'
2811       include 'COMMON.VAR'
2812       include 'COMMON.LOCAL'
2813       include 'COMMON.CHAIN'
2814       include 'COMMON.VECTORS'
2815       include 'COMMON.SETUP'
2816       include 'COMMON.TIME1'
2817       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2818 C Compute the local reference systems. For reference system (i), the
2819 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2820 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2821 #ifdef PARVEC
2822       do i=ivec_start,ivec_end
2823 #else
2824       do i=1,nres-1
2825 #endif
2826           if (i.eq.nres-1) then
2827 C Case of the last full residue
2828 C Compute the Z-axis
2829             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2830             costh=dcos(pi-theta(nres))
2831             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2832             do k=1,3
2833               uz(k,i)=fac*uz(k,i)
2834             enddo
2835 C Compute the derivatives of uz
2836             uzder(1,1,1)= 0.0d0
2837             uzder(2,1,1)=-dc_norm(3,i-1)
2838             uzder(3,1,1)= dc_norm(2,i-1)
2839             uzder(1,2,1)= dc_norm(3,i-1)
2840             uzder(2,2,1)= 0.0d0
2841             uzder(3,2,1)=-dc_norm(1,i-1)
2842             uzder(1,3,1)=-dc_norm(2,i-1)
2843             uzder(2,3,1)= dc_norm(1,i-1)
2844             uzder(3,3,1)= 0.0d0
2845             uzder(1,1,2)= 0.0d0
2846             uzder(2,1,2)= dc_norm(3,i)
2847             uzder(3,1,2)=-dc_norm(2,i)
2848             uzder(1,2,2)=-dc_norm(3,i)
2849             uzder(2,2,2)= 0.0d0
2850             uzder(3,2,2)= dc_norm(1,i)
2851             uzder(1,3,2)= dc_norm(2,i)
2852             uzder(2,3,2)=-dc_norm(1,i)
2853             uzder(3,3,2)= 0.0d0
2854 C Compute the Y-axis
2855             facy=fac
2856             do k=1,3
2857               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2858             enddo
2859 C Compute the derivatives of uy
2860             do j=1,3
2861               do k=1,3
2862                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2863      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2864                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2865               enddo
2866               uyder(j,j,1)=uyder(j,j,1)-costh
2867               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2868             enddo
2869             do j=1,2
2870               do k=1,3
2871                 do l=1,3
2872                   uygrad(l,k,j,i)=uyder(l,k,j)
2873                   uzgrad(l,k,j,i)=uzder(l,k,j)
2874                 enddo
2875               enddo
2876             enddo
2877             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2878             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2879             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2880             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2881           else
2882 C Other residues
2883 C Compute the Z-axis
2884             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2885             costh=dcos(pi-theta(i+2))
2886             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2887             do k=1,3
2888               uz(k,i)=fac*uz(k,i)
2889             enddo
2890 C Compute the derivatives of uz
2891             uzder(1,1,1)= 0.0d0
2892             uzder(2,1,1)=-dc_norm(3,i+1)
2893             uzder(3,1,1)= dc_norm(2,i+1)
2894             uzder(1,2,1)= dc_norm(3,i+1)
2895             uzder(2,2,1)= 0.0d0
2896             uzder(3,2,1)=-dc_norm(1,i+1)
2897             uzder(1,3,1)=-dc_norm(2,i+1)
2898             uzder(2,3,1)= dc_norm(1,i+1)
2899             uzder(3,3,1)= 0.0d0
2900             uzder(1,1,2)= 0.0d0
2901             uzder(2,1,2)= dc_norm(3,i)
2902             uzder(3,1,2)=-dc_norm(2,i)
2903             uzder(1,2,2)=-dc_norm(3,i)
2904             uzder(2,2,2)= 0.0d0
2905             uzder(3,2,2)= dc_norm(1,i)
2906             uzder(1,3,2)= dc_norm(2,i)
2907             uzder(2,3,2)=-dc_norm(1,i)
2908             uzder(3,3,2)= 0.0d0
2909 C Compute the Y-axis
2910             facy=fac
2911             do k=1,3
2912               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2913             enddo
2914 C Compute the derivatives of uy
2915             do j=1,3
2916               do k=1,3
2917                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2918      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2919                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2920               enddo
2921               uyder(j,j,1)=uyder(j,j,1)-costh
2922               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2923             enddo
2924             do j=1,2
2925               do k=1,3
2926                 do l=1,3
2927                   uygrad(l,k,j,i)=uyder(l,k,j)
2928                   uzgrad(l,k,j,i)=uzder(l,k,j)
2929                 enddo
2930               enddo
2931             enddo
2932             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2933             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2934             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2935             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2936           endif
2937       enddo
2938       do i=1,nres-1
2939         vbld_inv_temp(1)=vbld_inv(i+1)
2940         if (i.lt.nres-1) then
2941           vbld_inv_temp(2)=vbld_inv(i+2)
2942           else
2943           vbld_inv_temp(2)=vbld_inv(i)
2944           endif
2945         do j=1,2
2946           do k=1,3
2947             do l=1,3
2948               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2949               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2950             enddo
2951           enddo
2952         enddo
2953       enddo
2954 #if defined(PARVEC) && defined(MPI)
2955       if (nfgtasks1.gt.1) then
2956         time00=MPI_Wtime()
2957 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2958 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2959 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2960         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2961      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2962      &   FG_COMM1,IERR)
2963         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2964      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2965      &   FG_COMM1,IERR)
2966         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2967      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2968      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2969         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2970      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2971      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2972         time_gather=time_gather+MPI_Wtime()-time00
2973       endif
2974 #endif
2975 #ifdef DEBUG
2976       if (fg_rank.eq.0) then
2977         write (iout,*) "Arrays UY and UZ"
2978         do i=1,nres-1
2979           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2980      &     (uz(k,i),k=1,3)
2981         enddo
2982       endif
2983 #endif
2984       return
2985       end
2986 C--------------------------------------------------------------------------
2987       subroutine set_matrices
2988       implicit real*8 (a-h,o-z)
2989       include 'DIMENSIONS'
2990 #ifdef MPI
2991       include "mpif.h"
2992       include "COMMON.SETUP"
2993       integer IERR
2994       integer status(MPI_STATUS_SIZE)
2995 #endif
2996       include 'COMMON.IOUNITS'
2997       include 'COMMON.GEO'
2998       include 'COMMON.VAR'
2999       include 'COMMON.LOCAL'
3000       include 'COMMON.CHAIN'
3001       include 'COMMON.DERIV'
3002       include 'COMMON.INTERACT'
3003       include 'COMMON.CORRMAT'
3004       include 'COMMON.TORSION'
3005       include 'COMMON.VECTORS'
3006       include 'COMMON.FFIELD'
3007       double precision auxvec(2),auxmat(2,2)
3008 C
3009 C Compute the virtual-bond-torsional-angle dependent quantities needed
3010 C to calculate the el-loc multibody terms of various order.
3011 C
3012 c      write(iout,*) 'nphi=',nphi,nres
3013 c      write(iout,*) "itype2loc",itype2loc
3014 #ifdef PARMAT
3015       do i=ivec_start+2,ivec_end+2
3016 #else
3017       do i=3,nres+1
3018 #endif
3019         ii=ireschain(i-2)
3020 c        write (iout,*) "i",i,i-2," ii",ii
3021         if (ii.eq.0) cycle
3022         innt=chain_border(1,ii)
3023         inct=chain_border(2,ii)
3024 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3025 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3026         if (i.gt. innt+2 .and. i.lt.inct+2) then
3027           iti = itype2loc(itype(i-2))
3028         else
3029           iti=nloctyp
3030         endif
3031 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3032         if (i.gt. innt+1 .and. i.lt.inct+1) then
3033           iti1 = itype2loc(itype(i-1))
3034         else
3035           iti1=nloctyp
3036         endif
3037 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3038 c     &  " iti1",itype(i-1),iti1
3039 #ifdef NEWCORR
3040         cost1=dcos(theta(i-1))
3041         sint1=dsin(theta(i-1))
3042         sint1sq=sint1*sint1
3043         sint1cub=sint1sq*sint1
3044         sint1cost1=2*sint1*cost1
3045 c        write (iout,*) "bnew1",i,iti
3046 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
3047 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3048 c        write (iout,*) "bnew2",i,iti
3049 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3050 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3051         do k=1,2
3052           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3053           b1(k,i-2)=sint1*b1k
3054           gtb1(k,i-2)=cost1*b1k-sint1sq*
3055      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3056           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3057           b2(k,i-2)=sint1*b2k
3058           gtb2(k,i-2)=cost1*b2k-sint1sq*
3059      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3060         enddo
3061         do k=1,2
3062           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3063           cc(1,k,i-2)=sint1sq*aux
3064           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3065      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3066           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3067           dd(1,k,i-2)=sint1sq*aux
3068           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3069      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3070         enddo
3071         cc(2,1,i-2)=cc(1,2,i-2)
3072         cc(2,2,i-2)=-cc(1,1,i-2)
3073         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3074         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3075         dd(2,1,i-2)=dd(1,2,i-2)
3076         dd(2,2,i-2)=-dd(1,1,i-2)
3077         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3078         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3079         do k=1,2
3080           do l=1,2
3081             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3082             EE(l,k,i-2)=sint1sq*aux
3083             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3084           enddo
3085         enddo
3086         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3087         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3088         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3089         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3090         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3091         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3092         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3093 c        b1tilde(1,i-2)=b1(1,i-2)
3094 c        b1tilde(2,i-2)=-b1(2,i-2)
3095 c        b2tilde(1,i-2)=b2(1,i-2)
3096 c        b2tilde(2,i-2)=-b2(2,i-2)
3097 #ifdef DEBUG
3098         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3099         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3100         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3101         write (iout,*) 'theta=', theta(i-1)
3102 #endif
3103 #else
3104         if (i.gt. innt+2 .and. i.lt.inct+2) then
3105 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3106           iti = itype2loc(itype(i-2))
3107         else
3108           iti=nloctyp
3109         endif
3110 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3111 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3112         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3113           iti1 = itype2loc(itype(i-1))
3114         else
3115           iti1=nloctyp
3116         endif
3117         b1(1,i-2)=b(3,iti)
3118         b1(2,i-2)=b(5,iti)
3119         b2(1,i-2)=b(2,iti)
3120         b2(2,i-2)=b(4,iti)
3121         do k=1,2
3122           do l=1,2
3123            CC(k,l,i-2)=ccold(k,l,iti)
3124            DD(k,l,i-2)=ddold(k,l,iti)
3125            EE(k,l,i-2)=eeold(k,l,iti)
3126            gtEE(k,l,i-2)=0.0d0
3127           enddo
3128         enddo
3129 #endif
3130         b1tilde(1,i-2)= b1(1,i-2)
3131         b1tilde(2,i-2)=-b1(2,i-2)
3132         b2tilde(1,i-2)= b2(1,i-2)
3133         b2tilde(2,i-2)=-b2(2,i-2)
3134 c
3135         Ctilde(1,1,i-2)= CC(1,1,i-2)
3136         Ctilde(1,2,i-2)= CC(1,2,i-2)
3137         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3138         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3139 c
3140         Dtilde(1,1,i-2)= DD(1,1,i-2)
3141         Dtilde(1,2,i-2)= DD(1,2,i-2)
3142         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3143         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3144 #ifdef DEBUG
3145         write(iout,*) "i",i," iti",iti
3146         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3147         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3148 #endif
3149       enddo
3150       mu=0.0d0
3151 #ifdef PARMAT
3152       do i=ivec_start+2,ivec_end+2
3153 #else
3154       do i=3,nres+1
3155 #endif
3156 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3157         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3158           sin1=dsin(phi(i))
3159           cos1=dcos(phi(i))
3160           sintab(i-2)=sin1
3161           costab(i-2)=cos1
3162           obrot(1,i-2)=cos1
3163           obrot(2,i-2)=sin1
3164           sin2=dsin(2*phi(i))
3165           cos2=dcos(2*phi(i))
3166           sintab2(i-2)=sin2
3167           costab2(i-2)=cos2
3168           obrot2(1,i-2)=cos2
3169           obrot2(2,i-2)=sin2
3170           Ug(1,1,i-2)=-cos1
3171           Ug(1,2,i-2)=-sin1
3172           Ug(2,1,i-2)=-sin1
3173           Ug(2,2,i-2)= cos1
3174           Ug2(1,1,i-2)=-cos2
3175           Ug2(1,2,i-2)=-sin2
3176           Ug2(2,1,i-2)=-sin2
3177           Ug2(2,2,i-2)= cos2
3178         else
3179           costab(i-2)=1.0d0
3180           sintab(i-2)=0.0d0
3181           obrot(1,i-2)=1.0d0
3182           obrot(2,i-2)=0.0d0
3183           obrot2(1,i-2)=0.0d0
3184           obrot2(2,i-2)=0.0d0
3185           Ug(1,1,i-2)=1.0d0
3186           Ug(1,2,i-2)=0.0d0
3187           Ug(2,1,i-2)=0.0d0
3188           Ug(2,2,i-2)=1.0d0
3189           Ug2(1,1,i-2)=0.0d0
3190           Ug2(1,2,i-2)=0.0d0
3191           Ug2(2,1,i-2)=0.0d0
3192           Ug2(2,2,i-2)=0.0d0
3193         endif
3194         if (i .gt. 3) then
3195           obrot_der(1,i-2)=-sin1
3196           obrot_der(2,i-2)= cos1
3197           Ugder(1,1,i-2)= sin1
3198           Ugder(1,2,i-2)=-cos1
3199           Ugder(2,1,i-2)=-cos1
3200           Ugder(2,2,i-2)=-sin1
3201           dwacos2=cos2+cos2
3202           dwasin2=sin2+sin2
3203           obrot2_der(1,i-2)=-dwasin2
3204           obrot2_der(2,i-2)= dwacos2
3205           Ug2der(1,1,i-2)= dwasin2
3206           Ug2der(1,2,i-2)=-dwacos2
3207           Ug2der(2,1,i-2)=-dwacos2
3208           Ug2der(2,2,i-2)=-dwasin2
3209         else
3210           obrot_der(1,i-2)=0.0d0
3211           obrot_der(2,i-2)=0.0d0
3212           Ugder(1,1,i-2)=0.0d0
3213           Ugder(1,2,i-2)=0.0d0
3214           Ugder(2,1,i-2)=0.0d0
3215           Ugder(2,2,i-2)=0.0d0
3216           obrot2_der(1,i-2)=0.0d0
3217           obrot2_der(2,i-2)=0.0d0
3218           Ug2der(1,1,i-2)=0.0d0
3219           Ug2der(1,2,i-2)=0.0d0
3220           Ug2der(2,1,i-2)=0.0d0
3221           Ug2der(2,2,i-2)=0.0d0
3222         endif
3223 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3224 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3225         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3226           iti = itype2loc(itype(i-2))
3227         else
3228           iti=nloctyp
3229         endif
3230 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3231         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3232           iti1 = itype2loc(itype(i-1))
3233         else
3234           iti1=nloctyp
3235         endif
3236 cd        write (iout,*) '*******i',i,' iti1',iti
3237 cd        write (iout,*) 'b1',b1(:,iti)
3238 cd        write (iout,*) 'b2',b2(:,iti)
3239 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3240 c        if (i .gt. iatel_s+2) then
3241         if (i .gt. nnt+2) then
3242           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3243 #ifdef NEWCORR
3244           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3245 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3246 #endif
3247 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3248 c     &    EE(1,2,iti),EE(2,2,i)
3249           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3250           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3251 c          write(iout,*) "Macierz EUG",
3252 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3253 c     &    eug(2,2,i-2)
3254 #ifdef FOURBODY
3255           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3256      &    then
3257           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3258           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3259           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3260           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3261           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3262           endif
3263 #endif
3264         else
3265           do k=1,2
3266             Ub2(k,i-2)=0.0d0
3267             Ctobr(k,i-2)=0.0d0
3268             Dtobr2(k,i-2)=0.0d0
3269             do l=1,2
3270               EUg(l,k,i-2)=0.0d0
3271               CUg(l,k,i-2)=0.0d0
3272               DUg(l,k,i-2)=0.0d0
3273               DtUg2(l,k,i-2)=0.0d0
3274             enddo
3275           enddo
3276         endif
3277         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3278         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3279         do k=1,2
3280           muder(k,i-2)=Ub2der(k,i-2)
3281         enddo
3282 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3283         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3284           if (itype(i-1).le.ntyp) then
3285             iti1 = itype2loc(itype(i-1))
3286           else
3287             iti1=nloctyp
3288           endif
3289         else
3290           iti1=nloctyp
3291         endif
3292         do k=1,2
3293           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3294 c          mu(k,i-2)=b1(k,i-1)
3295 c          mu(k,i-2)=Ub2(k,i-2)
3296         enddo
3297 #ifdef MUOUT
3298         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3299      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3300      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3301      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3302      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3303      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3304 #endif
3305 cd        write (iout,*) 'mu1',mu1(:,i-2)
3306 cd        write (iout,*) 'mu2',mu2(:,i-2)
3307 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3308 #ifdef FOURBODY
3309         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3310      &  then
3311         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3312         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3313         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3314         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3315         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3316 C Vectors and matrices dependent on a single virtual-bond dihedral.
3317         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3318         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3319         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3320         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3321         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3322         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3323         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3324         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3325         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3326         endif
3327 #endif
3328       enddo
3329 #ifdef FOURBODY
3330 C Matrices dependent on two consecutive virtual-bond dihedrals.
3331 C The order of matrices is from left to right.
3332       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3333      &then
3334 c      do i=max0(ivec_start,2),ivec_end
3335       do i=2,nres-1
3336         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3337         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3338         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3339         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3340         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3341         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3342         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3343         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3344       enddo
3345       endif
3346 #endif
3347 #if defined(MPI) && defined(PARMAT)
3348 #ifdef DEBUG
3349 c      if (fg_rank.eq.0) then
3350         write (iout,*) "Arrays UG and UGDER before GATHER"
3351         do i=1,nres-1
3352           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3353      &     ((ug(l,k,i),l=1,2),k=1,2),
3354      &     ((ugder(l,k,i),l=1,2),k=1,2)
3355         enddo
3356         write (iout,*) "Arrays UG2 and UG2DER"
3357         do i=1,nres-1
3358           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3359      &     ((ug2(l,k,i),l=1,2),k=1,2),
3360      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3361         enddo
3362         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3363         do i=1,nres-1
3364           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3365      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3366      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3367         enddo
3368         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3369         do i=1,nres-1
3370           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3371      &     costab(i),sintab(i),costab2(i),sintab2(i)
3372         enddo
3373         write (iout,*) "Array MUDER"
3374         do i=1,nres-1
3375           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3376         enddo
3377 c      endif
3378 #endif
3379       if (nfgtasks.gt.1) then
3380         time00=MPI_Wtime()
3381 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3382 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3383 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3384 #ifdef MATGATHER
3385         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3386      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3387      &   FG_COMM1,IERR)
3388         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3389      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3390      &   FG_COMM1,IERR)
3391         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3392      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3393      &   FG_COMM1,IERR)
3394         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3395      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3396      &   FG_COMM1,IERR)
3397         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3398      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3399      &   FG_COMM1,IERR)
3400         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3401      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3402      &   FG_COMM1,IERR)
3403         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3404      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3405      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3406         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3407      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3408      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3409         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3410      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3411      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3412         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3413      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3414      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3415 #ifdef FOURBODY
3416         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3417      &  then
3418         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3419      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3420      &   FG_COMM1,IERR)
3421         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3422      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3423      &   FG_COMM1,IERR)
3424         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3425      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3426      &   FG_COMM1,IERR)
3427        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3428      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3429      &   FG_COMM1,IERR)
3430         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3431      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3432      &   FG_COMM1,IERR)
3433         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3434      &   ivec_count(fg_rank1),
3435      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3436      &   FG_COMM1,IERR)
3437         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3438      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3439      &   FG_COMM1,IERR)
3440         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3441      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3442      &   FG_COMM1,IERR)
3443         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3444      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3445      &   FG_COMM1,IERR)
3446         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3447      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3448      &   FG_COMM1,IERR)
3449         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3450      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3451      &   FG_COMM1,IERR)
3452         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3453      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3454      &   FG_COMM1,IERR)
3455         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3456      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3457      &   FG_COMM1,IERR)
3458         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3459      &   ivec_count(fg_rank1),
3460      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3461      &   FG_COMM1,IERR)
3462         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3463      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3464      &   FG_COMM1,IERR)
3465        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3466      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3467      &   FG_COMM1,IERR)
3468         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3469      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3470      &   FG_COMM1,IERR)
3471        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3472      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3473      &   FG_COMM1,IERR)
3474         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3475      &   ivec_count(fg_rank1),
3476      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3477      &   FG_COMM1,IERR)
3478         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3479      &   ivec_count(fg_rank1),
3480      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3481      &   FG_COMM1,IERR)
3482         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3483      &   ivec_count(fg_rank1),
3484      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3485      &   MPI_MAT2,FG_COMM1,IERR)
3486         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3487      &   ivec_count(fg_rank1),
3488      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3489      &   MPI_MAT2,FG_COMM1,IERR)
3490         endif
3491 #endif
3492 #else
3493 c Passes matrix info through the ring
3494       isend=fg_rank1
3495       irecv=fg_rank1-1
3496       if (irecv.lt.0) irecv=nfgtasks1-1
3497       iprev=irecv
3498       inext=fg_rank1+1
3499       if (inext.ge.nfgtasks1) inext=0
3500       do i=1,nfgtasks1-1
3501 c        write (iout,*) "isend",isend," irecv",irecv
3502 c        call flush(iout)
3503         lensend=lentyp(isend)
3504         lenrecv=lentyp(irecv)
3505 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3506 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3507 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3508 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3509 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3510 c        write (iout,*) "Gather ROTAT1"
3511 c        call flush(iout)
3512 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3513 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3514 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3515 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3516 c        write (iout,*) "Gather ROTAT2"
3517 c        call flush(iout)
3518         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3519      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3520      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3521      &   iprev,4400+irecv,FG_COMM,status,IERR)
3522 c        write (iout,*) "Gather ROTAT_OLD"
3523 c        call flush(iout)
3524         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3525      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3526      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3527      &   iprev,5500+irecv,FG_COMM,status,IERR)
3528 c        write (iout,*) "Gather PRECOMP11"
3529 c        call flush(iout)
3530         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3531      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3532      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3533      &   iprev,6600+irecv,FG_COMM,status,IERR)
3534 c        write (iout,*) "Gather PRECOMP12"
3535 c        call flush(iout)
3536 #ifdef FOURBODY
3537         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3538      &  then
3539         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3540      &   MPI_ROTAT2(lensend),inext,7700+isend,
3541      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3542      &   iprev,7700+irecv,FG_COMM,status,IERR)
3543 c        write (iout,*) "Gather PRECOMP21"
3544 c        call flush(iout)
3545         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3546      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3547      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3548      &   iprev,8800+irecv,FG_COMM,status,IERR)
3549 c        write (iout,*) "Gather PRECOMP22"
3550 c        call flush(iout)
3551         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3552      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3553      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3554      &   MPI_PRECOMP23(lenrecv),
3555      &   iprev,9900+irecv,FG_COMM,status,IERR)
3556 #endif
3557 c        write (iout,*) "Gather PRECOMP23"
3558 c        call flush(iout)
3559         endif
3560         isend=irecv
3561         irecv=irecv-1
3562         if (irecv.lt.0) irecv=nfgtasks1-1
3563       enddo
3564 #endif
3565         time_gather=time_gather+MPI_Wtime()-time00
3566       endif
3567 #ifdef DEBUG
3568 c      if (fg_rank.eq.0) then
3569         write (iout,*) "Arrays UG and UGDER"
3570         do i=1,nres-1
3571           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3572      &     ((ug(l,k,i),l=1,2),k=1,2),
3573      &     ((ugder(l,k,i),l=1,2),k=1,2)
3574         enddo
3575         write (iout,*) "Arrays UG2 and UG2DER"
3576         do i=1,nres-1
3577           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3578      &     ((ug2(l,k,i),l=1,2),k=1,2),
3579      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3580         enddo
3581         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3582         do i=1,nres-1
3583           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3584      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3585      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3586         enddo
3587         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3588         do i=1,nres-1
3589           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3590      &     costab(i),sintab(i),costab2(i),sintab2(i)
3591         enddo
3592         write (iout,*) "Array MUDER"
3593         do i=1,nres-1
3594           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3595         enddo
3596 c      endif
3597 #endif
3598 #endif
3599 cd      do i=1,nres
3600 cd        iti = itype2loc(itype(i))
3601 cd        write (iout,*) i
3602 cd        do j=1,2
3603 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3604 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3605 cd        enddo
3606 cd      enddo
3607       return
3608       end
3609 C-----------------------------------------------------------------------------
3610       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3611 C
3612 C This subroutine calculates the average interaction energy and its gradient
3613 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3614 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3615 C The potential depends both on the distance of peptide-group centers and on
3616 C the orientation of the CA-CA virtual bonds.
3617 C
3618       implicit real*8 (a-h,o-z)
3619 #ifdef MPI
3620       include 'mpif.h'
3621 #endif
3622       include 'DIMENSIONS'
3623       include 'COMMON.CONTROL'
3624       include 'COMMON.SETUP'
3625       include 'COMMON.IOUNITS'
3626       include 'COMMON.GEO'
3627       include 'COMMON.VAR'
3628       include 'COMMON.LOCAL'
3629       include 'COMMON.CHAIN'
3630       include 'COMMON.DERIV'
3631       include 'COMMON.INTERACT'
3632 #ifdef FOURBODY
3633       include 'COMMON.CONTACTS'
3634       include 'COMMON.CONTMAT'
3635 #endif
3636       include 'COMMON.CORRMAT'
3637       include 'COMMON.TORSION'
3638       include 'COMMON.VECTORS'
3639       include 'COMMON.FFIELD'
3640       include 'COMMON.TIME1'
3641       include 'COMMON.SPLITELE'
3642       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3643      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3644       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3645      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3646       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3647      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3648      &    num_conti,j1,j2
3649 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3650 #ifdef MOMENT
3651       double precision scal_el /1.0d0/
3652 #else
3653       double precision scal_el /0.5d0/
3654 #endif
3655 C 12/13/98
3656 C 13-go grudnia roku pamietnego...
3657       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3658      &                   0.0d0,1.0d0,0.0d0,
3659      &                   0.0d0,0.0d0,1.0d0/
3660 cd      write(iout,*) 'In EELEC'
3661 cd      do i=1,nloctyp
3662 cd        write(iout,*) 'Type',i
3663 cd        write(iout,*) 'B1',B1(:,i)
3664 cd        write(iout,*) 'B2',B2(:,i)
3665 cd        write(iout,*) 'CC',CC(:,:,i)
3666 cd        write(iout,*) 'DD',DD(:,:,i)
3667 cd        write(iout,*) 'EE',EE(:,:,i)
3668 cd      enddo
3669 cd      call check_vecgrad
3670 cd      stop
3671       if (icheckgrad.eq.1) then
3672         do i=1,nres-1
3673           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3674           do k=1,3
3675             dc_norm(k,i)=dc(k,i)*fac
3676           enddo
3677 c          write (iout,*) 'i',i,' fac',fac
3678         enddo
3679       endif
3680       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3681      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3682      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3683 c        call vec_and_deriv
3684 #ifdef TIMING
3685         time01=MPI_Wtime()
3686 #endif
3687         call set_matrices
3688 #ifdef TIMING
3689         time_mat=time_mat+MPI_Wtime()-time01
3690 #endif
3691       endif
3692 cd      do i=1,nres-1
3693 cd        write (iout,*) 'i=',i
3694 cd        do k=1,3
3695 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3696 cd        enddo
3697 cd        do k=1,3
3698 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3699 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3700 cd        enddo
3701 cd      enddo
3702       t_eelecij=0.0d0
3703       ees=0.0D0
3704       evdw1=0.0D0
3705       eel_loc=0.0d0
3706       eello_turn3=0.0d0
3707       eello_turn4=0.0d0
3708       ind=0
3709 #ifdef FOURBODY
3710       do i=1,nres
3711         num_cont_hb(i)=0
3712       enddo
3713 #endif
3714 cd      print '(a)','Enter EELEC'
3715 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3716       do i=1,nres
3717         gel_loc_loc(i)=0.0d0
3718         gcorr_loc(i)=0.0d0
3719       enddo
3720 c
3721 c
3722 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3723 C
3724 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3725 C
3726 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3727       do i=iturn3_start,iturn3_end
3728 c        if (i.le.1) cycle
3729 C        write(iout,*) "tu jest i",i
3730         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3731 C changes suggested by Ana to avoid out of bounds
3732 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3733 c     & .or.((i+4).gt.nres)
3734 c     & .or.((i-1).le.0)
3735 C end of changes by Ana
3736      &  .or. itype(i+2).eq.ntyp1
3737      &  .or. itype(i+3).eq.ntyp1) cycle
3738 C Adam: Instructions below will switch off existing interactions
3739 c        if(i.gt.1)then
3740 c          if(itype(i-1).eq.ntyp1)cycle
3741 c        end if
3742 c        if(i.LT.nres-3)then
3743 c          if (itype(i+4).eq.ntyp1) cycle
3744 c        end if
3745         dxi=dc(1,i)
3746         dyi=dc(2,i)
3747         dzi=dc(3,i)
3748         dx_normi=dc_norm(1,i)
3749         dy_normi=dc_norm(2,i)
3750         dz_normi=dc_norm(3,i)
3751         xmedi=c(1,i)+0.5d0*dxi
3752         ymedi=c(2,i)+0.5d0*dyi
3753         zmedi=c(3,i)+0.5d0*dzi
3754           xmedi=mod(xmedi,boxxsize)
3755           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3756           ymedi=mod(ymedi,boxysize)
3757           if (ymedi.lt.0) ymedi=ymedi+boxysize
3758           zmedi=mod(zmedi,boxzsize)
3759           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3760         num_conti=0
3761         call eelecij(i,i+2,ees,evdw1,eel_loc)
3762         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3763 #ifdef FOURBODY
3764         num_cont_hb(i)=num_conti
3765 #endif
3766       enddo
3767       do i=iturn4_start,iturn4_end
3768         if (i.lt.1) cycle
3769         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3770 C changes suggested by Ana to avoid out of bounds
3771 c     & .or.((i+5).gt.nres)
3772 c     & .or.((i-1).le.0)
3773 C end of changes suggested by Ana
3774      &    .or. itype(i+3).eq.ntyp1
3775      &    .or. itype(i+4).eq.ntyp1
3776 c     &    .or. itype(i+5).eq.ntyp1
3777 c     &    .or. itype(i).eq.ntyp1
3778 c     &    .or. itype(i-1).eq.ntyp1
3779      &                             ) cycle
3780         dxi=dc(1,i)
3781         dyi=dc(2,i)
3782         dzi=dc(3,i)
3783         dx_normi=dc_norm(1,i)
3784         dy_normi=dc_norm(2,i)
3785         dz_normi=dc_norm(3,i)
3786         xmedi=c(1,i)+0.5d0*dxi
3787         ymedi=c(2,i)+0.5d0*dyi
3788         zmedi=c(3,i)+0.5d0*dzi
3789 C Return atom into box, boxxsize is size of box in x dimension
3790 c  194   continue
3791 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3792 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3793 C Condition for being inside the proper box
3794 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3795 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3796 c        go to 194
3797 c        endif
3798 c  195   continue
3799 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3800 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3801 C Condition for being inside the proper box
3802 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3803 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3804 c        go to 195
3805 c        endif
3806 c  196   continue
3807 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3808 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3809 C Condition for being inside the proper box
3810 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3811 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3812 c        go to 196
3813 c        endif
3814           xmedi=mod(xmedi,boxxsize)
3815           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3816           ymedi=mod(ymedi,boxysize)
3817           if (ymedi.lt.0) ymedi=ymedi+boxysize
3818           zmedi=mod(zmedi,boxzsize)
3819           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3820
3821 #ifdef FOURBODY
3822         num_conti=num_cont_hb(i)
3823 #endif
3824 c        write(iout,*) "JESTEM W PETLI"
3825         call eelecij(i,i+3,ees,evdw1,eel_loc)
3826         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3827      &   call eturn4(i,eello_turn4)
3828 #ifdef FOURBODY
3829         num_cont_hb(i)=num_conti
3830 #endif
3831       enddo   ! i
3832 C Loop over all neighbouring boxes
3833 C      do xshift=-1,1
3834 C      do yshift=-1,1
3835 C      do zshift=-1,1
3836 c
3837 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3838 c
3839 CTU KURWA
3840       do i=iatel_s,iatel_e
3841 C        do i=75,75
3842 c        if (i.le.1) cycle
3843         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3844 C changes suggested by Ana to avoid out of bounds
3845 c     & .or.((i+2).gt.nres)
3846 c     & .or.((i-1).le.0)
3847 C end of changes by Ana
3848 c     &  .or. itype(i+2).eq.ntyp1
3849 c     &  .or. itype(i-1).eq.ntyp1
3850      &                ) cycle
3851         dxi=dc(1,i)
3852         dyi=dc(2,i)
3853         dzi=dc(3,i)
3854         dx_normi=dc_norm(1,i)
3855         dy_normi=dc_norm(2,i)
3856         dz_normi=dc_norm(3,i)
3857         xmedi=c(1,i)+0.5d0*dxi
3858         ymedi=c(2,i)+0.5d0*dyi
3859         zmedi=c(3,i)+0.5d0*dzi
3860           xmedi=mod(xmedi,boxxsize)
3861           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3862           ymedi=mod(ymedi,boxysize)
3863           if (ymedi.lt.0) ymedi=ymedi+boxysize
3864           zmedi=mod(zmedi,boxzsize)
3865           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3866 C          xmedi=xmedi+xshift*boxxsize
3867 C          ymedi=ymedi+yshift*boxysize
3868 C          zmedi=zmedi+zshift*boxzsize
3869
3870 C Return tom into box, boxxsize is size of box in x dimension
3871 c  164   continue
3872 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3873 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3874 C Condition for being inside the proper box
3875 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3876 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3877 c        go to 164
3878 c        endif
3879 c  165   continue
3880 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3881 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3882 C Condition for being inside the proper box
3883 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3884 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3885 c        go to 165
3886 c        endif
3887 c  166   continue
3888 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3889 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3890 cC Condition for being inside the proper box
3891 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3892 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3893 c        go to 166
3894 c        endif
3895
3896 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3897 #ifdef FOURBODY
3898         num_conti=num_cont_hb(i)
3899 #endif
3900 C I TU KURWA
3901         do j=ielstart(i),ielend(i)
3902 C          do j=16,17
3903 C          write (iout,*) i,j
3904 C         if (j.le.1) cycle
3905           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3906 C changes suggested by Ana to avoid out of bounds
3907 c     & .or.((j+2).gt.nres)
3908 c     & .or.((j-1).le.0)
3909 C end of changes by Ana
3910 c     & .or.itype(j+2).eq.ntyp1
3911 c     & .or.itype(j-1).eq.ntyp1
3912      &) cycle
3913           call eelecij(i,j,ees,evdw1,eel_loc)
3914         enddo ! j
3915 #ifdef FOURBODY
3916         num_cont_hb(i)=num_conti
3917 #endif
3918       enddo   ! i
3919 C     enddo   ! zshift
3920 C      enddo   ! yshift
3921 C      enddo   ! xshift
3922
3923 c      write (iout,*) "Number of loop steps in EELEC:",ind
3924 cd      do i=1,nres
3925 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3926 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3927 cd      enddo
3928 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3929 ccc      eel_loc=eel_loc+eello_turn3
3930 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3931       return
3932       end
3933 C-------------------------------------------------------------------------------
3934       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3935       implicit none
3936       include 'DIMENSIONS'
3937 #ifdef MPI
3938       include "mpif.h"
3939 #endif
3940       include 'COMMON.CONTROL'
3941       include 'COMMON.IOUNITS'
3942       include 'COMMON.GEO'
3943       include 'COMMON.VAR'
3944       include 'COMMON.LOCAL'
3945       include 'COMMON.CHAIN'
3946       include 'COMMON.DERIV'
3947       include 'COMMON.INTERACT'
3948 #ifdef FOURBODY
3949       include 'COMMON.CONTACTS'
3950       include 'COMMON.CONTMAT'
3951 #endif
3952       include 'COMMON.CORRMAT'
3953       include 'COMMON.TORSION'
3954       include 'COMMON.VECTORS'
3955       include 'COMMON.FFIELD'
3956       include 'COMMON.TIME1'
3957       include 'COMMON.SPLITELE'
3958       include 'COMMON.SHIELD'
3959       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3960      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3961       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3962      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3963      &    gmuij2(4),gmuji2(4)
3964       double precision dxi,dyi,dzi
3965       double precision dx_normi,dy_normi,dz_normi,aux
3966       integer j1,j2,lll,num_conti
3967       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3968      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3969      &    num_conti,j1,j2
3970       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3971       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3972       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3973       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3974      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3975      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3976      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3977      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3978      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3979      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3980      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3981       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3982       double precision dist_init,xj_safe,yj_safe,zj_safe,
3983      &  xj_temp,yj_temp,zj_temp,dist_temp,xmedi,ymedi,zmedi
3984       double precision sscale,sscagrad,scalar
3985
3986 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3987 #ifdef MOMENT
3988       double precision scal_el /1.0d0/
3989 #else
3990       double precision scal_el /0.5d0/
3991 #endif
3992 C 12/13/98
3993 C 13-go grudnia roku pamietnego...
3994       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3995      &                   0.0d0,1.0d0,0.0d0,
3996      &                   0.0d0,0.0d0,1.0d0/
3997        integer xshift,yshift,zshift
3998 c          time00=MPI_Wtime()
3999 cd      write (iout,*) "eelecij",i,j
4000 c          ind=ind+1
4001           iteli=itel(i)
4002           itelj=itel(j)
4003           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4004           aaa=app(iteli,itelj)
4005           bbb=bpp(iteli,itelj)
4006           ael6i=ael6(iteli,itelj)
4007           ael3i=ael3(iteli,itelj)
4008           dxj=dc(1,j)
4009           dyj=dc(2,j)
4010           dzj=dc(3,j)
4011           dx_normj=dc_norm(1,j)
4012           dy_normj=dc_norm(2,j)
4013           dz_normj=dc_norm(3,j)
4014 C          xj=c(1,j)+0.5D0*dxj-xmedi
4015 C          yj=c(2,j)+0.5D0*dyj-ymedi
4016 C          zj=c(3,j)+0.5D0*dzj-zmedi
4017           xj=c(1,j)+0.5D0*dxj
4018           yj=c(2,j)+0.5D0*dyj
4019           zj=c(3,j)+0.5D0*dzj
4020           xj=mod(xj,boxxsize)
4021           if (xj.lt.0) xj=xj+boxxsize
4022           yj=mod(yj,boxysize)
4023           if (yj.lt.0) yj=yj+boxysize
4024           zj=mod(zj,boxzsize)
4025           if (zj.lt.0) zj=zj+boxzsize
4026           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4027       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4028       xj_safe=xj
4029       yj_safe=yj
4030       zj_safe=zj
4031       isubchap=0
4032       do xshift=-1,1
4033       do yshift=-1,1
4034       do zshift=-1,1
4035           xj=xj_safe+xshift*boxxsize
4036           yj=yj_safe+yshift*boxysize
4037           zj=zj_safe+zshift*boxzsize
4038           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4039           if(dist_temp.lt.dist_init) then
4040             dist_init=dist_temp
4041             xj_temp=xj
4042             yj_temp=yj
4043             zj_temp=zj
4044             isubchap=1
4045           endif
4046        enddo
4047        enddo
4048        enddo
4049        if (isubchap.eq.1) then
4050           xj=xj_temp-xmedi
4051           yj=yj_temp-ymedi
4052           zj=zj_temp-zmedi
4053        else
4054           xj=xj_safe-xmedi
4055           yj=yj_safe-ymedi
4056           zj=zj_safe-zmedi
4057        endif
4058 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4059 c  174   continue
4060 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4061 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4062 C Condition for being inside the proper box
4063 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4064 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4065 c        go to 174
4066 c        endif
4067 c  175   continue
4068 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4069 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4070 C Condition for being inside the proper box
4071 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4072 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4073 c        go to 175
4074 c        endif
4075 c  176   continue
4076 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4077 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4078 C Condition for being inside the proper box
4079 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4080 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4081 c        go to 176
4082 c        endif
4083 C        endif !endPBC condintion
4084 C        xj=xj-xmedi
4085 C        yj=yj-ymedi
4086 C        zj=zj-zmedi
4087           rij=xj*xj+yj*yj+zj*zj
4088
4089           sss=sscale(sqrt(rij),r_cut_int)
4090           if (sss.eq.0.0d0) return
4091           sssgrad=sscagrad(sqrt(rij),r_cut_int)
4092 c            if (sss.gt.0.0d0) then
4093           rrmij=1.0D0/rij
4094           rij=dsqrt(rij)
4095           rmij=1.0D0/rij
4096           r3ij=rrmij*rmij
4097           r6ij=r3ij*r3ij
4098           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4099           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4100           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4101           fac=cosa-3.0D0*cosb*cosg
4102           ev1=aaa*r6ij*r6ij
4103 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4104           if (j.eq.i+2) ev1=scal_el*ev1
4105           ev2=bbb*r6ij
4106           fac3=ael6i*r6ij
4107           fac4=ael3i*r3ij
4108           evdwij=(ev1+ev2)
4109           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4110           el2=fac4*fac
4111 C MARYSIA
4112 C          eesij=(el1+el2)
4113 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4114           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4115           if (shield_mode.gt.0) then
4116 C          fac_shield(i)=0.4
4117 C          fac_shield(j)=0.6
4118           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4119           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4120           eesij=(el1+el2)
4121           ees=ees+eesij
4122           else
4123           fac_shield(i)=1.0
4124           fac_shield(j)=1.0
4125           eesij=(el1+el2)
4126           ees=ees+eesij*sss
4127           endif
4128           evdw1=evdw1+evdwij*sss
4129 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4130 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4131 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4132 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4133
4134           if (energy_dec) then
4135             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4136      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4137             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4138      &        fac_shield(i),fac_shield(j)
4139           endif
4140
4141 C
4142 C Calculate contributions to the Cartesian gradient.
4143 C
4144 #ifdef SPLITELE
4145           facvdw=-6*rrmij*(ev1+evdwij)*sss
4146           facel=-3*rrmij*(el1+eesij)
4147           fac1=fac
4148           erij(1)=xj*rmij
4149           erij(2)=yj*rmij
4150           erij(3)=zj*rmij
4151
4152 *
4153 * Radial derivatives. First process both termini of the fragment (i,j)
4154 *
4155           aux=facel+sssgrad*eesij
4156           ggg(1)=facel*xj
4157           ggg(2)=facel*yj
4158           ggg(3)=facel*zj
4159           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4160      &  (shield_mode.gt.0)) then
4161 C          print *,i,j
4162           do ilist=1,ishield_list(i)
4163            iresshield=shield_list(ilist,i)
4164            do k=1,3
4165            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4166      &      *2.0
4167            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4168      &              rlocshield
4169      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4170             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4171 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4172 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4173 C             if (iresshield.gt.i) then
4174 C               do ishi=i+1,iresshield-1
4175 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4176 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4177 C
4178 C              enddo
4179 C             else
4180 C               do ishi=iresshield,i
4181 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4182 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4183 C
4184 C               enddo
4185 C              endif
4186            enddo
4187           enddo
4188           do ilist=1,ishield_list(j)
4189            iresshield=shield_list(ilist,j)
4190            do k=1,3
4191            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4192      &     *2.0*sss
4193            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4194      &              rlocshield
4195      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4196            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4197
4198 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4199 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4200 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4201 C             if (iresshield.gt.j) then
4202 C               do ishi=j+1,iresshield-1
4203 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4204 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4205 C
4206 C               enddo
4207 C            else
4208 C               do ishi=iresshield,j
4209 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4210 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4211 C               enddo
4212 C              endif
4213            enddo
4214           enddo
4215
4216           do k=1,3
4217             gshieldc(k,i)=gshieldc(k,i)+
4218      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4219             gshieldc(k,j)=gshieldc(k,j)+
4220      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4221             gshieldc(k,i-1)=gshieldc(k,i-1)+
4222      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4223             gshieldc(k,j-1)=gshieldc(k,j-1)+
4224      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4225
4226            enddo
4227            endif
4228 c          do k=1,3
4229 c            ghalf=0.5D0*ggg(k)
4230 c            gelc(k,i)=gelc(k,i)+ghalf
4231 c            gelc(k,j)=gelc(k,j)+ghalf
4232 c          enddo
4233 c 9/28/08 AL Gradient compotents will be summed only at the end
4234 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4235           do k=1,3
4236             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4237 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4238             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4239 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4240 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4241 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4242 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4243 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4244           enddo
4245 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4246
4247 *
4248 * Loop over residues i+1 thru j-1.
4249 *
4250 cgrad          do k=i+1,j-1
4251 cgrad            do l=1,3
4252 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4253 cgrad            enddo
4254 cgrad          enddo
4255           facvdw=facvdw+sssgrad*rmij*evdwij
4256           ggg(1)=facvdw*xj
4257           ggg(2)=facvdw*yj
4258           ggg(3)=facvdw*zj
4259 c          do k=1,3
4260 c            ghalf=0.5D0*ggg(k)
4261 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4262 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4263 c          enddo
4264 c 9/28/08 AL Gradient compotents will be summed only at the end
4265           do k=1,3
4266             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4267             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4268           enddo
4269 *
4270 * Loop over residues i+1 thru j-1.
4271 *
4272 cgrad          do k=i+1,j-1
4273 cgrad            do l=1,3
4274 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4275 cgrad            enddo
4276 cgrad          enddo
4277 #else
4278 C MARYSIA
4279           facvdw=(ev1+evdwij)
4280           facel=(el1+eesij)
4281           fac1=fac
4282           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4283      &       +(evdwij+eesij)*sssgrad*rrmij
4284           erij(1)=xj*rmij
4285           erij(2)=yj*rmij
4286           erij(3)=zj*rmij
4287 *
4288 * Radial derivatives. First process both termini of the fragment (i,j)
4289 *
4290           ggg(1)=fac*xj
4291 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4292           ggg(2)=fac*yj
4293 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4294           ggg(3)=fac*zj
4295 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4296 c          do k=1,3
4297 c            ghalf=0.5D0*ggg(k)
4298 c            gelc(k,i)=gelc(k,i)+ghalf
4299 c            gelc(k,j)=gelc(k,j)+ghalf
4300 c          enddo
4301 c 9/28/08 AL Gradient compotents will be summed only at the end
4302           do k=1,3
4303             gelc_long(k,j)=gelc(k,j)+ggg(k)
4304             gelc_long(k,i)=gelc(k,i)-ggg(k)
4305           enddo
4306 *
4307 * Loop over residues i+1 thru j-1.
4308 *
4309 cgrad          do k=i+1,j-1
4310 cgrad            do l=1,3
4311 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4312 cgrad            enddo
4313 cgrad          enddo
4314 c 9/28/08 AL Gradient compotents will be summed only at the end
4315           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4316           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4317           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4318           do k=1,3
4319             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4320             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4321           enddo
4322 #endif
4323 *
4324 * Angular part
4325 *
4326           ecosa=2.0D0*fac3*fac1+fac4
4327           fac4=-3.0D0*fac4
4328           fac3=-6.0D0*fac3
4329           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4330           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4331           do k=1,3
4332             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4333             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4334           enddo
4335 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4336 cd   &          (dcosg(k),k=1,3)
4337           do k=1,3
4338             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4339      &      fac_shield(i)**2*fac_shield(j)**2
4340           enddo
4341 c          do k=1,3
4342 c            ghalf=0.5D0*ggg(k)
4343 c            gelc(k,i)=gelc(k,i)+ghalf
4344 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4345 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4346 c            gelc(k,j)=gelc(k,j)+ghalf
4347 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4348 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4349 c          enddo
4350 cgrad          do k=i+1,j-1
4351 cgrad            do l=1,3
4352 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4353 cgrad            enddo
4354 cgrad          enddo
4355 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4356           do k=1,3
4357             gelc(k,i)=gelc(k,i)
4358      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4359      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4360      &           *fac_shield(i)**2*fac_shield(j)**2
4361             gelc(k,j)=gelc(k,j)
4362      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4363      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4364      &           *fac_shield(i)**2*fac_shield(j)**2
4365             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4366             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4367           enddo
4368 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4369
4370 C MARYSIA
4371 c          endif !sscale
4372           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4373      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4374      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4375 C
4376 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4377 C   energy of a peptide unit is assumed in the form of a second-order
4378 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4379 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4380 C   are computed for EVERY pair of non-contiguous peptide groups.
4381 C
4382
4383           if (j.lt.nres-1) then
4384             j1=j+1
4385             j2=j-1
4386           else
4387             j1=j-1
4388             j2=j-2
4389           endif
4390           kkk=0
4391           lll=0
4392           do k=1,2
4393             do l=1,2
4394               kkk=kkk+1
4395               muij(kkk)=mu(k,i)*mu(l,j)
4396 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4397 #ifdef NEWCORR
4398              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4399 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4400              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4401              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4402 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4403              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4404 #endif
4405             enddo
4406           enddo
4407 #ifdef DEBUG
4408           write (iout,*) 'EELEC: i',i,' j',j
4409           write (iout,*) 'j',j,' j1',j1,' j2',j2
4410           write(iout,*) 'muij',muij
4411 #endif
4412           ury=scalar(uy(1,i),erij)
4413           urz=scalar(uz(1,i),erij)
4414           vry=scalar(uy(1,j),erij)
4415           vrz=scalar(uz(1,j),erij)
4416           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4417           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4418           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4419           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4420           fac=dsqrt(-ael6i)*r3ij
4421 #ifdef DEBUG
4422           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4423           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4424      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4425      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4426      &      "uzvz",scalar(uz(1,i),uz(1,j))
4427           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4428           write (iout,*) "fac",fac
4429 #endif
4430           a22=a22*fac
4431           a23=a23*fac
4432           a32=a32*fac
4433           a33=a33*fac
4434 #ifdef DEBUG
4435           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4436 #endif
4437 #undef DEBUG
4438 cd          write (iout,'(4i5,4f10.5)')
4439 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4440 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4441 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4442 cd     &      uy(:,j),uz(:,j)
4443 cd          write (iout,'(4f10.5)')
4444 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4445 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4446 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4447 cd           write (iout,'(9f10.5/)')
4448 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4449 C Derivatives of the elements of A in virtual-bond vectors
4450           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4451           do k=1,3
4452             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4453             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4454             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4455             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4456             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4457             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4458             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4459             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4460             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4461             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4462             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4463             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4464           enddo
4465 C Compute radial contributions to the gradient
4466           facr=-3.0d0*rrmij
4467           a22der=a22*facr
4468           a23der=a23*facr
4469           a32der=a32*facr
4470           a33der=a33*facr
4471           agg(1,1)=a22der*xj
4472           agg(2,1)=a22der*yj
4473           agg(3,1)=a22der*zj
4474           agg(1,2)=a23der*xj
4475           agg(2,2)=a23der*yj
4476           agg(3,2)=a23der*zj
4477           agg(1,3)=a32der*xj
4478           agg(2,3)=a32der*yj
4479           agg(3,3)=a32der*zj
4480           agg(1,4)=a33der*xj
4481           agg(2,4)=a33der*yj
4482           agg(3,4)=a33der*zj
4483 C Add the contributions coming from er
4484           fac3=-3.0d0*fac
4485           do k=1,3
4486             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4487             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4488             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4489             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4490           enddo
4491           do k=1,3
4492 C Derivatives in DC(i)
4493 cgrad            ghalf1=0.5d0*agg(k,1)
4494 cgrad            ghalf2=0.5d0*agg(k,2)
4495 cgrad            ghalf3=0.5d0*agg(k,3)
4496 cgrad            ghalf4=0.5d0*agg(k,4)
4497             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4498      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4499             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4500      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4501             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4502      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4503             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4504      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4505 C Derivatives in DC(i+1)
4506             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4507      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4508             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4509      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4510             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4511      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4512             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4513      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4514 C Derivatives in DC(j)
4515             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4516      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4517             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4518      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4519             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4520      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4521             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4522      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4523 C Derivatives in DC(j+1) or DC(nres-1)
4524             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4525      &      -3.0d0*vryg(k,3)*ury)
4526             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4527      &      -3.0d0*vrzg(k,3)*ury)
4528             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4529      &      -3.0d0*vryg(k,3)*urz)
4530             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4531      &      -3.0d0*vrzg(k,3)*urz)
4532 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4533 cgrad              do l=1,4
4534 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4535 cgrad              enddo
4536 cgrad            endif
4537           enddo
4538           acipa(1,1)=a22
4539           acipa(1,2)=a23
4540           acipa(2,1)=a32
4541           acipa(2,2)=a33
4542           a22=-a22
4543           a23=-a23
4544           do l=1,2
4545             do k=1,3
4546               agg(k,l)=-agg(k,l)
4547               aggi(k,l)=-aggi(k,l)
4548               aggi1(k,l)=-aggi1(k,l)
4549               aggj(k,l)=-aggj(k,l)
4550               aggj1(k,l)=-aggj1(k,l)
4551             enddo
4552           enddo
4553           if (j.lt.nres-1) then
4554             a22=-a22
4555             a32=-a32
4556             do l=1,3,2
4557               do k=1,3
4558                 agg(k,l)=-agg(k,l)
4559                 aggi(k,l)=-aggi(k,l)
4560                 aggi1(k,l)=-aggi1(k,l)
4561                 aggj(k,l)=-aggj(k,l)
4562                 aggj1(k,l)=-aggj1(k,l)
4563               enddo
4564             enddo
4565           else
4566             a22=-a22
4567             a23=-a23
4568             a32=-a32
4569             a33=-a33
4570             do l=1,4
4571               do k=1,3
4572                 agg(k,l)=-agg(k,l)
4573                 aggi(k,l)=-aggi(k,l)
4574                 aggi1(k,l)=-aggi1(k,l)
4575                 aggj(k,l)=-aggj(k,l)
4576                 aggj1(k,l)=-aggj1(k,l)
4577               enddo
4578             enddo
4579           endif
4580           ENDIF ! WCORR
4581           IF (wel_loc.gt.0.0d0) THEN
4582 C Contribution to the local-electrostatic energy coming from the i-j pair
4583           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4584      &     +a33*muij(4)
4585 #ifdef DEBUG
4586           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4587      &     " a33",a33
4588           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4589      &     " wel_loc",wel_loc
4590 #endif
4591           if (shield_mode.eq.0) then
4592            fac_shield(i)=1.0
4593            fac_shield(j)=1.0
4594 C          else
4595 C           fac_shield(i)=0.4
4596 C           fac_shield(j)=0.6
4597           endif
4598           eel_loc_ij=eel_loc_ij
4599      &    *fac_shield(i)*fac_shield(j)*sss
4600 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4601 c     &            'eelloc',i,j,eel_loc_ij
4602 C Now derivative over eel_loc
4603           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4604      &  (shield_mode.gt.0)) then
4605 C          print *,i,j
4606
4607           do ilist=1,ishield_list(i)
4608            iresshield=shield_list(ilist,i)
4609            do k=1,3
4610            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4611      &                                          /fac_shield(i)*sss
4612 C     &      *2.0
4613            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4614      &              rlocshield
4615      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)*sss
4616             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4617      &      +rlocshield
4618            enddo
4619           enddo
4620           do ilist=1,ishield_list(j)
4621            iresshield=shield_list(ilist,j)
4622            do k=1,3
4623            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4624      &                                       /fac_shield(j)*sss
4625 C     &     *2.0
4626            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4627      &              rlocshield
4628      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)*sss
4629            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4630      &             +rlocshield
4631
4632            enddo
4633           enddo
4634
4635           do k=1,3
4636             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4637      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)*sss
4638             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4639      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)*sss
4640             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4641      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)*sss
4642             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4643      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)*sss
4644            enddo
4645            endif
4646
4647
4648 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4649 c     &                     ' eel_loc_ij',eel_loc_ij
4650 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4651 C Calculate patrial derivative for theta angle
4652 #ifdef NEWCORR
4653          geel_loc_ij=(a22*gmuij1(1)
4654      &     +a23*gmuij1(2)
4655      &     +a32*gmuij1(3)
4656      &     +a33*gmuij1(4))
4657      &    *fac_shield(i)*fac_shield(j)*sss
4658 c         write(iout,*) "derivative over thatai"
4659 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4660 c     &   a33*gmuij1(4)
4661          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4662      &      geel_loc_ij*wel_loc
4663 c         write(iout,*) "derivative over thatai-1"
4664 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4665 c     &   a33*gmuij2(4)
4666          geel_loc_ij=
4667      &     a22*gmuij2(1)
4668      &     +a23*gmuij2(2)
4669      &     +a32*gmuij2(3)
4670      &     +a33*gmuij2(4)
4671          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4672      &      geel_loc_ij*wel_loc
4673      &    *fac_shield(i)*fac_shield(j)*sss
4674
4675 c  Derivative over j residue
4676          geel_loc_ji=a22*gmuji1(1)
4677      &     +a23*gmuji1(2)
4678      &     +a32*gmuji1(3)
4679      &     +a33*gmuji1(4)
4680 c         write(iout,*) "derivative over thataj"
4681 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4682 c     &   a33*gmuji1(4)
4683
4684         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4685      &      geel_loc_ji*wel_loc
4686      &    *fac_shield(i)*fac_shield(j)*sss
4687
4688          geel_loc_ji=
4689      &     +a22*gmuji2(1)
4690      &     +a23*gmuji2(2)
4691      &     +a32*gmuji2(3)
4692      &     +a33*gmuji2(4)
4693 c         write(iout,*) "derivative over thataj-1"
4694 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4695 c     &   a33*gmuji2(4)
4696          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4697      &      geel_loc_ji*wel_loc
4698      &    *fac_shield(i)*fac_shield(j)*sss
4699 #endif
4700 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4701
4702           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4703      &            'eelloc',i,j,eel_loc_ij
4704 c           if (eel_loc_ij.ne.0)
4705 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4706 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4707
4708           eel_loc=eel_loc+eel_loc_ij
4709 C Partial derivatives in virtual-bond dihedral angles gamma
4710           if (i.gt.1)
4711      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4712      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4713      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4714      &    *fac_shield(i)*fac_shield(j)*sss
4715
4716           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4717      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4718      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4719      &    *fac_shield(i)*fac_shield(j)*sss
4720 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4721           do l=1,3
4722             ggg(l)=(agg(l,1)*muij(1)+
4723      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4724      &    *fac_shield(i)*fac_shield(j)*sss
4725             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4726             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4727 cgrad            ghalf=0.5d0*ggg(l)
4728 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4729 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4730           enddo
4731 cgrad          do k=i+1,j2
4732 cgrad            do l=1,3
4733 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4734 cgrad            enddo
4735 cgrad          enddo
4736 C Remaining derivatives of eello
4737           do l=1,3
4738             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4739      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4740      &    *fac_shield(i)*fac_shield(j)*sss
4741
4742             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4743      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4744      &    *fac_shield(i)*fac_shield(j)*sss
4745
4746             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4747      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4748      &    *fac_shield(i)*fac_shield(j)*sss
4749
4750             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4751      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4752      &    *fac_shield(i)*fac_shield(j)*sss
4753
4754           enddo
4755           ENDIF
4756 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4757 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4758 #ifdef FOURBODY
4759           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4760      &       .and. num_conti.le.maxconts) then
4761 c            write (iout,*) i,j," entered corr"
4762 C
4763 C Calculate the contact function. The ith column of the array JCONT will
4764 C contain the numbers of atoms that make contacts with the atom I (of numbers
4765 C greater than I). The arrays FACONT and GACONT will contain the values of
4766 C the contact function and its derivative.
4767 c           r0ij=1.02D0*rpp(iteli,itelj)
4768 c           r0ij=1.11D0*rpp(iteli,itelj)
4769             r0ij=2.20D0*rpp(iteli,itelj)
4770 c           r0ij=1.55D0*rpp(iteli,itelj)
4771             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4772             if (fcont.gt.0.0D0) then
4773               num_conti=num_conti+1
4774               if (num_conti.gt.maxconts) then
4775                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4776      &                         ' will skip next contacts for this conf.'
4777               else
4778                 jcont_hb(num_conti,i)=j
4779 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4780 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4781                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4782      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4783 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4784 C  terms.
4785                 d_cont(num_conti,i)=rij
4786 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4787 C     --- Electrostatic-interaction matrix ---
4788                 a_chuj(1,1,num_conti,i)=a22
4789                 a_chuj(1,2,num_conti,i)=a23
4790                 a_chuj(2,1,num_conti,i)=a32
4791                 a_chuj(2,2,num_conti,i)=a33
4792 C     --- Gradient of rij
4793                 do kkk=1,3
4794                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4795                 enddo
4796                 kkll=0
4797                 do k=1,2
4798                   do l=1,2
4799                     kkll=kkll+1
4800                     do m=1,3
4801                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4802                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4803                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4804                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4805                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4806                     enddo
4807                   enddo
4808                 enddo
4809                 ENDIF
4810                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4811 C Calculate contact energies
4812                 cosa4=4.0D0*cosa
4813                 wij=cosa-3.0D0*cosb*cosg
4814                 cosbg1=cosb+cosg
4815                 cosbg2=cosb-cosg
4816 c               fac3=dsqrt(-ael6i)/r0ij**3
4817                 fac3=dsqrt(-ael6i)*r3ij
4818 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4819                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4820                 if (ees0tmp.gt.0) then
4821                   ees0pij=dsqrt(ees0tmp)
4822                 else
4823                   ees0pij=0
4824                 endif
4825 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4826                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4827                 if (ees0tmp.gt.0) then
4828                   ees0mij=dsqrt(ees0tmp)
4829                 else
4830                   ees0mij=0
4831                 endif
4832 c               ees0mij=0.0D0
4833                 if (shield_mode.eq.0) then
4834                 fac_shield(i)=1.0d0
4835                 fac_shield(j)=1.0d0
4836                 else
4837                 ees0plist(num_conti,i)=j
4838 C                fac_shield(i)=0.4d0
4839 C                fac_shield(j)=0.6d0
4840                 endif
4841                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4842      &          *fac_shield(i)*fac_shield(j)*sss
4843                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4844      &          *fac_shield(i)*fac_shield(j)*sss
4845 C Diagnostics. Comment out or remove after debugging!
4846 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4847 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4848 c               ees0m(num_conti,i)=0.0D0
4849 C End diagnostics.
4850 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4851 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4852 C Angular derivatives of the contact function
4853                 ees0pij1=fac3/ees0pij
4854                 ees0mij1=fac3/ees0mij
4855                 fac3p=-3.0D0*fac3*rrmij
4856                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4857                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4858 c               ees0mij1=0.0D0
4859                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4860                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4861                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4862                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4863                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4864                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4865                 ecosap=ecosa1+ecosa2
4866                 ecosbp=ecosb1+ecosb2
4867                 ecosgp=ecosg1+ecosg2
4868                 ecosam=ecosa1-ecosa2
4869                 ecosbm=ecosb1-ecosb2
4870                 ecosgm=ecosg1-ecosg2
4871 C Diagnostics
4872 c               ecosap=ecosa1
4873 c               ecosbp=ecosb1
4874 c               ecosgp=ecosg1
4875 c               ecosam=0.0D0
4876 c               ecosbm=0.0D0
4877 c               ecosgm=0.0D0
4878 C End diagnostics
4879                 facont_hb(num_conti,i)=fcont
4880                 fprimcont=fprimcont/rij
4881 cd              facont_hb(num_conti,i)=1.0D0
4882 C Following line is for diagnostics.
4883 cd              fprimcont=0.0D0
4884                 do k=1,3
4885                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4886                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4887                 enddo
4888                 do k=1,3
4889                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4890                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4891                 enddo
4892                 gggp(1)=gggp(1)+ees0pijp*xj
4893      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4894                 gggp(2)=gggp(2)+ees0pijp*yj
4895      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4896                 gggp(3)=gggp(3)+ees0pijp*zj
4897      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4898                 gggm(1)=gggm(1)+ees0mijp*xj
4899      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4900                 gggm(2)=gggm(2)+ees0mijp*yj
4901      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4902                 gggm(3)=gggm(3)+ees0mijp*zj
4903      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4904 C Derivatives due to the contact function
4905                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4906                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4907                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4908                 do k=1,3
4909 c
4910 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4911 c          following the change of gradient-summation algorithm.
4912 c
4913 cgrad                  ghalfp=0.5D0*gggp(k)
4914 cgrad                  ghalfm=0.5D0*gggm(k)
4915                   gacontp_hb1(k,num_conti,i)=!ghalfp
4916      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4917      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4918      &          *fac_shield(i)*fac_shield(j)*sss
4919
4920                   gacontp_hb2(k,num_conti,i)=!ghalfp
4921      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4922      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4923      &          *fac_shield(i)*fac_shield(j)*sss
4924
4925                   gacontp_hb3(k,num_conti,i)=gggp(k)
4926      &          *fac_shield(i)*fac_shield(j)*sss
4927
4928                   gacontm_hb1(k,num_conti,i)=!ghalfm
4929      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4930      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4931      &          *fac_shield(i)*fac_shield(j)*sss
4932
4933                   gacontm_hb2(k,num_conti,i)=!ghalfm
4934      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4935      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4936      &          *fac_shield(i)*fac_shield(j)*sss
4937
4938                   gacontm_hb3(k,num_conti,i)=gggm(k)
4939      &          *fac_shield(i)*fac_shield(j)*sss
4940
4941                 enddo
4942 C Diagnostics. Comment out or remove after debugging!
4943 cdiag           do k=1,3
4944 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4945 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4946 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4947 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4948 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4949 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4950 cdiag           enddo
4951               ENDIF ! wcorr
4952               endif  ! num_conti.le.maxconts
4953             endif  ! fcont.gt.0
4954           endif    ! j.gt.i+1
4955 #endif
4956           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4957             do k=1,4
4958               do l=1,3
4959                 ghalf=0.5d0*agg(l,k)
4960                 aggi(l,k)=aggi(l,k)+ghalf
4961                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4962                 aggj(l,k)=aggj(l,k)+ghalf
4963               enddo
4964             enddo
4965             if (j.eq.nres-1 .and. i.lt.j-2) then
4966               do k=1,4
4967                 do l=1,3
4968                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4969                 enddo
4970               enddo
4971             endif
4972           endif
4973 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4974       return
4975       end
4976 C-----------------------------------------------------------------------------
4977       subroutine eturn3(i,eello_turn3)
4978 C Third- and fourth-order contributions from turns
4979       implicit real*8 (a-h,o-z)
4980       include 'DIMENSIONS'
4981       include 'COMMON.IOUNITS'
4982       include 'COMMON.GEO'
4983       include 'COMMON.VAR'
4984       include 'COMMON.LOCAL'
4985       include 'COMMON.CHAIN'
4986       include 'COMMON.DERIV'
4987       include 'COMMON.INTERACT'
4988       include 'COMMON.CORRMAT'
4989       include 'COMMON.TORSION'
4990       include 'COMMON.VECTORS'
4991       include 'COMMON.FFIELD'
4992       include 'COMMON.CONTROL'
4993       include 'COMMON.SHIELD'
4994       dimension ggg(3)
4995       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4996      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4997      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4998      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4999      &  auxgmat2(2,2),auxgmatt2(2,2)
5000       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5001      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5002       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5003      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5004      &    num_conti,j1,j2
5005       j=i+2
5006 c      write (iout,*) "eturn3",i,j,j1,j2
5007       a_temp(1,1)=a22
5008       a_temp(1,2)=a23
5009       a_temp(2,1)=a32
5010       a_temp(2,2)=a33
5011 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5012 C
5013 C               Third-order contributions
5014 C
5015 C                 (i+2)o----(i+3)
5016 C                      | |
5017 C                      | |
5018 C                 (i+1)o----i
5019 C
5020 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5021 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5022         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5023 c auxalary matices for theta gradient
5024 c auxalary matrix for i+1 and constant i+2
5025         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5026 c auxalary matrix for i+2 and constant i+1
5027         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5028         call transpose2(auxmat(1,1),auxmat1(1,1))
5029         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5030         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5031         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5032         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5033         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5034         if (shield_mode.eq.0) then
5035         fac_shield(i)=1.0
5036         fac_shield(j)=1.0
5037 C        else
5038 C        fac_shield(i)=0.4
5039 C        fac_shield(j)=0.6
5040         endif
5041         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5042      &  *fac_shield(i)*fac_shield(j)
5043         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5044      &  *fac_shield(i)*fac_shield(j)
5045         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5046      &    eello_t3
5047 C#ifdef NEWCORR
5048 C Derivatives in theta
5049         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5050      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5051      &   *fac_shield(i)*fac_shield(j)
5052         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5053      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5054      &   *fac_shield(i)*fac_shield(j)
5055 C#endif
5056
5057 C Derivatives in shield mode
5058           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5059      &  (shield_mode.gt.0)) then
5060 C          print *,i,j
5061
5062           do ilist=1,ishield_list(i)
5063            iresshield=shield_list(ilist,i)
5064            do k=1,3
5065            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5066 C     &      *2.0
5067            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5068      &              rlocshield
5069      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5070             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5071      &      +rlocshield
5072            enddo
5073           enddo
5074           do ilist=1,ishield_list(j)
5075            iresshield=shield_list(ilist,j)
5076            do k=1,3
5077            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5078 C     &     *2.0
5079            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5080      &              rlocshield
5081      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5082            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5083      &             +rlocshield
5084
5085            enddo
5086           enddo
5087
5088           do k=1,3
5089             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5090      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5091             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5092      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5093             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5094      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5095             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5096      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5097            enddo
5098            endif
5099
5100 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5101 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5102 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5103 cd     &    ' eello_turn3_num',4*eello_turn3_num
5104 C Derivatives in gamma(i)
5105         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5106         call transpose2(auxmat2(1,1),auxmat3(1,1))
5107         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5108         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5109      &   *fac_shield(i)*fac_shield(j)
5110 C Derivatives in gamma(i+1)
5111         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5112         call transpose2(auxmat2(1,1),auxmat3(1,1))
5113         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5114         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5115      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5116      &   *fac_shield(i)*fac_shield(j)
5117 C Cartesian derivatives
5118         do l=1,3
5119 c            ghalf1=0.5d0*agg(l,1)
5120 c            ghalf2=0.5d0*agg(l,2)
5121 c            ghalf3=0.5d0*agg(l,3)
5122 c            ghalf4=0.5d0*agg(l,4)
5123           a_temp(1,1)=aggi(l,1)!+ghalf1
5124           a_temp(1,2)=aggi(l,2)!+ghalf2
5125           a_temp(2,1)=aggi(l,3)!+ghalf3
5126           a_temp(2,2)=aggi(l,4)!+ghalf4
5127           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5128           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5129      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5130      &   *fac_shield(i)*fac_shield(j)
5131
5132           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5133           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5134           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5135           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5136           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5137           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5138      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5139      &   *fac_shield(i)*fac_shield(j)
5140           a_temp(1,1)=aggj(l,1)!+ghalf1
5141           a_temp(1,2)=aggj(l,2)!+ghalf2
5142           a_temp(2,1)=aggj(l,3)!+ghalf3
5143           a_temp(2,2)=aggj(l,4)!+ghalf4
5144           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5145           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5146      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5147      &   *fac_shield(i)*fac_shield(j)
5148           a_temp(1,1)=aggj1(l,1)
5149           a_temp(1,2)=aggj1(l,2)
5150           a_temp(2,1)=aggj1(l,3)
5151           a_temp(2,2)=aggj1(l,4)
5152           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5153           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5154      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5155      &   *fac_shield(i)*fac_shield(j)
5156         enddo
5157       return
5158       end
5159 C-------------------------------------------------------------------------------
5160       subroutine eturn4(i,eello_turn4)
5161 C Third- and fourth-order contributions from turns
5162       implicit real*8 (a-h,o-z)
5163       include 'DIMENSIONS'
5164       include 'COMMON.IOUNITS'
5165       include 'COMMON.GEO'
5166       include 'COMMON.VAR'
5167       include 'COMMON.LOCAL'
5168       include 'COMMON.CHAIN'
5169       include 'COMMON.DERIV'
5170       include 'COMMON.INTERACT'
5171       include 'COMMON.CORRMAT'
5172       include 'COMMON.TORSION'
5173       include 'COMMON.VECTORS'
5174       include 'COMMON.FFIELD'
5175       include 'COMMON.CONTROL'
5176       include 'COMMON.SHIELD'
5177       dimension ggg(3)
5178       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5179      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5180      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5181      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5182      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5183      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5184      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5185       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5186      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5187       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5188      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5189      &    num_conti,j1,j2
5190       j=i+3
5191 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5192 C
5193 C               Fourth-order contributions
5194 C
5195 C                 (i+3)o----(i+4)
5196 C                     /  |
5197 C               (i+2)o   |
5198 C                     \  |
5199 C                 (i+1)o----i
5200 C
5201 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5202 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5203 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5204 c        write(iout,*)"WCHODZE W PROGRAM"
5205         a_temp(1,1)=a22
5206         a_temp(1,2)=a23
5207         a_temp(2,1)=a32
5208         a_temp(2,2)=a33
5209         iti1=itype2loc(itype(i+1))
5210         iti2=itype2loc(itype(i+2))
5211         iti3=itype2loc(itype(i+3))
5212 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5213         call transpose2(EUg(1,1,i+1),e1t(1,1))
5214         call transpose2(Eug(1,1,i+2),e2t(1,1))
5215         call transpose2(Eug(1,1,i+3),e3t(1,1))
5216 C Ematrix derivative in theta
5217         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5218         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5219         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5220         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5221 c       eta1 in derivative theta
5222         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5223         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5224 c       auxgvec is derivative of Ub2 so i+3 theta
5225         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5226 c       auxalary matrix of E i+1
5227         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5228 c        s1=0.0
5229 c        gs1=0.0
5230         s1=scalar2(b1(1,i+2),auxvec(1))
5231 c derivative of theta i+2 with constant i+3
5232         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5233 c derivative of theta i+2 with constant i+2
5234         gs32=scalar2(b1(1,i+2),auxgvec(1))
5235 c derivative of E matix in theta of i+1
5236         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5237
5238         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5239 c       ea31 in derivative theta
5240         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5241         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5242 c auxilary matrix auxgvec of Ub2 with constant E matirx
5243         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5244 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5245         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5246
5247 c        s2=0.0
5248 c        gs2=0.0
5249         s2=scalar2(b1(1,i+1),auxvec(1))
5250 c derivative of theta i+1 with constant i+3
5251         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5252 c derivative of theta i+2 with constant i+1
5253         gs21=scalar2(b1(1,i+1),auxgvec(1))
5254 c derivative of theta i+3 with constant i+1
5255         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5256 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5257 c     &  gtb1(1,i+1)
5258         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5259 c two derivatives over diffetent matrices
5260 c gtae3e2 is derivative over i+3
5261         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5262 c ae3gte2 is derivative over i+2
5263         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5264         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5265 c three possible derivative over theta E matices
5266 c i+1
5267         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5268 c i+2
5269         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5270 c i+3
5271         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5272         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5273
5274         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5275         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5276         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5277         if (shield_mode.eq.0) then
5278         fac_shield(i)=1.0
5279         fac_shield(j)=1.0
5280 C        else
5281 C        fac_shield(i)=0.6
5282 C        fac_shield(j)=0.4
5283         endif
5284         eello_turn4=eello_turn4-(s1+s2+s3)
5285      &  *fac_shield(i)*fac_shield(j)
5286         eello_t4=-(s1+s2+s3)
5287      &  *fac_shield(i)*fac_shield(j)
5288 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5289         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5290      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5291 C Now derivative over shield:
5292           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5293      &  (shield_mode.gt.0)) then
5294 C          print *,i,j
5295
5296           do ilist=1,ishield_list(i)
5297            iresshield=shield_list(ilist,i)
5298            do k=1,3
5299            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5300 C     &      *2.0
5301            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5302      &              rlocshield
5303      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5304             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5305      &      +rlocshield
5306            enddo
5307           enddo
5308           do ilist=1,ishield_list(j)
5309            iresshield=shield_list(ilist,j)
5310            do k=1,3
5311            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5312 C     &     *2.0
5313            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5314      &              rlocshield
5315      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5316            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5317      &             +rlocshield
5318
5319            enddo
5320           enddo
5321
5322           do k=1,3
5323             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5324      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5325             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5326      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5327             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5328      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5329             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5330      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5331            enddo
5332            endif
5333
5334
5335
5336
5337
5338
5339 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5340 cd     &    ' eello_turn4_num',8*eello_turn4_num
5341 #ifdef NEWCORR
5342         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5343      &                  -(gs13+gsE13+gsEE1)*wturn4
5344      &  *fac_shield(i)*fac_shield(j)
5345         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5346      &                    -(gs23+gs21+gsEE2)*wturn4
5347      &  *fac_shield(i)*fac_shield(j)
5348
5349         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5350      &                    -(gs32+gsE31+gsEE3)*wturn4
5351      &  *fac_shield(i)*fac_shield(j)
5352
5353 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5354 c     &   gs2
5355 #endif
5356         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5357      &      'eturn4',i,j,-(s1+s2+s3)
5358 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5359 c     &    ' eello_turn4_num',8*eello_turn4_num
5360 C Derivatives in gamma(i)
5361         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5362         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5363         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5364         s1=scalar2(b1(1,i+2),auxvec(1))
5365         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5366         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5367         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5368      &  *fac_shield(i)*fac_shield(j)
5369 C Derivatives in gamma(i+1)
5370         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5371         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5372         s2=scalar2(b1(1,i+1),auxvec(1))
5373         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5374         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5375         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5376         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5377      &  *fac_shield(i)*fac_shield(j)
5378 C Derivatives in gamma(i+2)
5379         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5380         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5381         s1=scalar2(b1(1,i+2),auxvec(1))
5382         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5383         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5384         s2=scalar2(b1(1,i+1),auxvec(1))
5385         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5386         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5387         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5388         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5389      &  *fac_shield(i)*fac_shield(j)
5390 C Cartesian derivatives
5391 C Derivatives of this turn contributions in DC(i+2)
5392         if (j.lt.nres-1) then
5393           do l=1,3
5394             a_temp(1,1)=agg(l,1)
5395             a_temp(1,2)=agg(l,2)
5396             a_temp(2,1)=agg(l,3)
5397             a_temp(2,2)=agg(l,4)
5398             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5399             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5400             s1=scalar2(b1(1,i+2),auxvec(1))
5401             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5402             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5403             s2=scalar2(b1(1,i+1),auxvec(1))
5404             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5405             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5406             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5407             ggg(l)=-(s1+s2+s3)
5408             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5409      &  *fac_shield(i)*fac_shield(j)
5410           enddo
5411         endif
5412 C Remaining derivatives of this turn contribution
5413         do l=1,3
5414           a_temp(1,1)=aggi(l,1)
5415           a_temp(1,2)=aggi(l,2)
5416           a_temp(2,1)=aggi(l,3)
5417           a_temp(2,2)=aggi(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           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5428      &  *fac_shield(i)*fac_shield(j)
5429           a_temp(1,1)=aggi1(l,1)
5430           a_temp(1,2)=aggi1(l,2)
5431           a_temp(2,1)=aggi1(l,3)
5432           a_temp(2,2)=aggi1(l,4)
5433           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5434           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5435           s1=scalar2(b1(1,i+2),auxvec(1))
5436           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5437           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5438           s2=scalar2(b1(1,i+1),auxvec(1))
5439           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5440           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5441           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5442           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5443      &  *fac_shield(i)*fac_shield(j)
5444           a_temp(1,1)=aggj(l,1)
5445           a_temp(1,2)=aggj(l,2)
5446           a_temp(2,1)=aggj(l,3)
5447           a_temp(2,2)=aggj(l,4)
5448           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5449           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5450           s1=scalar2(b1(1,i+2),auxvec(1))
5451           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5452           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5453           s2=scalar2(b1(1,i+1),auxvec(1))
5454           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5455           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5456           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5457           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5458      &  *fac_shield(i)*fac_shield(j)
5459           a_temp(1,1)=aggj1(l,1)
5460           a_temp(1,2)=aggj1(l,2)
5461           a_temp(2,1)=aggj1(l,3)
5462           a_temp(2,2)=aggj1(l,4)
5463           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5464           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5465           s1=scalar2(b1(1,i+2),auxvec(1))
5466           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5467           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5468           s2=scalar2(b1(1,i+1),auxvec(1))
5469           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5470           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5471           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5472 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5473           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5474      &  *fac_shield(i)*fac_shield(j)
5475         enddo
5476       return
5477       end
5478 C-----------------------------------------------------------------------------
5479       subroutine vecpr(u,v,w)
5480       implicit real*8(a-h,o-z)
5481       dimension u(3),v(3),w(3)
5482       w(1)=u(2)*v(3)-u(3)*v(2)
5483       w(2)=-u(1)*v(3)+u(3)*v(1)
5484       w(3)=u(1)*v(2)-u(2)*v(1)
5485       return
5486       end
5487 C-----------------------------------------------------------------------------
5488       subroutine unormderiv(u,ugrad,unorm,ungrad)
5489 C This subroutine computes the derivatives of a normalized vector u, given
5490 C the derivatives computed without normalization conditions, ugrad. Returns
5491 C ungrad.
5492       implicit none
5493       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5494       double precision vec(3)
5495       double precision scalar
5496       integer i,j
5497 c      write (2,*) 'ugrad',ugrad
5498 c      write (2,*) 'u',u
5499       do i=1,3
5500         vec(i)=scalar(ugrad(1,i),u(1))
5501       enddo
5502 c      write (2,*) 'vec',vec
5503       do i=1,3
5504         do j=1,3
5505           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5506         enddo
5507       enddo
5508 c      write (2,*) 'ungrad',ungrad
5509       return
5510       end
5511 C-----------------------------------------------------------------------------
5512       subroutine escp_soft_sphere(evdw2,evdw2_14)
5513 C
5514 C This subroutine calculates the excluded-volume interaction energy between
5515 C peptide-group centers and side chains and its gradient in virtual-bond and
5516 C side-chain vectors.
5517 C
5518       implicit real*8 (a-h,o-z)
5519       include 'DIMENSIONS'
5520       include 'COMMON.GEO'
5521       include 'COMMON.VAR'
5522       include 'COMMON.LOCAL'
5523       include 'COMMON.CHAIN'
5524       include 'COMMON.DERIV'
5525       include 'COMMON.INTERACT'
5526       include 'COMMON.FFIELD'
5527       include 'COMMON.IOUNITS'
5528       include 'COMMON.CONTROL'
5529       dimension ggg(3)
5530       integer xshift,yshift,zshift
5531       evdw2=0.0D0
5532       evdw2_14=0.0d0
5533       r0_scp=4.5d0
5534 cd    print '(a)','Enter ESCP'
5535 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5536 C      do xshift=-1,1
5537 C      do yshift=-1,1
5538 C      do zshift=-1,1
5539       do i=iatscp_s,iatscp_e
5540         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5541         iteli=itel(i)
5542         xi=0.5D0*(c(1,i)+c(1,i+1))
5543         yi=0.5D0*(c(2,i)+c(2,i+1))
5544         zi=0.5D0*(c(3,i)+c(3,i+1))
5545 C Return atom into box, boxxsize is size of box in x dimension
5546 c  134   continue
5547 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5548 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5549 C Condition for being inside the proper box
5550 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5551 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5552 c        go to 134
5553 c        endif
5554 c  135   continue
5555 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5556 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5557 C Condition for being inside the proper box
5558 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5559 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5560 c        go to 135
5561 c c       endif
5562 c  136   continue
5563 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5564 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5565 cC Condition for being inside the proper box
5566 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5567 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5568 c        go to 136
5569 c        endif
5570           xi=mod(xi,boxxsize)
5571           if (xi.lt.0) xi=xi+boxxsize
5572           yi=mod(yi,boxysize)
5573           if (yi.lt.0) yi=yi+boxysize
5574           zi=mod(zi,boxzsize)
5575           if (zi.lt.0) zi=zi+boxzsize
5576 C          xi=xi+xshift*boxxsize
5577 C          yi=yi+yshift*boxysize
5578 C          zi=zi+zshift*boxzsize
5579         do iint=1,nscp_gr(i)
5580
5581         do j=iscpstart(i,iint),iscpend(i,iint)
5582           if (itype(j).eq.ntyp1) cycle
5583           itypj=iabs(itype(j))
5584 C Uncomment following three lines for SC-p interactions
5585 c         xj=c(1,nres+j)-xi
5586 c         yj=c(2,nres+j)-yi
5587 c         zj=c(3,nres+j)-zi
5588 C Uncomment following three lines for Ca-p interactions
5589           xj=c(1,j)
5590           yj=c(2,j)
5591           zj=c(3,j)
5592 c  174   continue
5593 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5594 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5595 C Condition for being inside the proper box
5596 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5597 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5598 c        go to 174
5599 c        endif
5600 c  175   continue
5601 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5602 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5603 cC Condition for being inside the proper box
5604 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5605 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5606 c        go to 175
5607 c        endif
5608 c  176   continue
5609 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5610 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5611 C Condition for being inside the proper box
5612 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5613 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5614 c        go to 176
5615           xj=mod(xj,boxxsize)
5616           if (xj.lt.0) xj=xj+boxxsize
5617           yj=mod(yj,boxysize)
5618           if (yj.lt.0) yj=yj+boxysize
5619           zj=mod(zj,boxzsize)
5620           if (zj.lt.0) zj=zj+boxzsize
5621       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5622       xj_safe=xj
5623       yj_safe=yj
5624       zj_safe=zj
5625       subchap=0
5626       do xshift=-1,1
5627       do yshift=-1,1
5628       do zshift=-1,1
5629           xj=xj_safe+xshift*boxxsize
5630           yj=yj_safe+yshift*boxysize
5631           zj=zj_safe+zshift*boxzsize
5632           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5633           if(dist_temp.lt.dist_init) then
5634             dist_init=dist_temp
5635             xj_temp=xj
5636             yj_temp=yj
5637             zj_temp=zj
5638             subchap=1
5639           endif
5640        enddo
5641        enddo
5642        enddo
5643        if (subchap.eq.1) then
5644           xj=xj_temp-xi
5645           yj=yj_temp-yi
5646           zj=zj_temp-zi
5647        else
5648           xj=xj_safe-xi
5649           yj=yj_safe-yi
5650           zj=zj_safe-zi
5651        endif
5652 c c       endif
5653 C          xj=xj-xi
5654 C          yj=yj-yi
5655 C          zj=zj-zi
5656           rij=xj*xj+yj*yj+zj*zj
5657
5658           r0ij=r0_scp
5659           r0ijsq=r0ij*r0ij
5660           if (rij.lt.r0ijsq) then
5661             evdwij=0.25d0*(rij-r0ijsq)**2
5662             fac=rij-r0ijsq
5663           else
5664             evdwij=0.0d0
5665             fac=0.0d0
5666           endif
5667           evdw2=evdw2+evdwij
5668 C
5669 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5670 C
5671           ggg(1)=xj*fac
5672           ggg(2)=yj*fac
5673           ggg(3)=zj*fac
5674 cgrad          if (j.lt.i) then
5675 cd          write (iout,*) 'j<i'
5676 C Uncomment following three lines for SC-p interactions
5677 c           do k=1,3
5678 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5679 c           enddo
5680 cgrad          else
5681 cd          write (iout,*) 'j>i'
5682 cgrad            do k=1,3
5683 cgrad              ggg(k)=-ggg(k)
5684 C Uncomment following line for SC-p interactions
5685 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5686 cgrad            enddo
5687 cgrad          endif
5688 cgrad          do k=1,3
5689 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5690 cgrad          enddo
5691 cgrad          kstart=min0(i+1,j)
5692 cgrad          kend=max0(i-1,j-1)
5693 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5694 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5695 cgrad          do k=kstart,kend
5696 cgrad            do l=1,3
5697 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5698 cgrad            enddo
5699 cgrad          enddo
5700           do k=1,3
5701             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5702             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5703           enddo
5704         enddo
5705
5706         enddo ! iint
5707       enddo ! i
5708 C      enddo !zshift
5709 C      enddo !yshift
5710 C      enddo !xshift
5711       return
5712       end
5713 C-----------------------------------------------------------------------------
5714       subroutine escp(evdw2,evdw2_14)
5715 C
5716 C This subroutine calculates the excluded-volume interaction energy between
5717 C peptide-group centers and side chains and its gradient in virtual-bond and
5718 C side-chain vectors.
5719 C
5720       implicit none
5721       include 'DIMENSIONS'
5722       include 'COMMON.GEO'
5723       include 'COMMON.VAR'
5724       include 'COMMON.LOCAL'
5725       include 'COMMON.CHAIN'
5726       include 'COMMON.DERIV'
5727       include 'COMMON.INTERACT'
5728       include 'COMMON.FFIELD'
5729       include 'COMMON.IOUNITS'
5730       include 'COMMON.CONTROL'
5731       include 'COMMON.SPLITELE'
5732       integer xshift,yshift,zshift
5733       double precision ggg(3)
5734       integer i,iint,j,k,iteli,itypj,subchap
5735       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5736      & fac,e1,e2,rij
5737       double precision evdw2,evdw2_14,evdwij
5738       double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,
5739      & dist_temp, dist_init
5740       double precision sscale,sscagrad
5741       evdw2=0.0D0
5742       evdw2_14=0.0d0
5743 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5744 cd    print '(a)','Enter ESCP'
5745 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5746 C      do xshift=-1,1
5747 C      do yshift=-1,1
5748 C      do zshift=-1,1
5749       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5750       do i=iatscp_s,iatscp_e
5751         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5752         iteli=itel(i)
5753         xi=0.5D0*(c(1,i)+c(1,i+1))
5754         yi=0.5D0*(c(2,i)+c(2,i+1))
5755         zi=0.5D0*(c(3,i)+c(3,i+1))
5756           xi=mod(xi,boxxsize)
5757           if (xi.lt.0) xi=xi+boxxsize
5758           yi=mod(yi,boxysize)
5759           if (yi.lt.0) yi=yi+boxysize
5760           zi=mod(zi,boxzsize)
5761           if (zi.lt.0) zi=zi+boxzsize
5762 c          xi=xi+xshift*boxxsize
5763 c          yi=yi+yshift*boxysize
5764 c          zi=zi+zshift*boxzsize
5765 c        print *,xi,yi,zi,'polozenie i'
5766 C Return atom into box, boxxsize is size of box in x dimension
5767 c  134   continue
5768 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5769 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5770 C Condition for being inside the proper box
5771 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5772 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5773 c        go to 134
5774 c        endif
5775 c  135   continue
5776 c          print *,xi,boxxsize,"pierwszy"
5777
5778 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5779 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5780 C Condition for being inside the proper box
5781 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5782 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5783 c        go to 135
5784 c        endif
5785 c  136   continue
5786 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5787 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5788 C Condition for being inside the proper box
5789 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5790 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5791 c        go to 136
5792 c        endif
5793         do iint=1,nscp_gr(i)
5794
5795         do j=iscpstart(i,iint),iscpend(i,iint)
5796           itypj=iabs(itype(j))
5797           if (itypj.eq.ntyp1) cycle
5798 C Uncomment following three lines for SC-p interactions
5799 c         xj=c(1,nres+j)-xi
5800 c         yj=c(2,nres+j)-yi
5801 c         zj=c(3,nres+j)-zi
5802 C Uncomment following three lines for Ca-p interactions
5803           xj=c(1,j)
5804           yj=c(2,j)
5805           zj=c(3,j)
5806           xj=mod(xj,boxxsize)
5807           if (xj.lt.0) xj=xj+boxxsize
5808           yj=mod(yj,boxysize)
5809           if (yj.lt.0) yj=yj+boxysize
5810           zj=mod(zj,boxzsize)
5811           if (zj.lt.0) zj=zj+boxzsize
5812 c  174   continue
5813 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5814 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5815 C Condition for being inside the proper box
5816 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5817 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5818 c        go to 174
5819 c        endif
5820 c  175   continue
5821 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5822 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5823 cC Condition for being inside the proper box
5824 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5825 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5826 c        go to 175
5827 c        endif
5828 c  176   continue
5829 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5830 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5831 C Condition for being inside the proper box
5832 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5833 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5834 c        go to 176
5835 c        endif
5836 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5837       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5838       xj_safe=xj
5839       yj_safe=yj
5840       zj_safe=zj
5841       subchap=0
5842       do xshift=-1,1
5843       do yshift=-1,1
5844       do zshift=-1,1
5845           xj=xj_safe+xshift*boxxsize
5846           yj=yj_safe+yshift*boxysize
5847           zj=zj_safe+zshift*boxzsize
5848           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5849           if(dist_temp.lt.dist_init) then
5850             dist_init=dist_temp
5851             xj_temp=xj
5852             yj_temp=yj
5853             zj_temp=zj
5854             subchap=1
5855           endif
5856        enddo
5857        enddo
5858        enddo
5859        if (subchap.eq.1) then
5860           xj=xj_temp-xi
5861           yj=yj_temp-yi
5862           zj=zj_temp-zi
5863        else
5864           xj=xj_safe-xi
5865           yj=yj_safe-yi
5866           zj=zj_safe-zi
5867        endif
5868 c          print *,xj,yj,zj,'polozenie j'
5869           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5870 c          print *,rrij
5871           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5872 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5873 c          if (sss.eq.0) print *,'czasem jest OK'
5874           if (sss.le.0.0d0) cycle
5875           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5876           fac=rrij**expon2
5877           e1=fac*fac*aad(itypj,iteli)
5878           e2=fac*bad(itypj,iteli)
5879           if (iabs(j-i) .le. 2) then
5880             e1=scal14*e1
5881             e2=scal14*e2
5882             evdw2_14=evdw2_14+(e1+e2)*sss
5883           endif
5884           evdwij=e1+e2
5885           evdw2=evdw2+evdwij*sss
5886           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5887      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5888      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5889      &       bad(itypj,iteli)
5890 C
5891 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5892 C
5893           fac=-(evdwij+e1)*rrij*sss
5894           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5895           ggg(1)=xj*fac
5896           ggg(2)=yj*fac
5897           ggg(3)=zj*fac
5898 cgrad          if (j.lt.i) then
5899 cd          write (iout,*) 'j<i'
5900 C Uncomment following three lines for SC-p interactions
5901 c           do k=1,3
5902 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5903 c           enddo
5904 cgrad          else
5905 cd          write (iout,*) 'j>i'
5906 cgrad            do k=1,3
5907 cgrad              ggg(k)=-ggg(k)
5908 C Uncomment following line for SC-p interactions
5909 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5910 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5911 cgrad            enddo
5912 cgrad          endif
5913 cgrad          do k=1,3
5914 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5915 cgrad          enddo
5916 cgrad          kstart=min0(i+1,j)
5917 cgrad          kend=max0(i-1,j-1)
5918 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5919 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5920 cgrad          do k=kstart,kend
5921 cgrad            do l=1,3
5922 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5923 cgrad            enddo
5924 cgrad          enddo
5925           do k=1,3
5926             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5927             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5928           enddo
5929 c        endif !endif for sscale cutoff
5930         enddo ! j
5931
5932         enddo ! iint
5933       enddo ! i
5934 c      enddo !zshift
5935 c      enddo !yshift
5936 c      enddo !xshift
5937       do i=1,nct
5938         do j=1,3
5939           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5940           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5941           gradx_scp(j,i)=expon*gradx_scp(j,i)
5942         enddo
5943       enddo
5944 C******************************************************************************
5945 C
5946 C                              N O T E !!!
5947 C
5948 C To save time the factor EXPON has been extracted from ALL components
5949 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5950 C use!
5951 C
5952 C******************************************************************************
5953       return
5954       end
5955 C--------------------------------------------------------------------------
5956       subroutine edis(ehpb)
5957 C
5958 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5959 C
5960       implicit real*8 (a-h,o-z)
5961       include 'DIMENSIONS'
5962       include 'COMMON.SBRIDGE'
5963       include 'COMMON.CHAIN'
5964       include 'COMMON.DERIV'
5965       include 'COMMON.VAR'
5966       include 'COMMON.INTERACT'
5967       include 'COMMON.IOUNITS'
5968       include 'COMMON.CONTROL'
5969       dimension ggg(3),ggg_peak(3,1000)
5970       ehpb=0.0D0
5971       do i=1,3
5972        ggg(i)=0.0d0
5973       enddo
5974 c 8/21/18 AL: added explicit restraints on reference coords
5975 c      write (iout,*) "restr_on_coord",restr_on_coord
5976       if (restr_on_coord) then
5977
5978       do i=nnt,nct
5979         ecoor=0.0d0
5980         if (itype(i).eq.ntyp1) cycle
5981         do j=1,3
5982           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5983           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5984         enddo
5985         if (itype(i).ne.10) then
5986           do j=1,3
5987             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5988             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5989           enddo
5990         endif
5991         if (energy_dec) write (iout,*)
5992      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5993         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5994       enddo
5995
5996       endif
5997 C      write (iout,*) ,"link_end",link_end,constr_dist
5998 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5999 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
6000 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
6001 c     &  " link_end_peak",link_end_peak
6002       if (link_end.eq.0.and.link_end_peak.eq.0) return
6003       do i=link_start_peak,link_end_peak
6004         ehpb_peak=0.0d0
6005 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
6006 c     &   ipeak(1,i),ipeak(2,i)
6007         do ip=ipeak(1,i),ipeak(2,i)
6008           ii=ihpb_peak(ip)
6009           jj=jhpb_peak(ip)
6010           dd=dist(ii,jj)
6011           iip=ip-ipeak(1,i)+1
6012 C iii and jjj point to the residues for which the distance is assigned.
6013 c          if (ii.gt.nres) then
6014 c            iii=ii-nres
6015 c            jjj=jj-nres
6016 c          else
6017 c            iii=ii
6018 c            jjj=jj
6019 c          endif
6020           if (ii.gt.nres) then
6021             iii=ii-nres
6022           else
6023             iii=ii
6024           endif
6025           if (jj.gt.nres) then
6026             jjj=jj-nres
6027           else
6028             jjj=jj
6029           endif
6030           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
6031           aux=dexp(-scal_peak*aux)
6032           ehpb_peak=ehpb_peak+aux
6033           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
6034      &      forcon_peak(ip))*aux/dd
6035           do j=1,3
6036             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
6037           enddo
6038           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
6039      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
6040      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
6041         enddo
6042 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
6043         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
6044         do ip=ipeak(1,i),ipeak(2,i)
6045           iip=ip-ipeak(1,i)+1
6046           do j=1,3
6047             ggg(j)=ggg_peak(j,iip)/ehpb_peak
6048           enddo
6049           ii=ihpb_peak(ip)
6050           jj=jhpb_peak(ip)
6051 C iii and jjj point to the residues for which the distance is assigned.
6052 c          if (ii.gt.nres) then
6053 c            iii=ii-nres
6054 c            jjj=jj-nres
6055 c          else
6056 c            iii=ii
6057 c            jjj=jj
6058 c          endif
6059           if (ii.gt.nres) then
6060             iii=ii-nres
6061           else
6062             iii=ii
6063           endif
6064           if (jj.gt.nres) then
6065             jjj=jj-nres
6066           else
6067             jjj=jj
6068           endif
6069           if (iii.lt.ii) then
6070             do j=1,3
6071               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6072             enddo
6073           endif
6074           if (jjj.lt.jj) then
6075             do j=1,3
6076               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6077             enddo
6078           endif
6079           do k=1,3
6080             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6081             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6082           enddo
6083         enddo
6084       enddo
6085       do i=link_start,link_end
6086 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6087 C CA-CA distance used in regularization of structure.
6088         ii=ihpb(i)
6089         jj=jhpb(i)
6090 C iii and jjj point to the residues for which the distance is assigned.
6091         if (ii.gt.nres) then
6092           iii=ii-nres
6093         else
6094           iii=ii
6095         endif
6096         if (jj.gt.nres) then
6097           jjj=jj-nres
6098         else
6099           jjj=jj
6100         endif
6101 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6102 c     &    dhpb(i),dhpb1(i),forcon(i)
6103 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6104 C    distance and angle dependent SS bond potential.
6105 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6106 C     & iabs(itype(jjj)).eq.1) then
6107 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6108 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6109         if (.not.dyn_ss .and. i.le.nss) then
6110 C 15/02/13 CC dynamic SSbond - additional check
6111           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6112      &        iabs(itype(jjj)).eq.1) then
6113            call ssbond_ene(iii,jjj,eij)
6114            ehpb=ehpb+2*eij
6115          endif
6116 cd          write (iout,*) "eij",eij
6117 cd   &   ' waga=',waga,' fac=',fac
6118 !        else if (ii.gt.nres .and. jj.gt.nres) then
6119         else
6120 C Calculate the distance between the two points and its difference from the
6121 C target distance.
6122           dd=dist(ii,jj)
6123           if (irestr_type(i).eq.11) then
6124             ehpb=ehpb+fordepth(i)!**4.0d0
6125      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6126             fac=fordepth(i)!**4.0d0
6127      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6128             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6129      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6130      &        ehpb,irestr_type(i)
6131           else if (irestr_type(i).eq.10) then
6132 c AL 6//19/2018 cross-link restraints
6133             xdis = 0.5d0*(dd/forcon(i))**2
6134             expdis = dexp(-xdis)
6135 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6136             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6137 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6138 c     &          " wboltzd",wboltzd
6139             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6140 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6141             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6142      &           *expdis/(aux*forcon(i)**2)
6143             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6144      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6145      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6146           else if (irestr_type(i).eq.2) then
6147 c Quartic restraints
6148             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6149             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6150      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6151      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6152             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6153           else
6154 c Quadratic restraints
6155             rdis=dd-dhpb(i)
6156 C Get the force constant corresponding to this distance.
6157             waga=forcon(i)
6158 C Calculate the contribution to energy.
6159             ehpb=ehpb+0.5d0*waga*rdis*rdis
6160             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6161      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6162      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6163 C
6164 C Evaluate gradient.
6165 C
6166             fac=waga*rdis/dd
6167           endif
6168 c Calculate Cartesian gradient
6169           do j=1,3
6170             ggg(j)=fac*(c(j,jj)-c(j,ii))
6171           enddo
6172 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6173 C If this is a SC-SC distance, we need to calculate the contributions to the
6174 C Cartesian gradient in the SC vectors (ghpbx).
6175           if (iii.lt.ii) then
6176             do j=1,3
6177               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6178             enddo
6179           endif
6180           if (jjj.lt.jj) then
6181             do j=1,3
6182               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6183             enddo
6184           endif
6185           do k=1,3
6186             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6187             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6188           enddo
6189         endif
6190       enddo
6191       return
6192       end
6193 C--------------------------------------------------------------------------
6194       subroutine ssbond_ene(i,j,eij)
6195 C
6196 C Calculate the distance and angle dependent SS-bond potential energy
6197 C using a free-energy function derived based on RHF/6-31G** ab initio
6198 C calculations of diethyl disulfide.
6199 C
6200 C A. Liwo and U. Kozlowska, 11/24/03
6201 C
6202       implicit real*8 (a-h,o-z)
6203       include 'DIMENSIONS'
6204       include 'COMMON.SBRIDGE'
6205       include 'COMMON.CHAIN'
6206       include 'COMMON.DERIV'
6207       include 'COMMON.LOCAL'
6208       include 'COMMON.INTERACT'
6209       include 'COMMON.VAR'
6210       include 'COMMON.IOUNITS'
6211       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6212       itypi=iabs(itype(i))
6213       xi=c(1,nres+i)
6214       yi=c(2,nres+i)
6215       zi=c(3,nres+i)
6216       dxi=dc_norm(1,nres+i)
6217       dyi=dc_norm(2,nres+i)
6218       dzi=dc_norm(3,nres+i)
6219 c      dsci_inv=dsc_inv(itypi)
6220       dsci_inv=vbld_inv(nres+i)
6221       itypj=iabs(itype(j))
6222 c      dscj_inv=dsc_inv(itypj)
6223       dscj_inv=vbld_inv(nres+j)
6224       xj=c(1,nres+j)-xi
6225       yj=c(2,nres+j)-yi
6226       zj=c(3,nres+j)-zi
6227       dxj=dc_norm(1,nres+j)
6228       dyj=dc_norm(2,nres+j)
6229       dzj=dc_norm(3,nres+j)
6230       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6231       rij=dsqrt(rrij)
6232       erij(1)=xj*rij
6233       erij(2)=yj*rij
6234       erij(3)=zj*rij
6235       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6236       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6237       om12=dxi*dxj+dyi*dyj+dzi*dzj
6238       do k=1,3
6239         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6240         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6241       enddo
6242       rij=1.0d0/rij
6243       deltad=rij-d0cm
6244       deltat1=1.0d0-om1
6245       deltat2=1.0d0+om2
6246       deltat12=om2-om1+2.0d0
6247       cosphi=om12-om1*om2
6248       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6249      &  +akct*deltad*deltat12
6250      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6251 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6252 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6253 c     &  " deltat12",deltat12," eij",eij
6254       ed=2*akcm*deltad+akct*deltat12
6255       pom1=akct*deltad
6256       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6257       eom1=-2*akth*deltat1-pom1-om2*pom2
6258       eom2= 2*akth*deltat2+pom1-om1*pom2
6259       eom12=pom2
6260       do k=1,3
6261         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6262         ghpbx(k,i)=ghpbx(k,i)-ggk
6263      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6264      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6265         ghpbx(k,j)=ghpbx(k,j)+ggk
6266      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6267      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6268         ghpbc(k,i)=ghpbc(k,i)-ggk
6269         ghpbc(k,j)=ghpbc(k,j)+ggk
6270       enddo
6271 C
6272 C Calculate the components of the gradient in DC and X
6273 C
6274 cgrad      do k=i,j-1
6275 cgrad        do l=1,3
6276 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6277 cgrad        enddo
6278 cgrad      enddo
6279       return
6280       end
6281 C--------------------------------------------------------------------------
6282       subroutine ebond(estr)
6283 c
6284 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6285 c
6286       implicit real*8 (a-h,o-z)
6287       include 'DIMENSIONS'
6288       include 'COMMON.LOCAL'
6289       include 'COMMON.GEO'
6290       include 'COMMON.INTERACT'
6291       include 'COMMON.DERIV'
6292       include 'COMMON.VAR'
6293       include 'COMMON.CHAIN'
6294       include 'COMMON.IOUNITS'
6295       include 'COMMON.NAMES'
6296       include 'COMMON.FFIELD'
6297       include 'COMMON.CONTROL'
6298       include 'COMMON.SETUP'
6299       double precision u(3),ud(3)
6300       estr=0.0d0
6301       estr1=0.0d0
6302       do i=ibondp_start,ibondp_end
6303 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6304 c      used
6305 #ifdef FIVEDIAG
6306         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6307         diff = vbld(i)-vbldp0
6308 #else
6309         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6310 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6311 c          do j=1,3
6312 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6313 c     &      *dc(j,i-1)/vbld(i)
6314 c          enddo
6315 c          if (energy_dec) write(iout,*)
6316 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6317 c        else
6318 C       Checking if it involves dummy (NH3+ or COO-) group
6319         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6320 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6321           diff = vbld(i)-vbldpDUM
6322           if (energy_dec) write(iout,*) "dum_bond",i,diff
6323         else
6324 C NO    vbldp0 is the equlibrium length of spring for peptide group
6325           diff = vbld(i)-vbldp0
6326         endif
6327 #endif
6328         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6329      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6330         estr=estr+diff*diff
6331         do j=1,3
6332           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6333         enddo
6334 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6335 c        endif
6336       enddo
6337
6338       estr=0.5d0*AKP*estr+estr1
6339 c
6340 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6341 c
6342       do i=ibond_start,ibond_end
6343         iti=iabs(itype(i))
6344         if (iti.ne.10 .and. iti.ne.ntyp1) then
6345           nbi=nbondterm(iti)
6346           if (nbi.eq.1) then
6347             diff=vbld(i+nres)-vbldsc0(1,iti)
6348             if (energy_dec)  write (iout,*)
6349      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6350      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6351             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6352             do j=1,3
6353               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6354             enddo
6355           else
6356             do j=1,nbi
6357               diff=vbld(i+nres)-vbldsc0(j,iti)
6358               ud(j)=aksc(j,iti)*diff
6359               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6360             enddo
6361             uprod=u(1)
6362             do j=2,nbi
6363               uprod=uprod*u(j)
6364             enddo
6365             usum=0.0d0
6366             usumsqder=0.0d0
6367             do j=1,nbi
6368               uprod1=1.0d0
6369               uprod2=1.0d0
6370               do k=1,nbi
6371                 if (k.ne.j) then
6372                   uprod1=uprod1*u(k)
6373                   uprod2=uprod2*u(k)*u(k)
6374                 endif
6375               enddo
6376               usum=usum+uprod1
6377               usumsqder=usumsqder+ud(j)*uprod2
6378             enddo
6379             estr=estr+uprod/usum
6380             do j=1,3
6381              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6382             enddo
6383           endif
6384         endif
6385       enddo
6386       return
6387       end
6388 #ifdef CRYST_THETA
6389 C--------------------------------------------------------------------------
6390       subroutine ebend(etheta)
6391 C
6392 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6393 C angles gamma and its derivatives in consecutive thetas and gammas.
6394 C
6395       implicit real*8 (a-h,o-z)
6396       include 'DIMENSIONS'
6397       include 'COMMON.LOCAL'
6398       include 'COMMON.GEO'
6399       include 'COMMON.INTERACT'
6400       include 'COMMON.DERIV'
6401       include 'COMMON.VAR'
6402       include 'COMMON.CHAIN'
6403       include 'COMMON.IOUNITS'
6404       include 'COMMON.NAMES'
6405       include 'COMMON.FFIELD'
6406       include 'COMMON.CONTROL'
6407       include 'COMMON.TORCNSTR'
6408       common /calcthet/ term1,term2,termm,diffak,ratak,
6409      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6410      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6411       double precision y(2),z(2)
6412       delta=0.02d0*pi
6413 c      time11=dexp(-2*time)
6414 c      time12=1.0d0
6415       etheta=0.0D0
6416 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6417       do i=ithet_start,ithet_end
6418         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6419      &  .or.itype(i).eq.ntyp1) cycle
6420 C Zero the energy function and its derivative at 0 or pi.
6421         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6422         it=itype(i-1)
6423         ichir1=isign(1,itype(i-2))
6424         ichir2=isign(1,itype(i))
6425          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6426          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6427          if (itype(i-1).eq.10) then
6428           itype1=isign(10,itype(i-2))
6429           ichir11=isign(1,itype(i-2))
6430           ichir12=isign(1,itype(i-2))
6431           itype2=isign(10,itype(i))
6432           ichir21=isign(1,itype(i))
6433           ichir22=isign(1,itype(i))
6434          endif
6435
6436         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6437 #ifdef OSF
6438           phii=phi(i)
6439           if (phii.ne.phii) phii=150.0
6440 #else
6441           phii=phi(i)
6442 #endif
6443           y(1)=dcos(phii)
6444           y(2)=dsin(phii)
6445         else
6446           y(1)=0.0D0
6447           y(2)=0.0D0
6448         endif
6449         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6450 #ifdef OSF
6451           phii1=phi(i+1)
6452           if (phii1.ne.phii1) phii1=150.0
6453           phii1=pinorm(phii1)
6454           z(1)=cos(phii1)
6455 #else
6456           phii1=phi(i+1)
6457 #endif
6458           z(1)=dcos(phii1)
6459           z(2)=dsin(phii1)
6460         else
6461           z(1)=0.0D0
6462           z(2)=0.0D0
6463         endif
6464 C Calculate the "mean" value of theta from the part of the distribution
6465 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6466 C In following comments this theta will be referred to as t_c.
6467         thet_pred_mean=0.0d0
6468         do k=1,2
6469             athetk=athet(k,it,ichir1,ichir2)
6470             bthetk=bthet(k,it,ichir1,ichir2)
6471           if (it.eq.10) then
6472              athetk=athet(k,itype1,ichir11,ichir12)
6473              bthetk=bthet(k,itype2,ichir21,ichir22)
6474           endif
6475          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6476 c         write(iout,*) 'chuj tu', y(k),z(k)
6477         enddo
6478         dthett=thet_pred_mean*ssd
6479         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6480 C Derivatives of the "mean" values in gamma1 and gamma2.
6481         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6482      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6483          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6484      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6485          if (it.eq.10) then
6486       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6487      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6488         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6489      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6490          endif
6491         if (theta(i).gt.pi-delta) then
6492           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6493      &         E_tc0)
6494           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6495           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6496           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6497      &        E_theta)
6498           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6499      &        E_tc)
6500         else if (theta(i).lt.delta) then
6501           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6502           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6503           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6504      &        E_theta)
6505           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6506           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6507      &        E_tc)
6508         else
6509           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6510      &        E_theta,E_tc)
6511         endif
6512         etheta=etheta+ethetai
6513         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6514      &      'ebend',i,ethetai,theta(i),itype(i)
6515         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6516         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6517         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6518       enddo
6519
6520 C Ufff.... We've done all this!!!
6521       return
6522       end
6523 C---------------------------------------------------------------------------
6524       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6525      &     E_tc)
6526       implicit real*8 (a-h,o-z)
6527       include 'DIMENSIONS'
6528       include 'COMMON.LOCAL'
6529       include 'COMMON.IOUNITS'
6530       common /calcthet/ term1,term2,termm,diffak,ratak,
6531      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6532      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6533 C Calculate the contributions to both Gaussian lobes.
6534 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6535 C The "polynomial part" of the "standard deviation" of this part of
6536 C the distributioni.
6537 ccc        write (iout,*) thetai,thet_pred_mean
6538         sig=polthet(3,it)
6539         do j=2,0,-1
6540           sig=sig*thet_pred_mean+polthet(j,it)
6541         enddo
6542 C Derivative of the "interior part" of the "standard deviation of the"
6543 C gamma-dependent Gaussian lobe in t_c.
6544         sigtc=3*polthet(3,it)
6545         do j=2,1,-1
6546           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6547         enddo
6548         sigtc=sig*sigtc
6549 C Set the parameters of both Gaussian lobes of the distribution.
6550 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6551         fac=sig*sig+sigc0(it)
6552         sigcsq=fac+fac
6553         sigc=1.0D0/sigcsq
6554 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6555         sigsqtc=-4.0D0*sigcsq*sigtc
6556 c       print *,i,sig,sigtc,sigsqtc
6557 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6558         sigtc=-sigtc/(fac*fac)
6559 C Following variable is sigma(t_c)**(-2)
6560         sigcsq=sigcsq*sigcsq
6561         sig0i=sig0(it)
6562         sig0inv=1.0D0/sig0i**2
6563         delthec=thetai-thet_pred_mean
6564         delthe0=thetai-theta0i
6565         term1=-0.5D0*sigcsq*delthec*delthec
6566         term2=-0.5D0*sig0inv*delthe0*delthe0
6567 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6568 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6569 C NaNs in taking the logarithm. We extract the largest exponent which is added
6570 C to the energy (this being the log of the distribution) at the end of energy
6571 C term evaluation for this virtual-bond angle.
6572         if (term1.gt.term2) then
6573           termm=term1
6574           term2=dexp(term2-termm)
6575           term1=1.0d0
6576         else
6577           termm=term2
6578           term1=dexp(term1-termm)
6579           term2=1.0d0
6580         endif
6581 C The ratio between the gamma-independent and gamma-dependent lobes of
6582 C the distribution is a Gaussian function of thet_pred_mean too.
6583         diffak=gthet(2,it)-thet_pred_mean
6584         ratak=diffak/gthet(3,it)**2
6585         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6586 C Let's differentiate it in thet_pred_mean NOW.
6587         aktc=ak*ratak
6588 C Now put together the distribution terms to make complete distribution.
6589         termexp=term1+ak*term2
6590         termpre=sigc+ak*sig0i
6591 C Contribution of the bending energy from this theta is just the -log of
6592 C the sum of the contributions from the two lobes and the pre-exponential
6593 C factor. Simple enough, isn't it?
6594         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6595 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6596 C NOW the derivatives!!!
6597 C 6/6/97 Take into account the deformation.
6598         E_theta=(delthec*sigcsq*term1
6599      &       +ak*delthe0*sig0inv*term2)/termexp
6600         E_tc=((sigtc+aktc*sig0i)/termpre
6601      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6602      &       aktc*term2)/termexp)
6603       return
6604       end
6605 c-----------------------------------------------------------------------------
6606       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6607       implicit real*8 (a-h,o-z)
6608       include 'DIMENSIONS'
6609       include 'COMMON.LOCAL'
6610       include 'COMMON.IOUNITS'
6611       common /calcthet/ term1,term2,termm,diffak,ratak,
6612      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6613      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6614       delthec=thetai-thet_pred_mean
6615       delthe0=thetai-theta0i
6616 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6617       t3 = thetai-thet_pred_mean
6618       t6 = t3**2
6619       t9 = term1
6620       t12 = t3*sigcsq
6621       t14 = t12+t6*sigsqtc
6622       t16 = 1.0d0
6623       t21 = thetai-theta0i
6624       t23 = t21**2
6625       t26 = term2
6626       t27 = t21*t26
6627       t32 = termexp
6628       t40 = t32**2
6629       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6630      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6631      & *(-t12*t9-ak*sig0inv*t27)
6632       return
6633       end
6634 #else
6635 C--------------------------------------------------------------------------
6636       subroutine ebend(etheta)
6637 C
6638 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6639 C angles gamma and its derivatives in consecutive thetas and gammas.
6640 C ab initio-derived potentials from
6641 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6642 C
6643       implicit real*8 (a-h,o-z)
6644       include 'DIMENSIONS'
6645       include 'COMMON.LOCAL'
6646       include 'COMMON.GEO'
6647       include 'COMMON.INTERACT'
6648       include 'COMMON.DERIV'
6649       include 'COMMON.VAR'
6650       include 'COMMON.CHAIN'
6651       include 'COMMON.IOUNITS'
6652       include 'COMMON.NAMES'
6653       include 'COMMON.FFIELD'
6654       include 'COMMON.CONTROL'
6655       include 'COMMON.TORCNSTR'
6656       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6657      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6658      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6659      & sinph1ph2(maxdouble,maxdouble)
6660       logical lprn /.false./, lprn1 /.false./
6661       etheta=0.0D0
6662       do i=ithet_start,ithet_end
6663 c        print *,i,itype(i-1),itype(i),itype(i-2)
6664         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6665      &  .or.itype(i).eq.ntyp1) cycle
6666 C        print *,i,theta(i)
6667         if (iabs(itype(i+1)).eq.20) iblock=2
6668         if (iabs(itype(i+1)).ne.20) iblock=1
6669         dethetai=0.0d0
6670         dephii=0.0d0
6671         dephii1=0.0d0
6672         theti2=0.5d0*theta(i)
6673         ityp2=ithetyp((itype(i-1)))
6674         do k=1,nntheterm
6675           coskt(k)=dcos(k*theti2)
6676           sinkt(k)=dsin(k*theti2)
6677         enddo
6678 C        print *,ethetai
6679         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6680 #ifdef OSF
6681           phii=phi(i)
6682           if (phii.ne.phii) phii=150.0
6683 #else
6684           phii=phi(i)
6685 #endif
6686           ityp1=ithetyp((itype(i-2)))
6687 C propagation of chirality for glycine type
6688           do k=1,nsingle
6689             cosph1(k)=dcos(k*phii)
6690             sinph1(k)=dsin(k*phii)
6691           enddo
6692         else
6693           phii=0.0d0
6694           do k=1,nsingle
6695           ityp1=ithetyp((itype(i-2)))
6696             cosph1(k)=0.0d0
6697             sinph1(k)=0.0d0
6698           enddo
6699         endif
6700         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6701 #ifdef OSF
6702           phii1=phi(i+1)
6703           if (phii1.ne.phii1) phii1=150.0
6704           phii1=pinorm(phii1)
6705 #else
6706           phii1=phi(i+1)
6707 #endif
6708           ityp3=ithetyp((itype(i)))
6709           do k=1,nsingle
6710             cosph2(k)=dcos(k*phii1)
6711             sinph2(k)=dsin(k*phii1)
6712           enddo
6713         else
6714           phii1=0.0d0
6715           ityp3=ithetyp((itype(i)))
6716           do k=1,nsingle
6717             cosph2(k)=0.0d0
6718             sinph2(k)=0.0d0
6719           enddo
6720         endif
6721         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6722         do k=1,ndouble
6723           do l=1,k-1
6724             ccl=cosph1(l)*cosph2(k-l)
6725             ssl=sinph1(l)*sinph2(k-l)
6726             scl=sinph1(l)*cosph2(k-l)
6727             csl=cosph1(l)*sinph2(k-l)
6728             cosph1ph2(l,k)=ccl-ssl
6729             cosph1ph2(k,l)=ccl+ssl
6730             sinph1ph2(l,k)=scl+csl
6731             sinph1ph2(k,l)=scl-csl
6732           enddo
6733         enddo
6734         if (lprn) then
6735         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6736      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6737         write (iout,*) "coskt and sinkt"
6738         do k=1,nntheterm
6739           write (iout,*) k,coskt(k),sinkt(k)
6740         enddo
6741         endif
6742         do k=1,ntheterm
6743           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6744           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6745      &      *coskt(k)
6746           if (lprn)
6747      &    write (iout,*) "k",k,"
6748      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6749      &     " ethetai",ethetai
6750         enddo
6751         if (lprn) then
6752         write (iout,*) "cosph and sinph"
6753         do k=1,nsingle
6754           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6755         enddo
6756         write (iout,*) "cosph1ph2 and sinph2ph2"
6757         do k=2,ndouble
6758           do l=1,k-1
6759             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6760      &         sinph1ph2(l,k),sinph1ph2(k,l)
6761           enddo
6762         enddo
6763         write(iout,*) "ethetai",ethetai
6764         endif
6765 C       print *,ethetai
6766         do m=1,ntheterm2
6767           do k=1,nsingle
6768             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6769      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6770      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6771      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6772             ethetai=ethetai+sinkt(m)*aux
6773             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6774             dephii=dephii+k*sinkt(m)*(
6775      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6776      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6777             dephii1=dephii1+k*sinkt(m)*(
6778      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6779      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6780             if (lprn)
6781      &      write (iout,*) "m",m," k",k," bbthet",
6782      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6783      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6784      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6785      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6786 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6787           enddo
6788         enddo
6789 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6790 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6791 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6792 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6793         if (lprn)
6794      &  write(iout,*) "ethetai",ethetai
6795 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6796         do m=1,ntheterm3
6797           do k=2,ndouble
6798             do l=1,k-1
6799               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6800      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6801      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6802      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6803               ethetai=ethetai+sinkt(m)*aux
6804               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6805               dephii=dephii+l*sinkt(m)*(
6806      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6807      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6808      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6809      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6810               dephii1=dephii1+(k-l)*sinkt(m)*(
6811      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6812      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6813      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6814      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6815               if (lprn) then
6816               write (iout,*) "m",m," k",k," l",l," ffthet",
6817      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6818      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6819      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6820      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6821      &            " ethetai",ethetai
6822               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6823      &            cosph1ph2(k,l)*sinkt(m),
6824      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6825               endif
6826             enddo
6827           enddo
6828         enddo
6829 10      continue
6830 c        lprn1=.true.
6831 C        print *,ethetai
6832         if (lprn1)
6833      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6834      &   i,theta(i)*rad2deg,phii*rad2deg,
6835      &   phii1*rad2deg,ethetai
6836 c        lprn1=.false.
6837         etheta=etheta+ethetai
6838         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6839         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6840         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6841       enddo
6842
6843       return
6844       end
6845 #endif
6846 #ifdef CRYST_SC
6847 c-----------------------------------------------------------------------------
6848       subroutine esc(escloc)
6849 C Calculate the local energy of a side chain and its derivatives in the
6850 C corresponding virtual-bond valence angles THETA and the spherical angles
6851 C ALPHA and OMEGA.
6852       implicit real*8 (a-h,o-z)
6853       include 'DIMENSIONS'
6854       include 'COMMON.GEO'
6855       include 'COMMON.LOCAL'
6856       include 'COMMON.VAR'
6857       include 'COMMON.INTERACT'
6858       include 'COMMON.DERIV'
6859       include 'COMMON.CHAIN'
6860       include 'COMMON.IOUNITS'
6861       include 'COMMON.NAMES'
6862       include 'COMMON.FFIELD'
6863       include 'COMMON.CONTROL'
6864       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6865      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6866       common /sccalc/ time11,time12,time112,theti,it,nlobit
6867       delta=0.02d0*pi
6868       escloc=0.0D0
6869 c     write (iout,'(a)') 'ESC'
6870       do i=loc_start,loc_end
6871         it=itype(i)
6872         if (it.eq.ntyp1) cycle
6873         if (it.eq.10) goto 1
6874         nlobit=nlob(iabs(it))
6875 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6876 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6877         theti=theta(i+1)-pipol
6878         x(1)=dtan(theti)
6879         x(2)=alph(i)
6880         x(3)=omeg(i)
6881
6882         if (x(2).gt.pi-delta) then
6883           xtemp(1)=x(1)
6884           xtemp(2)=pi-delta
6885           xtemp(3)=x(3)
6886           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6887           xtemp(2)=pi
6888           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6889           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6890      &        escloci,dersc(2))
6891           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6892      &        ddersc0(1),dersc(1))
6893           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6894      &        ddersc0(3),dersc(3))
6895           xtemp(2)=pi-delta
6896           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6897           xtemp(2)=pi
6898           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6899           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6900      &            dersc0(2),esclocbi,dersc02)
6901           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6902      &            dersc12,dersc01)
6903           call splinthet(x(2),0.5d0*delta,ss,ssd)
6904           dersc0(1)=dersc01
6905           dersc0(2)=dersc02
6906           dersc0(3)=0.0d0
6907           do k=1,3
6908             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6909           enddo
6910           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6911 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6912 c    &             esclocbi,ss,ssd
6913           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6914 c         escloci=esclocbi
6915 c         write (iout,*) escloci
6916         else if (x(2).lt.delta) then
6917           xtemp(1)=x(1)
6918           xtemp(2)=delta
6919           xtemp(3)=x(3)
6920           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6921           xtemp(2)=0.0d0
6922           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6923           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6924      &        escloci,dersc(2))
6925           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6926      &        ddersc0(1),dersc(1))
6927           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6928      &        ddersc0(3),dersc(3))
6929           xtemp(2)=delta
6930           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6931           xtemp(2)=0.0d0
6932           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6933           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6934      &            dersc0(2),esclocbi,dersc02)
6935           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6936      &            dersc12,dersc01)
6937           dersc0(1)=dersc01
6938           dersc0(2)=dersc02
6939           dersc0(3)=0.0d0
6940           call splinthet(x(2),0.5d0*delta,ss,ssd)
6941           do k=1,3
6942             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6943           enddo
6944           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6945 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6946 c    &             esclocbi,ss,ssd
6947           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6948 c         write (iout,*) escloci
6949         else
6950           call enesc(x,escloci,dersc,ddummy,.false.)
6951         endif
6952
6953         escloc=escloc+escloci
6954         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6955      &     'escloc',i,escloci
6956 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6957
6958         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6959      &   wscloc*dersc(1)
6960         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6961         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6962     1   continue
6963       enddo
6964       return
6965       end
6966 C---------------------------------------------------------------------------
6967       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6968       implicit real*8 (a-h,o-z)
6969       include 'DIMENSIONS'
6970       include 'COMMON.GEO'
6971       include 'COMMON.LOCAL'
6972       include 'COMMON.IOUNITS'
6973       common /sccalc/ time11,time12,time112,theti,it,nlobit
6974       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6975       double precision contr(maxlob,-1:1)
6976       logical mixed
6977 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6978         escloc_i=0.0D0
6979         do j=1,3
6980           dersc(j)=0.0D0
6981           if (mixed) ddersc(j)=0.0d0
6982         enddo
6983         x3=x(3)
6984
6985 C Because of periodicity of the dependence of the SC energy in omega we have
6986 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6987 C To avoid underflows, first compute & store the exponents.
6988
6989         do iii=-1,1
6990
6991           x(3)=x3+iii*dwapi
6992
6993           do j=1,nlobit
6994             do k=1,3
6995               z(k)=x(k)-censc(k,j,it)
6996             enddo
6997             do k=1,3
6998               Axk=0.0D0
6999               do l=1,3
7000                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7001               enddo
7002               Ax(k,j,iii)=Axk
7003             enddo
7004             expfac=0.0D0
7005             do k=1,3
7006               expfac=expfac+Ax(k,j,iii)*z(k)
7007             enddo
7008             contr(j,iii)=expfac
7009           enddo ! j
7010
7011         enddo ! iii
7012
7013         x(3)=x3
7014 C As in the case of ebend, we want to avoid underflows in exponentiation and
7015 C subsequent NaNs and INFs in energy calculation.
7016 C Find the largest exponent
7017         emin=contr(1,-1)
7018         do iii=-1,1
7019           do j=1,nlobit
7020             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7021           enddo
7022         enddo
7023         emin=0.5D0*emin
7024 cd      print *,'it=',it,' emin=',emin
7025
7026 C Compute the contribution to SC energy and derivatives
7027         do iii=-1,1
7028
7029           do j=1,nlobit
7030 #ifdef OSF
7031             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7032             if(adexp.ne.adexp) adexp=1.0
7033             expfac=dexp(adexp)
7034 #else
7035             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7036 #endif
7037 cd          print *,'j=',j,' expfac=',expfac
7038             escloc_i=escloc_i+expfac
7039             do k=1,3
7040               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7041             enddo
7042             if (mixed) then
7043               do k=1,3,2
7044                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7045      &            +gaussc(k,2,j,it))*expfac
7046               enddo
7047             endif
7048           enddo
7049
7050         enddo ! iii
7051
7052         dersc(1)=dersc(1)/cos(theti)**2
7053         ddersc(1)=ddersc(1)/cos(theti)**2
7054         ddersc(3)=ddersc(3)
7055
7056         escloci=-(dlog(escloc_i)-emin)
7057         do j=1,3
7058           dersc(j)=dersc(j)/escloc_i
7059         enddo
7060         if (mixed) then
7061           do j=1,3,2
7062             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7063           enddo
7064         endif
7065       return
7066       end
7067 C------------------------------------------------------------------------------
7068       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7069       implicit real*8 (a-h,o-z)
7070       include 'DIMENSIONS'
7071       include 'COMMON.GEO'
7072       include 'COMMON.LOCAL'
7073       include 'COMMON.IOUNITS'
7074       common /sccalc/ time11,time12,time112,theti,it,nlobit
7075       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7076       double precision contr(maxlob)
7077       logical mixed
7078
7079       escloc_i=0.0D0
7080
7081       do j=1,3
7082         dersc(j)=0.0D0
7083       enddo
7084
7085       do j=1,nlobit
7086         do k=1,2
7087           z(k)=x(k)-censc(k,j,it)
7088         enddo
7089         z(3)=dwapi
7090         do k=1,3
7091           Axk=0.0D0
7092           do l=1,3
7093             Axk=Axk+gaussc(l,k,j,it)*z(l)
7094           enddo
7095           Ax(k,j)=Axk
7096         enddo
7097         expfac=0.0D0
7098         do k=1,3
7099           expfac=expfac+Ax(k,j)*z(k)
7100         enddo
7101         contr(j)=expfac
7102       enddo ! j
7103
7104 C As in the case of ebend, we want to avoid underflows in exponentiation and
7105 C subsequent NaNs and INFs in energy calculation.
7106 C Find the largest exponent
7107       emin=contr(1)
7108       do j=1,nlobit
7109         if (emin.gt.contr(j)) emin=contr(j)
7110       enddo
7111       emin=0.5D0*emin
7112
7113 C Compute the contribution to SC energy and derivatives
7114
7115       dersc12=0.0d0
7116       do j=1,nlobit
7117         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7118         escloc_i=escloc_i+expfac
7119         do k=1,2
7120           dersc(k)=dersc(k)+Ax(k,j)*expfac
7121         enddo
7122         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7123      &            +gaussc(1,2,j,it))*expfac
7124         dersc(3)=0.0d0
7125       enddo
7126
7127       dersc(1)=dersc(1)/cos(theti)**2
7128       dersc12=dersc12/cos(theti)**2
7129       escloci=-(dlog(escloc_i)-emin)
7130       do j=1,2
7131         dersc(j)=dersc(j)/escloc_i
7132       enddo
7133       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7134       return
7135       end
7136 #else
7137 c----------------------------------------------------------------------------------
7138       subroutine esc(escloc)
7139 C Calculate the local energy of a side chain and its derivatives in the
7140 C corresponding virtual-bond valence angles THETA and the spherical angles
7141 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7142 C added by Urszula Kozlowska. 07/11/2007
7143 C
7144       implicit real*8 (a-h,o-z)
7145       include 'DIMENSIONS'
7146       include 'COMMON.GEO'
7147       include 'COMMON.LOCAL'
7148       include 'COMMON.VAR'
7149       include 'COMMON.SCROT'
7150       include 'COMMON.INTERACT'
7151       include 'COMMON.DERIV'
7152       include 'COMMON.CHAIN'
7153       include 'COMMON.IOUNITS'
7154       include 'COMMON.NAMES'
7155       include 'COMMON.FFIELD'
7156       include 'COMMON.CONTROL'
7157       include 'COMMON.VECTORS'
7158       double precision x_prime(3),y_prime(3),z_prime(3)
7159      &    , sumene,dsc_i,dp2_i,x(65),
7160      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7161      &    de_dxx,de_dyy,de_dzz,de_dt
7162       double precision s1_t,s1_6_t,s2_t,s2_6_t
7163       double precision
7164      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7165      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7166      & dt_dCi(3),dt_dCi1(3)
7167       common /sccalc/ time11,time12,time112,theti,it,nlobit
7168       delta=0.02d0*pi
7169       escloc=0.0D0
7170       do i=loc_start,loc_end
7171         if (itype(i).eq.ntyp1) cycle
7172         costtab(i+1) =dcos(theta(i+1))
7173         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7174         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7175         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7176         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7177         cosfac=dsqrt(cosfac2)
7178         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7179         sinfac=dsqrt(sinfac2)
7180         it=iabs(itype(i))
7181         if (it.eq.10) goto 1
7182 c
7183 C  Compute the axes of tghe local cartesian coordinates system; store in
7184 c   x_prime, y_prime and z_prime
7185 c
7186         do j=1,3
7187           x_prime(j) = 0.00
7188           y_prime(j) = 0.00
7189           z_prime(j) = 0.00
7190         enddo
7191 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7192 C     &   dc_norm(3,i+nres)
7193         do j = 1,3
7194           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7195           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7196         enddo
7197         do j = 1,3
7198           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7199         enddo
7200 c       write (2,*) "i",i
7201 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7202 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7203 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7204 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7205 c      & " xy",scalar(x_prime(1),y_prime(1)),
7206 c      & " xz",scalar(x_prime(1),z_prime(1)),
7207 c      & " yy",scalar(y_prime(1),y_prime(1)),
7208 c      & " yz",scalar(y_prime(1),z_prime(1)),
7209 c      & " zz",scalar(z_prime(1),z_prime(1))
7210 c
7211 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7212 C to local coordinate system. Store in xx, yy, zz.
7213 c
7214         xx=0.0d0
7215         yy=0.0d0
7216         zz=0.0d0
7217         do j = 1,3
7218           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7219           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7220           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7221         enddo
7222
7223         xxtab(i)=xx
7224         yytab(i)=yy
7225         zztab(i)=zz
7226 C
7227 C Compute the energy of the ith side cbain
7228 C
7229 c        write (2,*) "xx",xx," yy",yy," zz",zz
7230         it=iabs(itype(i))
7231         do j = 1,65
7232           x(j) = sc_parmin(j,it)
7233         enddo
7234 #ifdef CHECK_COORD
7235 Cc diagnostics - remove later
7236         xx1 = dcos(alph(2))
7237         yy1 = dsin(alph(2))*dcos(omeg(2))
7238         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7239         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7240      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7241      &    xx1,yy1,zz1
7242 C,"  --- ", xx_w,yy_w,zz_w
7243 c end diagnostics
7244 #endif
7245         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7246      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7247      &   + x(10)*yy*zz
7248         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7249      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7250      & + x(20)*yy*zz
7251         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7252      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7253      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7254      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7255      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7256      &  +x(40)*xx*yy*zz
7257         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7258      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7259      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7260      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7261      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7262      &  +x(60)*xx*yy*zz
7263         dsc_i   = 0.743d0+x(61)
7264         dp2_i   = 1.9d0+x(62)
7265         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7266      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7267         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7268      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7269         s1=(1+x(63))/(0.1d0 + dscp1)
7270         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7271         s2=(1+x(65))/(0.1d0 + dscp2)
7272         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7273         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7274      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7275 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7276 c     &   sumene4,
7277 c     &   dscp1,dscp2,sumene
7278 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7279         escloc = escloc + sumene
7280         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7281      &   " escloc",sumene,escloc,it,itype(i)
7282 c     & ,zz,xx,yy
7283 c#define DEBUG
7284 #ifdef DEBUG
7285 C
7286 C This section to check the numerical derivatives of the energy of ith side
7287 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7288 C #define DEBUG in the code to turn it on.
7289 C
7290         write (2,*) "sumene               =",sumene
7291         aincr=1.0d-7
7292         xxsave=xx
7293         xx=xx+aincr
7294         write (2,*) xx,yy,zz
7295         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7296         de_dxx_num=(sumenep-sumene)/aincr
7297         xx=xxsave
7298         write (2,*) "xx+ sumene from enesc=",sumenep
7299         yysave=yy
7300         yy=yy+aincr
7301         write (2,*) xx,yy,zz
7302         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7303         de_dyy_num=(sumenep-sumene)/aincr
7304         yy=yysave
7305         write (2,*) "yy+ sumene from enesc=",sumenep
7306         zzsave=zz
7307         zz=zz+aincr
7308         write (2,*) xx,yy,zz
7309         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7310         de_dzz_num=(sumenep-sumene)/aincr
7311         zz=zzsave
7312         write (2,*) "zz+ sumene from enesc=",sumenep
7313         costsave=cost2tab(i+1)
7314         sintsave=sint2tab(i+1)
7315         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7316         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7317         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7318         de_dt_num=(sumenep-sumene)/aincr
7319         write (2,*) " t+ sumene from enesc=",sumenep
7320         cost2tab(i+1)=costsave
7321         sint2tab(i+1)=sintsave
7322 C End of diagnostics section.
7323 #endif
7324 C
7325 C Compute the gradient of esc
7326 C
7327 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7328         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7329         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7330         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7331         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7332         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7333         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7334         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7335         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7336         pom1=(sumene3*sint2tab(i+1)+sumene1)
7337      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7338         pom2=(sumene4*cost2tab(i+1)+sumene2)
7339      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7340         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7341         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7342      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7343      &  +x(40)*yy*zz
7344         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7345         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7346      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7347      &  +x(60)*yy*zz
7348         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7349      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7350      &        +(pom1+pom2)*pom_dx
7351 #ifdef DEBUG
7352         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7353 #endif
7354 C
7355         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7356         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7357      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7358      &  +x(40)*xx*zz
7359         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7360         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7361      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7362      &  +x(59)*zz**2 +x(60)*xx*zz
7363         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7364      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7365      &        +(pom1-pom2)*pom_dy
7366 #ifdef DEBUG
7367         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7368 #endif
7369 C
7370         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7371      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7372      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7373      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7374      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7375      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7376      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7377      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7378 #ifdef DEBUG
7379         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7380 #endif
7381 C
7382         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7383      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7384      &  +pom1*pom_dt1+pom2*pom_dt2
7385 #ifdef DEBUG
7386         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7387 #endif
7388 c#undef DEBUG
7389 c
7390 C
7391        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7392        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7393        cosfac2xx=cosfac2*xx
7394        sinfac2yy=sinfac2*yy
7395        do k = 1,3
7396          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7397      &      vbld_inv(i+1)
7398          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7399      &      vbld_inv(i)
7400          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7401          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7402 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7403 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7404 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7405 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7406          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7407          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7408          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7409          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7410          dZZ_Ci1(k)=0.0d0
7411          dZZ_Ci(k)=0.0d0
7412          do j=1,3
7413            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7414      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7415            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7416      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7417          enddo
7418
7419          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7420          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7421          dZZ_XYZ(k)=vbld_inv(i+nres)*
7422      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7423 c
7424          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7425          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7426        enddo
7427
7428        do k=1,3
7429          dXX_Ctab(k,i)=dXX_Ci(k)
7430          dXX_C1tab(k,i)=dXX_Ci1(k)
7431          dYY_Ctab(k,i)=dYY_Ci(k)
7432          dYY_C1tab(k,i)=dYY_Ci1(k)
7433          dZZ_Ctab(k,i)=dZZ_Ci(k)
7434          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7435          dXX_XYZtab(k,i)=dXX_XYZ(k)
7436          dYY_XYZtab(k,i)=dYY_XYZ(k)
7437          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7438        enddo
7439
7440        do k = 1,3
7441 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7442 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7443 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7444 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7445 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7446 c     &    dt_dci(k)
7447 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7448 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7449          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7450      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7451          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7452      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7453          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7454      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7455        enddo
7456 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7457 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7458
7459 C to check gradient call subroutine check_grad
7460
7461     1 continue
7462       enddo
7463       return
7464       end
7465 c------------------------------------------------------------------------------
7466       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7467       implicit none
7468       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7469      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7470       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7471      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7472      &   + x(10)*yy*zz
7473       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7474      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7475      & + x(20)*yy*zz
7476       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7477      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7478      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7479      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7480      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7481      &  +x(40)*xx*yy*zz
7482       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7483      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7484      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7485      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7486      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7487      &  +x(60)*xx*yy*zz
7488       dsc_i   = 0.743d0+x(61)
7489       dp2_i   = 1.9d0+x(62)
7490       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7491      &          *(xx*cost2+yy*sint2))
7492       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7493      &          *(xx*cost2-yy*sint2))
7494       s1=(1+x(63))/(0.1d0 + dscp1)
7495       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7496       s2=(1+x(65))/(0.1d0 + dscp2)
7497       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7498       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7499      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7500       enesc=sumene
7501       return
7502       end
7503 #endif
7504 c------------------------------------------------------------------------------
7505       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7506 C
7507 C This procedure calculates two-body contact function g(rij) and its derivative:
7508 C
7509 C           eps0ij                                     !       x < -1
7510 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7511 C            0                                         !       x > 1
7512 C
7513 C where x=(rij-r0ij)/delta
7514 C
7515 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7516 C
7517       implicit none
7518       double precision rij,r0ij,eps0ij,fcont,fprimcont
7519       double precision x,x2,x4,delta
7520 c     delta=0.02D0*r0ij
7521 c      delta=0.2D0*r0ij
7522       x=(rij-r0ij)/delta
7523       if (x.lt.-1.0D0) then
7524         fcont=eps0ij
7525         fprimcont=0.0D0
7526       else if (x.le.1.0D0) then
7527         x2=x*x
7528         x4=x2*x2
7529         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7530         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7531       else
7532         fcont=0.0D0
7533         fprimcont=0.0D0
7534       endif
7535       return
7536       end
7537 c------------------------------------------------------------------------------
7538       subroutine splinthet(theti,delta,ss,ssder)
7539       implicit real*8 (a-h,o-z)
7540       include 'DIMENSIONS'
7541       include 'COMMON.VAR'
7542       include 'COMMON.GEO'
7543       thetup=pi-delta
7544       thetlow=delta
7545       if (theti.gt.pipol) then
7546         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7547       else
7548         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7549         ssder=-ssder
7550       endif
7551       return
7552       end
7553 c------------------------------------------------------------------------------
7554       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7555       implicit none
7556       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7557       double precision ksi,ksi2,ksi3,a1,a2,a3
7558       a1=fprim0*delta/(f1-f0)
7559       a2=3.0d0-2.0d0*a1
7560       a3=a1-2.0d0
7561       ksi=(x-x0)/delta
7562       ksi2=ksi*ksi
7563       ksi3=ksi2*ksi
7564       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7565       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7566       return
7567       end
7568 c------------------------------------------------------------------------------
7569       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7570       implicit none
7571       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7572       double precision ksi,ksi2,ksi3,a1,a2,a3
7573       ksi=(x-x0)/delta
7574       ksi2=ksi*ksi
7575       ksi3=ksi2*ksi
7576       a1=fprim0x*delta
7577       a2=3*(f1x-f0x)-2*fprim0x*delta
7578       a3=fprim0x*delta-2*(f1x-f0x)
7579       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7580       return
7581       end
7582 C-----------------------------------------------------------------------------
7583 #ifdef CRYST_TOR
7584 C-----------------------------------------------------------------------------
7585       subroutine etor(etors)
7586       implicit real*8 (a-h,o-z)
7587       include 'DIMENSIONS'
7588       include 'COMMON.VAR'
7589       include 'COMMON.GEO'
7590       include 'COMMON.LOCAL'
7591       include 'COMMON.TORSION'
7592       include 'COMMON.INTERACT'
7593       include 'COMMON.DERIV'
7594       include 'COMMON.CHAIN'
7595       include 'COMMON.NAMES'
7596       include 'COMMON.IOUNITS'
7597       include 'COMMON.FFIELD'
7598       include 'COMMON.TORCNSTR'
7599       include 'COMMON.CONTROL'
7600       logical lprn
7601 C Set lprn=.true. for debugging
7602       lprn=.false.
7603 c      lprn=.true.
7604       etors=0.0D0
7605       do i=iphi_start,iphi_end
7606       etors_ii=0.0D0
7607         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7608      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7609         itori=itortyp(itype(i-2))
7610         itori1=itortyp(itype(i-1))
7611         phii=phi(i)
7612         gloci=0.0D0
7613 C Proline-Proline pair is a special case...
7614         if (itori.eq.3 .and. itori1.eq.3) then
7615           if (phii.gt.-dwapi3) then
7616             cosphi=dcos(3*phii)
7617             fac=1.0D0/(1.0D0-cosphi)
7618             etorsi=v1(1,3,3)*fac
7619             etorsi=etorsi+etorsi
7620             etors=etors+etorsi-v1(1,3,3)
7621             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7622             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7623           endif
7624           do j=1,3
7625             v1ij=v1(j+1,itori,itori1)
7626             v2ij=v2(j+1,itori,itori1)
7627             cosphi=dcos(j*phii)
7628             sinphi=dsin(j*phii)
7629             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7630             if (energy_dec) etors_ii=etors_ii+
7631      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7632             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7633           enddo
7634         else
7635           do j=1,nterm_old
7636             v1ij=v1(j,itori,itori1)
7637             v2ij=v2(j,itori,itori1)
7638             cosphi=dcos(j*phii)
7639             sinphi=dsin(j*phii)
7640             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7641             if (energy_dec) etors_ii=etors_ii+
7642      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7643             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7644           enddo
7645         endif
7646         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7647              'etor',i,etors_ii
7648         if (lprn)
7649      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7650      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7651      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7652         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7653 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7654       enddo
7655       return
7656       end
7657 c------------------------------------------------------------------------------
7658       subroutine etor_d(etors_d)
7659       etors_d=0.0d0
7660       return
7661       end
7662 c----------------------------------------------------------------------------
7663 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7664       subroutine e_modeller(ehomology_constr)
7665       ehomology_constr=0.0d0
7666       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7667       return
7668       end
7669 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7670
7671 c------------------------------------------------------------------------------
7672       subroutine etor_d(etors_d)
7673       etors_d=0.0d0
7674       return
7675       end
7676 c----------------------------------------------------------------------------
7677 #else
7678       subroutine etor(etors)
7679       implicit real*8 (a-h,o-z)
7680       include 'DIMENSIONS'
7681       include 'COMMON.VAR'
7682       include 'COMMON.GEO'
7683       include 'COMMON.LOCAL'
7684       include 'COMMON.TORSION'
7685       include 'COMMON.INTERACT'
7686       include 'COMMON.DERIV'
7687       include 'COMMON.CHAIN'
7688       include 'COMMON.NAMES'
7689       include 'COMMON.IOUNITS'
7690       include 'COMMON.FFIELD'
7691       include 'COMMON.TORCNSTR'
7692       include 'COMMON.CONTROL'
7693       logical lprn
7694 C Set lprn=.true. for debugging
7695       lprn=.false.
7696 c     lprn=.true.
7697       etors=0.0D0
7698       do i=iphi_start,iphi_end
7699 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7700 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7701 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7702 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7703         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7704      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7705 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7706 C For introducing the NH3+ and COO- group please check the etor_d for reference
7707 C and guidance
7708         etors_ii=0.0D0
7709          if (iabs(itype(i)).eq.20) then
7710          iblock=2
7711          else
7712          iblock=1
7713          endif
7714         itori=itortyp(itype(i-2))
7715         itori1=itortyp(itype(i-1))
7716         phii=phi(i)
7717         gloci=0.0D0
7718 C Regular cosine and sine terms
7719         do j=1,nterm(itori,itori1,iblock)
7720           v1ij=v1(j,itori,itori1,iblock)
7721           v2ij=v2(j,itori,itori1,iblock)
7722           cosphi=dcos(j*phii)
7723           sinphi=dsin(j*phii)
7724           etors=etors+v1ij*cosphi+v2ij*sinphi
7725           if (energy_dec) etors_ii=etors_ii+
7726      &                v1ij*cosphi+v2ij*sinphi
7727           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7728         enddo
7729 C Lorentz terms
7730 C                         v1
7731 C  E = SUM ----------------------------------- - v1
7732 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7733 C
7734         cosphi=dcos(0.5d0*phii)
7735         sinphi=dsin(0.5d0*phii)
7736         do j=1,nlor(itori,itori1,iblock)
7737           vl1ij=vlor1(j,itori,itori1)
7738           vl2ij=vlor2(j,itori,itori1)
7739           vl3ij=vlor3(j,itori,itori1)
7740           pom=vl2ij*cosphi+vl3ij*sinphi
7741           pom1=1.0d0/(pom*pom+1.0d0)
7742           etors=etors+vl1ij*pom1
7743           if (energy_dec) etors_ii=etors_ii+
7744      &                vl1ij*pom1
7745           pom=-pom*pom1*pom1
7746           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7747         enddo
7748 C Subtract the constant term
7749         etors=etors-v0(itori,itori1,iblock)
7750           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7751      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7752         if (lprn)
7753      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7754      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7755      &  (v1(j,itori,itori1,iblock),j=1,6),
7756      &  (v2(j,itori,itori1,iblock),j=1,6)
7757         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7758 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7759       enddo
7760       return
7761       end
7762 c----------------------------------------------------------------------------
7763       subroutine etor_d(etors_d)
7764 C 6/23/01 Compute double torsional energy
7765       implicit real*8 (a-h,o-z)
7766       include 'DIMENSIONS'
7767       include 'COMMON.VAR'
7768       include 'COMMON.GEO'
7769       include 'COMMON.LOCAL'
7770       include 'COMMON.TORSION'
7771       include 'COMMON.INTERACT'
7772       include 'COMMON.DERIV'
7773       include 'COMMON.CHAIN'
7774       include 'COMMON.NAMES'
7775       include 'COMMON.IOUNITS'
7776       include 'COMMON.FFIELD'
7777       include 'COMMON.TORCNSTR'
7778       logical lprn
7779 C Set lprn=.true. for debugging
7780       lprn=.false.
7781 c     lprn=.true.
7782       etors_d=0.0D0
7783 c      write(iout,*) "a tu??"
7784       do i=iphid_start,iphid_end
7785 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7786 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7787 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7788 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7789 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7790          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7791      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7792      &  (itype(i+1).eq.ntyp1)) cycle
7793 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7794         itori=itortyp(itype(i-2))
7795         itori1=itortyp(itype(i-1))
7796         itori2=itortyp(itype(i))
7797         phii=phi(i)
7798         phii1=phi(i+1)
7799         gloci1=0.0D0
7800         gloci2=0.0D0
7801         iblock=1
7802         if (iabs(itype(i+1)).eq.20) iblock=2
7803 C Iblock=2 Proline type
7804 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7805 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7806 C        if (itype(i+1).eq.ntyp1) iblock=3
7807 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7808 C IS or IS NOT need for this
7809 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7810 C        is (itype(i-3).eq.ntyp1) ntblock=2
7811 C        ntblock is N-terminal blocking group
7812
7813 C Regular cosine and sine terms
7814         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7815 C Example of changes for NH3+ blocking group
7816 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7817 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7818           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7819           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7820           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7821           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7822           cosphi1=dcos(j*phii)
7823           sinphi1=dsin(j*phii)
7824           cosphi2=dcos(j*phii1)
7825           sinphi2=dsin(j*phii1)
7826           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7827      &     v2cij*cosphi2+v2sij*sinphi2
7828           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7829           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7830         enddo
7831         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7832           do l=1,k-1
7833             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7834             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7835             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7836             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7837             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7838             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7839             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7840             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7841             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7842      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7843             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7844      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7845             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7846      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7847           enddo
7848         enddo
7849         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7850         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7851       enddo
7852       return
7853       end
7854 #endif
7855 C----------------------------------------------------------------------------------
7856 C The rigorous attempt to derive energy function
7857       subroutine etor_kcc(etors)
7858       implicit real*8 (a-h,o-z)
7859       include 'DIMENSIONS'
7860       include 'COMMON.VAR'
7861       include 'COMMON.GEO'
7862       include 'COMMON.LOCAL'
7863       include 'COMMON.TORSION'
7864       include 'COMMON.INTERACT'
7865       include 'COMMON.DERIV'
7866       include 'COMMON.CHAIN'
7867       include 'COMMON.NAMES'
7868       include 'COMMON.IOUNITS'
7869       include 'COMMON.FFIELD'
7870       include 'COMMON.TORCNSTR'
7871       include 'COMMON.CONTROL'
7872       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7873       logical lprn
7874 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7875 C Set lprn=.true. for debugging
7876       lprn=energy_dec
7877 c     lprn=.true.
7878 C      print *,"wchodze kcc"
7879       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7880       etors=0.0D0
7881       do i=iphi_start,iphi_end
7882 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7883 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7884 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7885 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7886         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7887      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7888         itori=itortyp(itype(i-2))
7889         itori1=itortyp(itype(i-1))
7890         phii=phi(i)
7891         glocig=0.0D0
7892         glocit1=0.0d0
7893         glocit2=0.0d0
7894 C to avoid multiple devision by 2
7895 c        theti22=0.5d0*theta(i)
7896 C theta 12 is the theta_1 /2
7897 C theta 22 is theta_2 /2
7898 c        theti12=0.5d0*theta(i-1)
7899 C and appropriate sinus function
7900         sinthet1=dsin(theta(i-1))
7901         sinthet2=dsin(theta(i))
7902         costhet1=dcos(theta(i-1))
7903         costhet2=dcos(theta(i))
7904 C to speed up lets store its mutliplication
7905         sint1t2=sinthet2*sinthet1
7906         sint1t2n=1.0d0
7907 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7908 C +d_n*sin(n*gamma)) *
7909 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7910 C we have two sum 1) Non-Chebyshev which is with n and gamma
7911         nval=nterm_kcc_Tb(itori,itori1)
7912         c1(0)=0.0d0
7913         c2(0)=0.0d0
7914         c1(1)=1.0d0
7915         c2(1)=1.0d0
7916         do j=2,nval
7917           c1(j)=c1(j-1)*costhet1
7918           c2(j)=c2(j-1)*costhet2
7919         enddo
7920         etori=0.0d0
7921         do j=1,nterm_kcc(itori,itori1)
7922           cosphi=dcos(j*phii)
7923           sinphi=dsin(j*phii)
7924           sint1t2n1=sint1t2n
7925           sint1t2n=sint1t2n*sint1t2
7926           sumvalc=0.0d0
7927           gradvalct1=0.0d0
7928           gradvalct2=0.0d0
7929           do k=1,nval
7930             do l=1,nval
7931               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7932               gradvalct1=gradvalct1+
7933      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7934               gradvalct2=gradvalct2+
7935      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7936             enddo
7937           enddo
7938           gradvalct1=-gradvalct1*sinthet1
7939           gradvalct2=-gradvalct2*sinthet2
7940           sumvals=0.0d0
7941           gradvalst1=0.0d0
7942           gradvalst2=0.0d0
7943           do k=1,nval
7944             do l=1,nval
7945               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7946               gradvalst1=gradvalst1+
7947      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7948               gradvalst2=gradvalst2+
7949      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7950             enddo
7951           enddo
7952           gradvalst1=-gradvalst1*sinthet1
7953           gradvalst2=-gradvalst2*sinthet2
7954           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7955           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7956 C glocig is the gradient local i site in gamma
7957           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7958 C now gradient over theta_1
7959           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7960      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7961           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7962      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7963         enddo ! j
7964         etors=etors+etori
7965 C derivative over gamma
7966         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7967 C derivative over theta1
7968         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7969 C now derivative over theta2
7970         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7971         if (lprn) then
7972           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7973      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7974           write (iout,*) "c1",(c1(k),k=0,nval),
7975      &    " c2",(c2(k),k=0,nval)
7976         endif
7977       enddo
7978       return
7979       end
7980 c---------------------------------------------------------------------------------------------
7981       subroutine etor_constr(edihcnstr)
7982       implicit real*8 (a-h,o-z)
7983       include 'DIMENSIONS'
7984       include 'COMMON.VAR'
7985       include 'COMMON.GEO'
7986       include 'COMMON.LOCAL'
7987       include 'COMMON.TORSION'
7988       include 'COMMON.INTERACT'
7989       include 'COMMON.DERIV'
7990       include 'COMMON.CHAIN'
7991       include 'COMMON.NAMES'
7992       include 'COMMON.IOUNITS'
7993       include 'COMMON.FFIELD'
7994       include 'COMMON.TORCNSTR'
7995       include 'COMMON.BOUNDS'
7996       include 'COMMON.CONTROL'
7997 ! 6/20/98 - dihedral angle constraints
7998       edihcnstr=0.0d0
7999 c      do i=1,ndih_constr
8000       if (raw_psipred) then
8001         do i=idihconstr_start,idihconstr_end
8002           itori=idih_constr(i)
8003           phii=phi(itori)
8004           gaudih_i=vpsipred(1,i)
8005           gauder_i=0.0d0
8006           do j=1,2
8007             s = sdihed(j,i)
8008             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
8009             dexpcos_i=dexp(-cos_i*cos_i)
8010             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
8011             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
8012      &            *cos_i*dexpcos_i/s**2
8013           enddo
8014           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
8015           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
8016           if (energy_dec)
8017      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
8018      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
8019      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
8020      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
8021      &     -wdihc*dlog(gaudih_i)
8022         enddo
8023       else
8024
8025       do i=idihconstr_start,idihconstr_end
8026         itori=idih_constr(i)
8027         phii=phi(itori)
8028         difi=pinorm(phii-phi0(i))
8029         if (difi.gt.drange(i)) then
8030           difi=difi-drange(i)
8031           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8032           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8033         else if (difi.lt.-drange(i)) then
8034           difi=difi+drange(i)
8035           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8036           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8037         else
8038           difi=0.0
8039         endif
8040       enddo
8041
8042       endif
8043
8044       return
8045       end
8046 c----------------------------------------------------------------------------
8047 c MODELLER restraint function
8048       subroutine e_modeller(ehomology_constr)
8049       implicit none
8050       include 'DIMENSIONS'
8051
8052       double precision ehomology_constr
8053       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8054       integer katy, odleglosci, test7
8055       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8056       real*8 Eval,Erot
8057       real*8 distance(max_template),distancek(max_template),
8058      &    min_odl,godl(max_template),dih_diff(max_template)
8059
8060 c
8061 c     FP - 30/10/2014 Temporary specifications for homology restraints
8062 c
8063       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8064      &                 sgtheta
8065       double precision, dimension (maxres) :: guscdiff,usc_diff
8066       double precision, dimension (max_template) ::
8067      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8068      &           theta_diff
8069       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8070      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8071      & betai,sum_sgodl,dij
8072       double precision dist,pinorm
8073 c
8074       include 'COMMON.SBRIDGE'
8075       include 'COMMON.CHAIN'
8076       include 'COMMON.GEO'
8077       include 'COMMON.DERIV'
8078       include 'COMMON.LOCAL'
8079       include 'COMMON.INTERACT'
8080       include 'COMMON.VAR'
8081       include 'COMMON.IOUNITS'
8082 c      include 'COMMON.MD'
8083       include 'COMMON.CONTROL'
8084       include 'COMMON.HOMOLOGY'
8085       include 'COMMON.QRESTR'
8086 c
8087 c     From subroutine Econstr_back
8088 c
8089       include 'COMMON.NAMES'
8090       include 'COMMON.TIME1'
8091 c
8092
8093
8094       do i=1,max_template
8095         distancek(i)=9999999.9
8096       enddo
8097
8098
8099       odleg=0.0d0
8100
8101 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8102 c function)
8103 C AL 5/2/14 - Introduce list of restraints
8104 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8105 #ifdef DEBUG
8106       write(iout,*) "------- dist restrs start -------"
8107 #endif
8108       do ii = link_start_homo,link_end_homo
8109          i = ires_homo(ii)
8110          j = jres_homo(ii)
8111          dij=dist(i,j)
8112 c        write (iout,*) "dij(",i,j,") =",dij
8113          nexl=0
8114          do k=1,constr_homology
8115 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8116            if(.not.l_homo(k,ii)) then
8117              nexl=nexl+1
8118              cycle
8119            endif
8120            distance(k)=odl(k,ii)-dij
8121 c          write (iout,*) "distance(",k,") =",distance(k)
8122 c
8123 c          For Gaussian-type Urestr
8124 c
8125            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8126 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8127 c          write (iout,*) "distancek(",k,") =",distancek(k)
8128 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8129 c
8130 c          For Lorentzian-type Urestr
8131 c
8132            if (waga_dist.lt.0.0d0) then
8133               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8134               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8135      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8136            endif
8137          enddo
8138
8139 c         min_odl=minval(distancek)
8140          do kk=1,constr_homology
8141           if(l_homo(kk,ii)) then
8142             min_odl=distancek(kk)
8143             exit
8144           endif
8145          enddo
8146          do kk=1,constr_homology
8147           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8148      &              min_odl=distancek(kk)
8149          enddo
8150
8151 c        write (iout,* )"min_odl",min_odl
8152 #ifdef DEBUG
8153          write (iout,*) "ij dij",i,j,dij
8154          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8155          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8156          write (iout,* )"min_odl",min_odl
8157 #endif
8158 #ifdef OLDRESTR
8159          odleg2=0.0d0
8160 #else
8161          if (waga_dist.ge.0.0d0) then
8162            odleg2=nexl
8163          else
8164            odleg2=0.0d0
8165          endif
8166 #endif
8167          do k=1,constr_homology
8168 c Nie wiem po co to liczycie jeszcze raz!
8169 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8170 c     &              (2*(sigma_odl(i,j,k))**2))
8171            if(.not.l_homo(k,ii)) cycle
8172            if (waga_dist.ge.0.0d0) then
8173 c
8174 c          For Gaussian-type Urestr
8175 c
8176             godl(k)=dexp(-distancek(k)+min_odl)
8177             odleg2=odleg2+godl(k)
8178 c
8179 c          For Lorentzian-type Urestr
8180 c
8181            else
8182             odleg2=odleg2+distancek(k)
8183            endif
8184
8185 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8186 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8187 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8188 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8189
8190          enddo
8191 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8192 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8193 #ifdef DEBUG
8194          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8195          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8196 #endif
8197            if (waga_dist.ge.0.0d0) then
8198 c
8199 c          For Gaussian-type Urestr
8200 c
8201               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8202 c
8203 c          For Lorentzian-type Urestr
8204 c
8205            else
8206               odleg=odleg+odleg2/constr_homology
8207            endif
8208 c
8209 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8210 c Gradient
8211 c
8212 c          For Gaussian-type Urestr
8213 c
8214          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8215          sum_sgodl=0.0d0
8216          do k=1,constr_homology
8217 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8218 c     &           *waga_dist)+min_odl
8219 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8220 c
8221          if(.not.l_homo(k,ii)) cycle
8222          if (waga_dist.ge.0.0d0) then
8223 c          For Gaussian-type Urestr
8224 c
8225            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8226 c
8227 c          For Lorentzian-type Urestr
8228 c
8229          else
8230            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8231      &           sigma_odlir(k,ii)**2)**2)
8232          endif
8233            sum_sgodl=sum_sgodl+sgodl
8234
8235 c            sgodl2=sgodl2+sgodl
8236 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8237 c      write(iout,*) "constr_homology=",constr_homology
8238 c      write(iout,*) i, j, k, "TEST K"
8239          enddo
8240          if (waga_dist.ge.0.0d0) then
8241 c
8242 c          For Gaussian-type Urestr
8243 c
8244             grad_odl3=waga_homology(iset)*waga_dist
8245      &                *sum_sgodl/(sum_godl*dij)
8246 c
8247 c          For Lorentzian-type Urestr
8248 c
8249          else
8250 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8251 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8252             grad_odl3=-waga_homology(iset)*waga_dist*
8253      &                sum_sgodl/(constr_homology*dij)
8254          endif
8255 c
8256 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8257
8258
8259 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8260 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8261 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8262
8263 ccc      write(iout,*) godl, sgodl, grad_odl3
8264
8265 c          grad_odl=grad_odl+grad_odl3
8266
8267          do jik=1,3
8268             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8269 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8270 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8271 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8272             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8273             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8274 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8275 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8276 c         if (i.eq.25.and.j.eq.27) then
8277 c         write(iout,*) "jik",jik,"i",i,"j",j
8278 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8279 c         write(iout,*) "grad_odl3",grad_odl3
8280 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8281 c         write(iout,*) "ggodl",ggodl
8282 c         write(iout,*) "ghpbc(",jik,i,")",
8283 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8284 c     &                 ghpbc(jik,j)
8285 c         endif
8286          enddo
8287 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8288 ccc     & dLOG(odleg2),"-odleg=", -odleg
8289
8290       enddo ! ii-loop for dist
8291 #ifdef DEBUG
8292       write(iout,*) "------- dist restrs end -------"
8293 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8294 c    &     waga_d.eq.1.0d0) call sum_gradient
8295 #endif
8296 c Pseudo-energy and gradient from dihedral-angle restraints from
8297 c homology templates
8298 c      write (iout,*) "End of distance loop"
8299 c      call flush(iout)
8300       kat=0.0d0
8301 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8302 #ifdef DEBUG
8303       write(iout,*) "------- dih restrs start -------"
8304       do i=idihconstr_start_homo,idihconstr_end_homo
8305         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8306       enddo
8307 #endif
8308       do i=idihconstr_start_homo,idihconstr_end_homo
8309         kat2=0.0d0
8310 c        betai=beta(i,i+1,i+2,i+3)
8311         betai = phi(i)
8312 c       write (iout,*) "betai =",betai
8313         do k=1,constr_homology
8314           dih_diff(k)=pinorm(dih(k,i)-betai)
8315 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8316 cd     &                  ,sigma_dih(k,i)
8317 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8318 c     &                                   -(6.28318-dih_diff(i,k))
8319 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8320 c     &                                   6.28318+dih_diff(i,k)
8321 #ifdef OLD_DIHED
8322           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8323 #else
8324           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8325 #endif
8326 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8327           gdih(k)=dexp(kat3)
8328           kat2=kat2+gdih(k)
8329 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8330 c          write(*,*)""
8331         enddo
8332 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8333 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8334 #ifdef DEBUG
8335         write (iout,*) "i",i," betai",betai," kat2",kat2
8336         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8337 #endif
8338         if (kat2.le.1.0d-14) cycle
8339         kat=kat-dLOG(kat2/constr_homology)
8340 c       write (iout,*) "kat",kat ! sum of -ln-s
8341
8342 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8343 ccc     & dLOG(kat2), "-kat=", -kat
8344
8345 c ----------------------------------------------------------------------
8346 c Gradient
8347 c ----------------------------------------------------------------------
8348
8349         sum_gdih=kat2
8350         sum_sgdih=0.0d0
8351         do k=1,constr_homology
8352 #ifdef OLD_DIHED
8353           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8354 #else
8355           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8356 #endif
8357 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8358           sum_sgdih=sum_sgdih+sgdih
8359         enddo
8360 c       grad_dih3=sum_sgdih/sum_gdih
8361         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8362
8363 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8364 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8365 ccc     & gloc(nphi+i-3,icg)
8366         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8367 c        if (i.eq.25) then
8368 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8369 c        endif
8370 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8371 ccc     & gloc(nphi+i-3,icg)
8372
8373       enddo ! i-loop for dih
8374 #ifdef DEBUG
8375       write(iout,*) "------- dih restrs end -------"
8376 #endif
8377
8378 c Pseudo-energy and gradient for theta angle restraints from
8379 c homology templates
8380 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8381 c adapted
8382
8383 c
8384 c     For constr_homology reference structures (FP)
8385 c
8386 c     Uconst_back_tot=0.0d0
8387       Eval=0.0d0
8388       Erot=0.0d0
8389 c     Econstr_back legacy
8390       do i=1,nres
8391 c     do i=ithet_start,ithet_end
8392        dutheta(i)=0.0d0
8393 c     enddo
8394 c     do i=loc_start,loc_end
8395         do j=1,3
8396           duscdiff(j,i)=0.0d0
8397           duscdiffx(j,i)=0.0d0
8398         enddo
8399       enddo
8400 c
8401 c     do iref=1,nref
8402 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8403 c     write (iout,*) "waga_theta",waga_theta
8404       if (waga_theta.gt.0.0d0) then
8405 #ifdef DEBUG
8406       write (iout,*) "usampl",usampl
8407       write(iout,*) "------- theta restrs start -------"
8408 c     do i=ithet_start,ithet_end
8409 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8410 c     enddo
8411 #endif
8412 c     write (iout,*) "maxres",maxres,"nres",nres
8413
8414       do i=ithet_start,ithet_end
8415 c
8416 c     do i=1,nfrag_back
8417 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8418 c
8419 c Deviation of theta angles wrt constr_homology ref structures
8420 c
8421         utheta_i=0.0d0 ! argument of Gaussian for single k
8422         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8423 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8424 c       over residues in a fragment
8425 c       write (iout,*) "theta(",i,")=",theta(i)
8426         do k=1,constr_homology
8427 c
8428 c         dtheta_i=theta(j)-thetaref(j,iref)
8429 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8430           theta_diff(k)=thetatpl(k,i)-theta(i)
8431 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8432 cd     &                  ,sigma_theta(k,i)
8433
8434 c
8435           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8436 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8437           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8438           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8439 c         Gradient for single Gaussian restraint in subr Econstr_back
8440 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8441 c
8442         enddo
8443 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8444 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8445
8446 c
8447 c         Gradient for multiple Gaussian restraint
8448         sum_gtheta=gutheta_i
8449         sum_sgtheta=0.0d0
8450         do k=1,constr_homology
8451 c        New generalized expr for multiple Gaussian from Econstr_back
8452          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8453 c
8454 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8455           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8456         enddo
8457 c       Final value of gradient using same var as in Econstr_back
8458         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8459      &      +sum_sgtheta/sum_gtheta*waga_theta
8460      &               *waga_homology(iset)
8461 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8462 c     &               *waga_homology(iset)
8463 c       dutheta(i)=sum_sgtheta/sum_gtheta
8464 c
8465 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8466         Eval=Eval-dLOG(gutheta_i/constr_homology)
8467 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8468 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8469 c       Uconst_back=Uconst_back+utheta(i)
8470       enddo ! (i-loop for theta)
8471 #ifdef DEBUG
8472       write(iout,*) "------- theta restrs end -------"
8473 #endif
8474       endif
8475 c
8476 c Deviation of local SC geometry
8477 c
8478 c Separation of two i-loops (instructed by AL - 11/3/2014)
8479 c
8480 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8481 c     write (iout,*) "waga_d",waga_d
8482
8483 #ifdef DEBUG
8484       write(iout,*) "------- SC restrs start -------"
8485       write (iout,*) "Initial duscdiff,duscdiffx"
8486       do i=loc_start,loc_end
8487         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8488      &                 (duscdiffx(jik,i),jik=1,3)
8489       enddo
8490 #endif
8491       do i=loc_start,loc_end
8492         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8493         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8494 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8495 c       write(iout,*) "xxtab, yytab, zztab"
8496 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8497         do k=1,constr_homology
8498 c
8499           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8500 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8501           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8502           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8503 c         write(iout,*) "dxx, dyy, dzz"
8504 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8505 c
8506           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8507 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8508 c         uscdiffk(k)=usc_diff(i)
8509           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8510 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8511 c     &       " guscdiff2",guscdiff2(k)
8512           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8513 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8514 c     &      xxref(j),yyref(j),zzref(j)
8515         enddo
8516 c
8517 c       Gradient
8518 c
8519 c       Generalized expression for multiple Gaussian acc to that for a single
8520 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8521 c
8522 c       Original implementation
8523 c       sum_guscdiff=guscdiff(i)
8524 c
8525 c       sum_sguscdiff=0.0d0
8526 c       do k=1,constr_homology
8527 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8528 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8529 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8530 c       enddo
8531 c
8532 c       Implementation of new expressions for gradient (Jan. 2015)
8533 c
8534 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8535         do k=1,constr_homology
8536 c
8537 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8538 c       before. Now the drivatives should be correct
8539 c
8540           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8541 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8542           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8543           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8544 c
8545 c         New implementation
8546 c
8547           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8548      &                 sigma_d(k,i) ! for the grad wrt r'
8549 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8550 c
8551 c
8552 c        New implementation
8553          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8554          do jik=1,3
8555             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8556      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8557      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8558             duscdiff(jik,i)=duscdiff(jik,i)+
8559      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8560      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8561             duscdiffx(jik,i)=duscdiffx(jik,i)+
8562      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8563      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8564 c
8565 #ifdef DEBUG
8566              write(iout,*) "jik",jik,"i",i
8567              write(iout,*) "dxx, dyy, dzz"
8568              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8569              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8570 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8571 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8572 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8573 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8574 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8575 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8576 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8577 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8578 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8579 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8580 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8581 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8582 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8583 c            endif
8584 #endif
8585          enddo
8586         enddo
8587 c
8588 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8589 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8590 c
8591 c        write (iout,*) i," uscdiff",uscdiff(i)
8592 c
8593 c Put together deviations from local geometry
8594
8595 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8596 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8597         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8598 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8599 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8600 c       Uconst_back=Uconst_back+usc_diff(i)
8601 c
8602 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8603 c
8604 c     New implment: multiplied by sum_sguscdiff
8605 c
8606
8607       enddo ! (i-loop for dscdiff)
8608
8609 c      endif
8610
8611 #ifdef DEBUG
8612       write(iout,*) "------- SC restrs end -------"
8613         write (iout,*) "------ After SC loop in e_modeller ------"
8614         do i=loc_start,loc_end
8615          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8616          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8617         enddo
8618       if (waga_theta.eq.1.0d0) then
8619       write (iout,*) "in e_modeller after SC restr end: dutheta"
8620       do i=ithet_start,ithet_end
8621         write (iout,*) i,dutheta(i)
8622       enddo
8623       endif
8624       if (waga_d.eq.1.0d0) then
8625       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8626       do i=1,nres
8627         write (iout,*) i,(duscdiff(j,i),j=1,3)
8628         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8629       enddo
8630       endif
8631 #endif
8632
8633 c Total energy from homology restraints
8634 #ifdef DEBUG
8635       write (iout,*) "odleg",odleg," kat",kat
8636 #endif
8637 c
8638 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8639 c
8640 c     ehomology_constr=odleg+kat
8641 c
8642 c     For Lorentzian-type Urestr
8643 c
8644
8645       if (waga_dist.ge.0.0d0) then
8646 c
8647 c          For Gaussian-type Urestr
8648 c
8649         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8650      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8651 c     write (iout,*) "ehomology_constr=",ehomology_constr
8652       else
8653 c
8654 c          For Lorentzian-type Urestr
8655 c
8656         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8657      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8658 c     write (iout,*) "ehomology_constr=",ehomology_constr
8659       endif
8660 #ifdef DEBUG
8661       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8662      & "Eval",waga_theta,eval,
8663      &   "Erot",waga_d,Erot
8664       write (iout,*) "ehomology_constr",ehomology_constr
8665 #endif
8666       return
8667 c
8668 c FP 01/15 end
8669 c
8670   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8671   747 format(a12,i4,i4,i4,f8.3,f8.3)
8672   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8673   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8674   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8675      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8676       end
8677 c----------------------------------------------------------------------------
8678 C The rigorous attempt to derive energy function
8679       subroutine ebend_kcc(etheta)
8680
8681       implicit real*8 (a-h,o-z)
8682       include 'DIMENSIONS'
8683       include 'COMMON.VAR'
8684       include 'COMMON.GEO'
8685       include 'COMMON.LOCAL'
8686       include 'COMMON.TORSION'
8687       include 'COMMON.INTERACT'
8688       include 'COMMON.DERIV'
8689       include 'COMMON.CHAIN'
8690       include 'COMMON.NAMES'
8691       include 'COMMON.IOUNITS'
8692       include 'COMMON.FFIELD'
8693       include 'COMMON.TORCNSTR'
8694       include 'COMMON.CONTROL'
8695       logical lprn
8696       double precision thybt1(maxang_kcc)
8697 C Set lprn=.true. for debugging
8698       lprn=energy_dec
8699 c     lprn=.true.
8700 C      print *,"wchodze kcc"
8701       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8702       etheta=0.0D0
8703       do i=ithet_start,ithet_end
8704 c        print *,i,itype(i-1),itype(i),itype(i-2)
8705         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8706      &  .or.itype(i).eq.ntyp1) cycle
8707         iti=iabs(itortyp(itype(i-1)))
8708         sinthet=dsin(theta(i))
8709         costhet=dcos(theta(i))
8710         do j=1,nbend_kcc_Tb(iti)
8711           thybt1(j)=v1bend_chyb(j,iti)
8712         enddo
8713         sumth1thyb=v1bend_chyb(0,iti)+
8714      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8715         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8716      &    sumth1thyb
8717         ihelp=nbend_kcc_Tb(iti)-1
8718         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8719         etheta=etheta+sumth1thyb
8720 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8721         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8722       enddo
8723       return
8724       end
8725 c-------------------------------------------------------------------------------------
8726       subroutine etheta_constr(ethetacnstr)
8727
8728       implicit real*8 (a-h,o-z)
8729       include 'DIMENSIONS'
8730       include 'COMMON.VAR'
8731       include 'COMMON.GEO'
8732       include 'COMMON.LOCAL'
8733       include 'COMMON.TORSION'
8734       include 'COMMON.INTERACT'
8735       include 'COMMON.DERIV'
8736       include 'COMMON.CHAIN'
8737       include 'COMMON.NAMES'
8738       include 'COMMON.IOUNITS'
8739       include 'COMMON.FFIELD'
8740       include 'COMMON.TORCNSTR'
8741       include 'COMMON.CONTROL'
8742       ethetacnstr=0.0d0
8743 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8744       do i=ithetaconstr_start,ithetaconstr_end
8745         itheta=itheta_constr(i)
8746         thetiii=theta(itheta)
8747         difi=pinorm(thetiii-theta_constr0(i))
8748         if (difi.gt.theta_drange(i)) then
8749           difi=difi-theta_drange(i)
8750           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8751           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8752      &    +for_thet_constr(i)*difi**3
8753         else if (difi.lt.-drange(i)) then
8754           difi=difi+drange(i)
8755           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8756           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8757      &    +for_thet_constr(i)*difi**3
8758         else
8759           difi=0.0
8760         endif
8761        if (energy_dec) then
8762         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8763      &    i,itheta,rad2deg*thetiii,
8764      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8765      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8766      &    gloc(itheta+nphi-2,icg)
8767         endif
8768       enddo
8769       return
8770       end
8771 c------------------------------------------------------------------------------
8772       subroutine eback_sc_corr(esccor)
8773 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8774 c        conformational states; temporarily implemented as differences
8775 c        between UNRES torsional potentials (dependent on three types of
8776 c        residues) and the torsional potentials dependent on all 20 types
8777 c        of residues computed from AM1  energy surfaces of terminally-blocked
8778 c        amino-acid residues.
8779       implicit real*8 (a-h,o-z)
8780       include 'DIMENSIONS'
8781       include 'COMMON.VAR'
8782       include 'COMMON.GEO'
8783       include 'COMMON.LOCAL'
8784       include 'COMMON.TORSION'
8785       include 'COMMON.SCCOR'
8786       include 'COMMON.INTERACT'
8787       include 'COMMON.DERIV'
8788       include 'COMMON.CHAIN'
8789       include 'COMMON.NAMES'
8790       include 'COMMON.IOUNITS'
8791       include 'COMMON.FFIELD'
8792       include 'COMMON.CONTROL'
8793       logical lprn
8794 C Set lprn=.true. for debugging
8795       lprn=.false.
8796 c      lprn=.true.
8797 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8798       esccor=0.0D0
8799       do i=itau_start,itau_end
8800         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8801         esccor_ii=0.0D0
8802         isccori=isccortyp(itype(i-2))
8803         isccori1=isccortyp(itype(i-1))
8804 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8805         phii=phi(i)
8806         do intertyp=1,3 !intertyp
8807 cc Added 09 May 2012 (Adasko)
8808 cc  Intertyp means interaction type of backbone mainchain correlation:
8809 c   1 = SC...Ca...Ca...Ca
8810 c   2 = Ca...Ca...Ca...SC
8811 c   3 = SC...Ca...Ca...SCi
8812         gloci=0.0D0
8813         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8814      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8815      &      (itype(i-1).eq.ntyp1)))
8816      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8817      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8818      &     .or.(itype(i).eq.ntyp1)))
8819      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8820      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8821      &      (itype(i-3).eq.ntyp1)))) cycle
8822         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8823         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8824      & cycle
8825        do j=1,nterm_sccor(isccori,isccori1)
8826           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8827           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8828           cosphi=dcos(j*tauangle(intertyp,i))
8829           sinphi=dsin(j*tauangle(intertyp,i))
8830           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8831           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8832         enddo
8833 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8834         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8835         if (lprn)
8836      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8837      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8838      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8839      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8840         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8841        enddo !intertyp
8842       enddo
8843
8844       return
8845       end
8846 #ifdef FOURBODY
8847 c----------------------------------------------------------------------------
8848       subroutine multibody(ecorr)
8849 C This subroutine calculates multi-body contributions to energy following
8850 C the idea of Skolnick et al. If side chains I and J make a contact and
8851 C at the same time side chains I+1 and J+1 make a contact, an extra
8852 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8853       implicit real*8 (a-h,o-z)
8854       include 'DIMENSIONS'
8855       include 'COMMON.IOUNITS'
8856       include 'COMMON.DERIV'
8857       include 'COMMON.INTERACT'
8858       include 'COMMON.CONTACTS'
8859       include 'COMMON.CONTMAT'
8860       include 'COMMON.CORRMAT'
8861       double precision gx(3),gx1(3)
8862       logical lprn
8863
8864 C Set lprn=.true. for debugging
8865       lprn=.false.
8866
8867       if (lprn) then
8868         write (iout,'(a)') 'Contact function values:'
8869         do i=nnt,nct-2
8870           write (iout,'(i2,20(1x,i2,f10.5))')
8871      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8872         enddo
8873       endif
8874       ecorr=0.0D0
8875       do i=nnt,nct
8876         do j=1,3
8877           gradcorr(j,i)=0.0D0
8878           gradxorr(j,i)=0.0D0
8879         enddo
8880       enddo
8881       do i=nnt,nct-2
8882
8883         DO ISHIFT = 3,4
8884
8885         i1=i+ishift
8886         num_conti=num_cont(i)
8887         num_conti1=num_cont(i1)
8888         do jj=1,num_conti
8889           j=jcont(jj,i)
8890           do kk=1,num_conti1
8891             j1=jcont(kk,i1)
8892             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8893 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8894 cd   &                   ' ishift=',ishift
8895 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8896 C The system gains extra energy.
8897               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8898             endif   ! j1==j+-ishift
8899           enddo     ! kk
8900         enddo       ! jj
8901
8902         ENDDO ! ISHIFT
8903
8904       enddo         ! i
8905       return
8906       end
8907 c------------------------------------------------------------------------------
8908       double precision function esccorr(i,j,k,l,jj,kk)
8909       implicit real*8 (a-h,o-z)
8910       include 'DIMENSIONS'
8911       include 'COMMON.IOUNITS'
8912       include 'COMMON.DERIV'
8913       include 'COMMON.INTERACT'
8914       include 'COMMON.CONTACTS'
8915       include 'COMMON.CONTMAT'
8916       include 'COMMON.CORRMAT'
8917       include 'COMMON.SHIELD'
8918       double precision gx(3),gx1(3)
8919       logical lprn
8920       lprn=.false.
8921       eij=facont(jj,i)
8922       ekl=facont(kk,k)
8923 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8924 C Calculate the multi-body contribution to energy.
8925 C Calculate multi-body contributions to the gradient.
8926 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8927 cd   & k,l,(gacont(m,kk,k),m=1,3)
8928       do m=1,3
8929         gx(m) =ekl*gacont(m,jj,i)
8930         gx1(m)=eij*gacont(m,kk,k)
8931         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8932         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8933         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8934         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8935       enddo
8936       do m=i,j-1
8937         do ll=1,3
8938           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8939         enddo
8940       enddo
8941       do m=k,l-1
8942         do ll=1,3
8943           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8944         enddo
8945       enddo
8946       esccorr=-eij*ekl
8947       return
8948       end
8949 c------------------------------------------------------------------------------
8950       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8951 C This subroutine calculates multi-body contributions to hydrogen-bonding
8952       implicit real*8 (a-h,o-z)
8953       include 'DIMENSIONS'
8954       include 'COMMON.IOUNITS'
8955 #ifdef MPI
8956       include "mpif.h"
8957       parameter (max_cont=maxconts)
8958       parameter (max_dim=26)
8959       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8960       double precision zapas(max_dim,maxconts,max_fg_procs),
8961      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8962       common /przechowalnia/ zapas
8963       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8964      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8965 #endif
8966       include 'COMMON.SETUP'
8967       include 'COMMON.FFIELD'
8968       include 'COMMON.DERIV'
8969       include 'COMMON.INTERACT'
8970       include 'COMMON.CONTACTS'
8971       include 'COMMON.CONTMAT'
8972       include 'COMMON.CORRMAT'
8973       include 'COMMON.CONTROL'
8974       include 'COMMON.LOCAL'
8975       double precision gx(3),gx1(3),time00
8976       logical lprn,ldone
8977
8978 C Set lprn=.true. for debugging
8979       lprn=.false.
8980 #ifdef MPI
8981       n_corr=0
8982       n_corr1=0
8983       if (nfgtasks.le.1) goto 30
8984       if (lprn) then
8985         write (iout,'(a)') 'Contact function values before RECEIVE:'
8986         do i=nnt,nct-2
8987           write (iout,'(2i3,50(1x,i2,f5.2))')
8988      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8989      &    j=1,num_cont_hb(i))
8990         enddo
8991         call flush(iout)
8992       endif
8993       do i=1,ntask_cont_from
8994         ncont_recv(i)=0
8995       enddo
8996       do i=1,ntask_cont_to
8997         ncont_sent(i)=0
8998       enddo
8999 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9000 c     & ntask_cont_to
9001 C Make the list of contacts to send to send to other procesors
9002 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
9003 c      call flush(iout)
9004       do i=iturn3_start,iturn3_end
9005 c        write (iout,*) "make contact list turn3",i," num_cont",
9006 c     &    num_cont_hb(i)
9007         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
9008       enddo
9009       do i=iturn4_start,iturn4_end
9010 c        write (iout,*) "make contact list turn4",i," num_cont",
9011 c     &   num_cont_hb(i)
9012         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
9013       enddo
9014       do ii=1,nat_sent
9015         i=iat_sent(ii)
9016 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9017 c     &    num_cont_hb(i)
9018         do j=1,num_cont_hb(i)
9019         do k=1,4
9020           jjc=jcont_hb(j,i)
9021           iproc=iint_sent_local(k,jjc,ii)
9022 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9023           if (iproc.gt.0) then
9024             ncont_sent(iproc)=ncont_sent(iproc)+1
9025             nn=ncont_sent(iproc)
9026             zapas(1,nn,iproc)=i
9027             zapas(2,nn,iproc)=jjc
9028             zapas(3,nn,iproc)=facont_hb(j,i)
9029             zapas(4,nn,iproc)=ees0p(j,i)
9030             zapas(5,nn,iproc)=ees0m(j,i)
9031             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
9032             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
9033             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
9034             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
9035             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
9036             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
9037             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
9038             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
9039             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
9040             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
9041             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
9042             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
9043             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
9044             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
9045             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
9046             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
9047             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
9048             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
9049             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
9050             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
9051             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
9052           endif
9053         enddo
9054         enddo
9055       enddo
9056       if (lprn) then
9057       write (iout,*)
9058      &  "Numbers of contacts to be sent to other processors",
9059      &  (ncont_sent(i),i=1,ntask_cont_to)
9060       write (iout,*) "Contacts sent"
9061       do ii=1,ntask_cont_to
9062         nn=ncont_sent(ii)
9063         iproc=itask_cont_to(ii)
9064         write (iout,*) nn," contacts to processor",iproc,
9065      &   " of CONT_TO_COMM group"
9066         do i=1,nn
9067           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9068         enddo
9069       enddo
9070       call flush(iout)
9071       endif
9072       CorrelType=477
9073       CorrelID=fg_rank+1
9074       CorrelType1=478
9075       CorrelID1=nfgtasks+fg_rank+1
9076       ireq=0
9077 C Receive the numbers of needed contacts from other processors
9078       do ii=1,ntask_cont_from
9079         iproc=itask_cont_from(ii)
9080         ireq=ireq+1
9081         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9082      &    FG_COMM,req(ireq),IERR)
9083       enddo
9084 c      write (iout,*) "IRECV ended"
9085 c      call flush(iout)
9086 C Send the number of contacts needed by other processors
9087       do ii=1,ntask_cont_to
9088         iproc=itask_cont_to(ii)
9089         ireq=ireq+1
9090         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9091      &    FG_COMM,req(ireq),IERR)
9092       enddo
9093 c      write (iout,*) "ISEND ended"
9094 c      write (iout,*) "number of requests (nn)",ireq
9095 c      call flush(iout)
9096       if (ireq.gt.0)
9097      &  call MPI_Waitall(ireq,req,status_array,ierr)
9098 c      write (iout,*)
9099 c     &  "Numbers of contacts to be received from other processors",
9100 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9101 c      call flush(iout)
9102 C Receive contacts
9103       ireq=0
9104       do ii=1,ntask_cont_from
9105         iproc=itask_cont_from(ii)
9106         nn=ncont_recv(ii)
9107 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9108 c     &   " of CONT_TO_COMM group"
9109 c        call flush(iout)
9110         if (nn.gt.0) then
9111           ireq=ireq+1
9112           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9113      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9114 c          write (iout,*) "ireq,req",ireq,req(ireq)
9115         endif
9116       enddo
9117 C Send the contacts to processors that need them
9118       do ii=1,ntask_cont_to
9119         iproc=itask_cont_to(ii)
9120         nn=ncont_sent(ii)
9121 c        write (iout,*) nn," contacts to processor",iproc,
9122 c     &   " of CONT_TO_COMM group"
9123         if (nn.gt.0) then
9124           ireq=ireq+1
9125           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9126      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9127 c          write (iout,*) "ireq,req",ireq,req(ireq)
9128 c          do i=1,nn
9129 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9130 c          enddo
9131         endif
9132       enddo
9133 c      write (iout,*) "number of requests (contacts)",ireq
9134 c      write (iout,*) "req",(req(i),i=1,4)
9135 c      call flush(iout)
9136       if (ireq.gt.0)
9137      & call MPI_Waitall(ireq,req,status_array,ierr)
9138       do iii=1,ntask_cont_from
9139         iproc=itask_cont_from(iii)
9140         nn=ncont_recv(iii)
9141         if (lprn) then
9142         write (iout,*) "Received",nn," contacts from processor",iproc,
9143      &   " of CONT_FROM_COMM group"
9144         call flush(iout)
9145         do i=1,nn
9146           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9147         enddo
9148         call flush(iout)
9149         endif
9150         do i=1,nn
9151           ii=zapas_recv(1,i,iii)
9152 c Flag the received contacts to prevent double-counting
9153           jj=-zapas_recv(2,i,iii)
9154 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9155 c          call flush(iout)
9156           nnn=num_cont_hb(ii)+1
9157           num_cont_hb(ii)=nnn
9158           jcont_hb(nnn,ii)=jj
9159           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9160           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9161           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9162           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9163           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9164           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9165           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9166           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9167           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9168           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9169           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9170           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9171           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9172           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9173           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9174           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9175           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9176           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9177           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9178           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9179           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9180           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9181           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9182           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9183         enddo
9184       enddo
9185       if (lprn) then
9186         write (iout,'(a)') 'Contact function values after receive:'
9187         do i=nnt,nct-2
9188           write (iout,'(2i3,50(1x,i3,f5.2))')
9189      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9190      &    j=1,num_cont_hb(i))
9191         enddo
9192         call flush(iout)
9193       endif
9194    30 continue
9195 #endif
9196       if (lprn) then
9197         write (iout,'(a)') 'Contact function values:'
9198         do i=nnt,nct-2
9199           write (iout,'(2i3,50(1x,i3,f5.2))')
9200      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9201      &    j=1,num_cont_hb(i))
9202         enddo
9203         call flush(iout)
9204       endif
9205       ecorr=0.0D0
9206 C Remove the loop below after debugging !!!
9207       do i=nnt,nct
9208         do j=1,3
9209           gradcorr(j,i)=0.0D0
9210           gradxorr(j,i)=0.0D0
9211         enddo
9212       enddo
9213 C Calculate the local-electrostatic correlation terms
9214       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9215         i1=i+1
9216         num_conti=num_cont_hb(i)
9217         num_conti1=num_cont_hb(i+1)
9218         do jj=1,num_conti
9219           j=jcont_hb(jj,i)
9220           jp=iabs(j)
9221           do kk=1,num_conti1
9222             j1=jcont_hb(kk,i1)
9223             jp1=iabs(j1)
9224 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9225 c     &         ' jj=',jj,' kk=',kk
9226 c            call flush(iout)
9227             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9228      &          .or. j.lt.0 .and. j1.gt.0) .and.
9229      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9230 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9231 C The system gains extra energy.
9232               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9233               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9234      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9235               n_corr=n_corr+1
9236             else if (j1.eq.j) then
9237 C Contacts I-J and I-(J+1) occur simultaneously.
9238 C The system loses extra energy.
9239 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9240             endif
9241           enddo ! kk
9242           do kk=1,num_conti
9243             j1=jcont_hb(kk,i)
9244 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9245 c    &         ' jj=',jj,' kk=',kk
9246             if (j1.eq.j+1) then
9247 C Contacts I-J and (I+1)-J occur simultaneously.
9248 C The system loses extra energy.
9249 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9250             endif ! j1==j+1
9251           enddo ! kk
9252         enddo ! jj
9253       enddo ! i
9254       return
9255       end
9256 c------------------------------------------------------------------------------
9257       subroutine add_hb_contact(ii,jj,itask)
9258       implicit real*8 (a-h,o-z)
9259       include "DIMENSIONS"
9260       include "COMMON.IOUNITS"
9261       integer max_cont
9262       integer max_dim
9263       parameter (max_cont=maxconts)
9264       parameter (max_dim=26)
9265       include "COMMON.CONTACTS"
9266       include 'COMMON.CONTMAT'
9267       include 'COMMON.CORRMAT'
9268       double precision zapas(max_dim,maxconts,max_fg_procs),
9269      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9270       common /przechowalnia/ zapas
9271       integer i,j,ii,jj,iproc,itask(4),nn
9272 c      write (iout,*) "itask",itask
9273       do i=1,2
9274         iproc=itask(i)
9275         if (iproc.gt.0) then
9276           do j=1,num_cont_hb(ii)
9277             jjc=jcont_hb(j,ii)
9278 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9279             if (jjc.eq.jj) then
9280               ncont_sent(iproc)=ncont_sent(iproc)+1
9281               nn=ncont_sent(iproc)
9282               zapas(1,nn,iproc)=ii
9283               zapas(2,nn,iproc)=jjc
9284               zapas(3,nn,iproc)=facont_hb(j,ii)
9285               zapas(4,nn,iproc)=ees0p(j,ii)
9286               zapas(5,nn,iproc)=ees0m(j,ii)
9287               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9288               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9289               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9290               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9291               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9292               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9293               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9294               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9295               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9296               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9297               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9298               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9299               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9300               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9301               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9302               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9303               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9304               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9305               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9306               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9307               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9308               exit
9309             endif
9310           enddo
9311         endif
9312       enddo
9313       return
9314       end
9315 c------------------------------------------------------------------------------
9316       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9317      &  n_corr1)
9318 C This subroutine calculates multi-body contributions to hydrogen-bonding
9319       implicit real*8 (a-h,o-z)
9320       include 'DIMENSIONS'
9321       include 'COMMON.IOUNITS'
9322 #ifdef MPI
9323       include "mpif.h"
9324       parameter (max_cont=maxconts)
9325       parameter (max_dim=70)
9326       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9327       double precision zapas(max_dim,maxconts,max_fg_procs),
9328      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9329       common /przechowalnia/ zapas
9330       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9331      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9332 #endif
9333       include 'COMMON.SETUP'
9334       include 'COMMON.FFIELD'
9335       include 'COMMON.DERIV'
9336       include 'COMMON.LOCAL'
9337       include 'COMMON.INTERACT'
9338       include 'COMMON.CONTACTS'
9339       include 'COMMON.CONTMAT'
9340       include 'COMMON.CORRMAT'
9341       include 'COMMON.CHAIN'
9342       include 'COMMON.CONTROL'
9343       include 'COMMON.SHIELD'
9344       double precision gx(3),gx1(3)
9345       integer num_cont_hb_old(maxres)
9346       logical lprn,ldone
9347       double precision eello4,eello5,eelo6,eello_turn6
9348       external eello4,eello5,eello6,eello_turn6
9349 C Set lprn=.true. for debugging
9350       lprn=.false.
9351       eturn6=0.0d0
9352 #ifdef MPI
9353       do i=1,nres
9354         num_cont_hb_old(i)=num_cont_hb(i)
9355       enddo
9356       n_corr=0
9357       n_corr1=0
9358       if (nfgtasks.le.1) goto 30
9359       if (lprn) then
9360         write (iout,'(a)') 'Contact function values before RECEIVE:'
9361         do i=nnt,nct-2
9362           write (iout,'(2i3,50(1x,i2,f5.2))')
9363      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9364      &    j=1,num_cont_hb(i))
9365         enddo
9366       endif
9367       do i=1,ntask_cont_from
9368         ncont_recv(i)=0
9369       enddo
9370       do i=1,ntask_cont_to
9371         ncont_sent(i)=0
9372       enddo
9373 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9374 c     & ntask_cont_to
9375 C Make the list of contacts to send to send to other procesors
9376       do i=iturn3_start,iturn3_end
9377 c        write (iout,*) "make contact list turn3",i," num_cont",
9378 c     &    num_cont_hb(i)
9379         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9380       enddo
9381       do i=iturn4_start,iturn4_end
9382 c        write (iout,*) "make contact list turn4",i," num_cont",
9383 c     &   num_cont_hb(i)
9384         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9385       enddo
9386       do ii=1,nat_sent
9387         i=iat_sent(ii)
9388 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9389 c     &    num_cont_hb(i)
9390         do j=1,num_cont_hb(i)
9391         do k=1,4
9392           jjc=jcont_hb(j,i)
9393           iproc=iint_sent_local(k,jjc,ii)
9394 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9395           if (iproc.ne.0) then
9396             ncont_sent(iproc)=ncont_sent(iproc)+1
9397             nn=ncont_sent(iproc)
9398             zapas(1,nn,iproc)=i
9399             zapas(2,nn,iproc)=jjc
9400             zapas(3,nn,iproc)=d_cont(j,i)
9401             ind=3
9402             do kk=1,3
9403               ind=ind+1
9404               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9405             enddo
9406             do kk=1,2
9407               do ll=1,2
9408                 ind=ind+1
9409                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9410               enddo
9411             enddo
9412             do jj=1,5
9413               do kk=1,3
9414                 do ll=1,2
9415                   do mm=1,2
9416                     ind=ind+1
9417                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9418                   enddo
9419                 enddo
9420               enddo
9421             enddo
9422           endif
9423         enddo
9424         enddo
9425       enddo
9426       if (lprn) then
9427       write (iout,*)
9428      &  "Numbers of contacts to be sent to other processors",
9429      &  (ncont_sent(i),i=1,ntask_cont_to)
9430       write (iout,*) "Contacts sent"
9431       do ii=1,ntask_cont_to
9432         nn=ncont_sent(ii)
9433         iproc=itask_cont_to(ii)
9434         write (iout,*) nn," contacts to processor",iproc,
9435      &   " of CONT_TO_COMM group"
9436         do i=1,nn
9437           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9438         enddo
9439       enddo
9440       call flush(iout)
9441       endif
9442       CorrelType=477
9443       CorrelID=fg_rank+1
9444       CorrelType1=478
9445       CorrelID1=nfgtasks+fg_rank+1
9446       ireq=0
9447 C Receive the numbers of needed contacts from other processors
9448       do ii=1,ntask_cont_from
9449         iproc=itask_cont_from(ii)
9450         ireq=ireq+1
9451         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9452      &    FG_COMM,req(ireq),IERR)
9453       enddo
9454 c      write (iout,*) "IRECV ended"
9455 c      call flush(iout)
9456 C Send the number of contacts needed by other processors
9457       do ii=1,ntask_cont_to
9458         iproc=itask_cont_to(ii)
9459         ireq=ireq+1
9460         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9461      &    FG_COMM,req(ireq),IERR)
9462       enddo
9463 c      write (iout,*) "ISEND ended"
9464 c      write (iout,*) "number of requests (nn)",ireq
9465 c      call flush(iout)
9466       if (ireq.gt.0)
9467      &  call MPI_Waitall(ireq,req,status_array,ierr)
9468 c      write (iout,*)
9469 c     &  "Numbers of contacts to be received from other processors",
9470 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9471 c      call flush(iout)
9472 C Receive contacts
9473       ireq=0
9474       do ii=1,ntask_cont_from
9475         iproc=itask_cont_from(ii)
9476         nn=ncont_recv(ii)
9477 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9478 c     &   " of CONT_TO_COMM group"
9479 c        call flush(iout)
9480         if (nn.gt.0) then
9481           ireq=ireq+1
9482           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9483      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9484 c          write (iout,*) "ireq,req",ireq,req(ireq)
9485         endif
9486       enddo
9487 C Send the contacts to processors that need them
9488       do ii=1,ntask_cont_to
9489         iproc=itask_cont_to(ii)
9490         nn=ncont_sent(ii)
9491 c        write (iout,*) nn," contacts to processor",iproc,
9492 c     &   " of CONT_TO_COMM group"
9493         if (nn.gt.0) then
9494           ireq=ireq+1
9495           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9496      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9497 c          write (iout,*) "ireq,req",ireq,req(ireq)
9498 c          do i=1,nn
9499 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9500 c          enddo
9501         endif
9502       enddo
9503 c      write (iout,*) "number of requests (contacts)",ireq
9504 c      write (iout,*) "req",(req(i),i=1,4)
9505 c      call flush(iout)
9506       if (ireq.gt.0)
9507      & call MPI_Waitall(ireq,req,status_array,ierr)
9508       do iii=1,ntask_cont_from
9509         iproc=itask_cont_from(iii)
9510         nn=ncont_recv(iii)
9511         if (lprn) then
9512         write (iout,*) "Received",nn," contacts from processor",iproc,
9513      &   " of CONT_FROM_COMM group"
9514         call flush(iout)
9515         do i=1,nn
9516           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9517         enddo
9518         call flush(iout)
9519         endif
9520         do i=1,nn
9521           ii=zapas_recv(1,i,iii)
9522 c Flag the received contacts to prevent double-counting
9523           jj=-zapas_recv(2,i,iii)
9524 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9525 c          call flush(iout)
9526           nnn=num_cont_hb(ii)+1
9527           num_cont_hb(ii)=nnn
9528           jcont_hb(nnn,ii)=jj
9529           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9530           ind=3
9531           do kk=1,3
9532             ind=ind+1
9533             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9534           enddo
9535           do kk=1,2
9536             do ll=1,2
9537               ind=ind+1
9538               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9539             enddo
9540           enddo
9541           do jj=1,5
9542             do kk=1,3
9543               do ll=1,2
9544                 do mm=1,2
9545                   ind=ind+1
9546                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9547                 enddo
9548               enddo
9549             enddo
9550           enddo
9551         enddo
9552       enddo
9553       if (lprn) then
9554         write (iout,'(a)') 'Contact function values after receive:'
9555         do i=nnt,nct-2
9556           write (iout,'(2i3,50(1x,i3,5f6.3))')
9557      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9558      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9559         enddo
9560         call flush(iout)
9561       endif
9562    30 continue
9563 #endif
9564       if (lprn) then
9565         write (iout,'(a)') 'Contact function values:'
9566         do i=nnt,nct-2
9567           write (iout,'(2i3,50(1x,i2,5f6.3))')
9568      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9569      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9570         enddo
9571       endif
9572       ecorr=0.0D0
9573       ecorr5=0.0d0
9574       ecorr6=0.0d0
9575 C Remove the loop below after debugging !!!
9576       do i=nnt,nct
9577         do j=1,3
9578           gradcorr(j,i)=0.0D0
9579           gradxorr(j,i)=0.0D0
9580         enddo
9581       enddo
9582 C Calculate the dipole-dipole interaction energies
9583       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9584       do i=iatel_s,iatel_e+1
9585         num_conti=num_cont_hb(i)
9586         do jj=1,num_conti
9587           j=jcont_hb(jj,i)
9588 #ifdef MOMENT
9589           call dipole(i,j,jj)
9590 #endif
9591         enddo
9592       enddo
9593       endif
9594 C Calculate the local-electrostatic correlation terms
9595 c                write (iout,*) "gradcorr5 in eello5 before loop"
9596 c                do iii=1,nres
9597 c                  write (iout,'(i5,3f10.5)')
9598 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9599 c                enddo
9600       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9601 c        write (iout,*) "corr loop i",i
9602         i1=i+1
9603         num_conti=num_cont_hb(i)
9604         num_conti1=num_cont_hb(i+1)
9605         do jj=1,num_conti
9606           j=jcont_hb(jj,i)
9607           jp=iabs(j)
9608           do kk=1,num_conti1
9609             j1=jcont_hb(kk,i1)
9610             jp1=iabs(j1)
9611 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9612 c     &         ' jj=',jj,' kk=',kk
9613 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9614             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9615      &          .or. j.lt.0 .and. j1.gt.0) .and.
9616      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9617 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9618 C The system gains extra energy.
9619               n_corr=n_corr+1
9620               sqd1=dsqrt(d_cont(jj,i))
9621               sqd2=dsqrt(d_cont(kk,i1))
9622               sred_geom = sqd1*sqd2
9623               IF (sred_geom.lt.cutoff_corr) THEN
9624                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9625      &            ekont,fprimcont)
9626 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9627 cd     &         ' jj=',jj,' kk=',kk
9628                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9629                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9630                 do l=1,3
9631                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9632                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9633                 enddo
9634                 n_corr1=n_corr1+1
9635 cd               write (iout,*) 'sred_geom=',sred_geom,
9636 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9637 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9638 cd               write (iout,*) "g_contij",g_contij
9639 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9640 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9641                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9642                 if (wcorr4.gt.0.0d0)
9643      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9644 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9645                   if (energy_dec.and.wcorr4.gt.0.0d0)
9646      1                 write (iout,'(a6,4i5,0pf7.3)')
9647      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9648 c                write (iout,*) "gradcorr5 before eello5"
9649 c                do iii=1,nres
9650 c                  write (iout,'(i5,3f10.5)')
9651 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9652 c                enddo
9653                 if (wcorr5.gt.0.0d0)
9654      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9655 c                write (iout,*) "gradcorr5 after eello5"
9656 c                do iii=1,nres
9657 c                  write (iout,'(i5,3f10.5)')
9658 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9659 c                enddo
9660                   if (energy_dec.and.wcorr5.gt.0.0d0)
9661      1                 write (iout,'(a6,4i5,0pf7.3)')
9662      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9663 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9664 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9665                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9666      &               .or. wturn6.eq.0.0d0))then
9667 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9668                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9669                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9670      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9671 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9672 cd     &            'ecorr6=',ecorr6
9673 cd                write (iout,'(4e15.5)') sred_geom,
9674 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9675 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9676 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9677                 else if (wturn6.gt.0.0d0
9678      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9679 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9680                   eturn6=eturn6+eello_turn6(i,jj,kk)
9681                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9682      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9683 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9684                 endif
9685               ENDIF
9686 1111          continue
9687             endif
9688           enddo ! kk
9689         enddo ! jj
9690       enddo ! i
9691       do i=1,nres
9692         num_cont_hb(i)=num_cont_hb_old(i)
9693       enddo
9694 c                write (iout,*) "gradcorr5 in eello5"
9695 c                do iii=1,nres
9696 c                  write (iout,'(i5,3f10.5)')
9697 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9698 c                enddo
9699       return
9700       end
9701 c------------------------------------------------------------------------------
9702       subroutine add_hb_contact_eello(ii,jj,itask)
9703       implicit real*8 (a-h,o-z)
9704       include "DIMENSIONS"
9705       include "COMMON.IOUNITS"
9706       integer max_cont
9707       integer max_dim
9708       parameter (max_cont=maxconts)
9709       parameter (max_dim=70)
9710       include "COMMON.CONTACTS"
9711       include 'COMMON.CONTMAT'
9712       include 'COMMON.CORRMAT'
9713       double precision zapas(max_dim,maxconts,max_fg_procs),
9714      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9715       common /przechowalnia/ zapas
9716       integer i,j,ii,jj,iproc,itask(4),nn
9717 c      write (iout,*) "itask",itask
9718       do i=1,2
9719         iproc=itask(i)
9720         if (iproc.gt.0) then
9721           do j=1,num_cont_hb(ii)
9722             jjc=jcont_hb(j,ii)
9723 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9724             if (jjc.eq.jj) then
9725               ncont_sent(iproc)=ncont_sent(iproc)+1
9726               nn=ncont_sent(iproc)
9727               zapas(1,nn,iproc)=ii
9728               zapas(2,nn,iproc)=jjc
9729               zapas(3,nn,iproc)=d_cont(j,ii)
9730               ind=3
9731               do kk=1,3
9732                 ind=ind+1
9733                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9734               enddo
9735               do kk=1,2
9736                 do ll=1,2
9737                   ind=ind+1
9738                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9739                 enddo
9740               enddo
9741               do jj=1,5
9742                 do kk=1,3
9743                   do ll=1,2
9744                     do mm=1,2
9745                       ind=ind+1
9746                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9747                     enddo
9748                   enddo
9749                 enddo
9750               enddo
9751               exit
9752             endif
9753           enddo
9754         endif
9755       enddo
9756       return
9757       end
9758 c------------------------------------------------------------------------------
9759       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9760       implicit real*8 (a-h,o-z)
9761       include 'DIMENSIONS'
9762       include 'COMMON.IOUNITS'
9763       include 'COMMON.DERIV'
9764       include 'COMMON.INTERACT'
9765       include 'COMMON.CONTACTS'
9766       include 'COMMON.CONTMAT'
9767       include 'COMMON.CORRMAT'
9768       include 'COMMON.SHIELD'
9769       include 'COMMON.CONTROL'
9770       double precision gx(3),gx1(3)
9771       logical lprn
9772       lprn=.false.
9773 C      print *,"wchodze",fac_shield(i),shield_mode
9774       eij=facont_hb(jj,i)
9775       ekl=facont_hb(kk,k)
9776       ees0pij=ees0p(jj,i)
9777       ees0pkl=ees0p(kk,k)
9778       ees0mij=ees0m(jj,i)
9779       ees0mkl=ees0m(kk,k)
9780       ekont=eij*ekl
9781       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9782 C*
9783 C     & fac_shield(i)**2*fac_shield(j)**2
9784 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9785 C Following 4 lines for diagnostics.
9786 cd    ees0pkl=0.0D0
9787 cd    ees0pij=1.0D0
9788 cd    ees0mkl=0.0D0
9789 cd    ees0mij=1.0D0
9790 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9791 c     & 'Contacts ',i,j,
9792 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9793 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9794 c     & 'gradcorr_long'
9795 C Calculate the multi-body contribution to energy.
9796 C      ecorr=ecorr+ekont*ees
9797 C Calculate multi-body contributions to the gradient.
9798       coeffpees0pij=coeffp*ees0pij
9799       coeffmees0mij=coeffm*ees0mij
9800       coeffpees0pkl=coeffp*ees0pkl
9801       coeffmees0mkl=coeffm*ees0mkl
9802       do ll=1,3
9803 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9804         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9805      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9806      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9807         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9808      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9809      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9810 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9811         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9812      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9813      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9814         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9815      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9816      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9817         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9818      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9819      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9820         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9821         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9822         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9823      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9824      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9825         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9826         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9827 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9828       enddo
9829 c      write (iout,*)
9830 cgrad      do m=i+1,j-1
9831 cgrad        do ll=1,3
9832 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9833 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9834 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9835 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9836 cgrad        enddo
9837 cgrad      enddo
9838 cgrad      do m=k+1,l-1
9839 cgrad        do ll=1,3
9840 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9841 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9842 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9843 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9844 cgrad        enddo
9845 cgrad      enddo
9846 c      write (iout,*) "ehbcorr",ekont*ees
9847 C      print *,ekont,ees,i,k
9848       ehbcorr=ekont*ees
9849 C now gradient over shielding
9850 C      return
9851       if (shield_mode.gt.0) then
9852        j=ees0plist(jj,i)
9853        l=ees0plist(kk,k)
9854 C        print *,i,j,fac_shield(i),fac_shield(j),
9855 C     &fac_shield(k),fac_shield(l)
9856         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9857      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9858           do ilist=1,ishield_list(i)
9859            iresshield=shield_list(ilist,i)
9860            do m=1,3
9861            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9862 C     &      *2.0
9863            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9864      &              rlocshield
9865      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9866             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9867      &+rlocshield
9868            enddo
9869           enddo
9870           do ilist=1,ishield_list(j)
9871            iresshield=shield_list(ilist,j)
9872            do m=1,3
9873            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9874 C     &     *2.0
9875            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9876      &              rlocshield
9877      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9878            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9879      &     +rlocshield
9880            enddo
9881           enddo
9882
9883           do ilist=1,ishield_list(k)
9884            iresshield=shield_list(ilist,k)
9885            do m=1,3
9886            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9887 C     &     *2.0
9888            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9889      &              rlocshield
9890      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9891            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9892      &     +rlocshield
9893            enddo
9894           enddo
9895           do ilist=1,ishield_list(l)
9896            iresshield=shield_list(ilist,l)
9897            do m=1,3
9898            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9899 C     &     *2.0
9900            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9901      &              rlocshield
9902      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9903            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9904      &     +rlocshield
9905            enddo
9906           enddo
9907 C          print *,gshieldx(m,iresshield)
9908           do m=1,3
9909             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9910      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9911             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9912      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9913             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9914      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9915             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9916      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9917
9918             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9919      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9920             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9921      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9922             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9923      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9924             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9925      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9926
9927            enddo
9928       endif
9929       endif
9930       return
9931       end
9932 #ifdef MOMENT
9933 C---------------------------------------------------------------------------
9934       subroutine dipole(i,j,jj)
9935       implicit real*8 (a-h,o-z)
9936       include 'DIMENSIONS'
9937       include 'COMMON.IOUNITS'
9938       include 'COMMON.CHAIN'
9939       include 'COMMON.FFIELD'
9940       include 'COMMON.DERIV'
9941       include 'COMMON.INTERACT'
9942       include 'COMMON.CONTACTS'
9943       include 'COMMON.CONTMAT'
9944       include 'COMMON.CORRMAT'
9945       include 'COMMON.TORSION'
9946       include 'COMMON.VAR'
9947       include 'COMMON.GEO'
9948       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9949      &  auxmat(2,2)
9950       iti1 = itortyp(itype(i+1))
9951       if (j.lt.nres-1) then
9952         itj1 = itype2loc(itype(j+1))
9953       else
9954         itj1=nloctyp
9955       endif
9956       do iii=1,2
9957         dipi(iii,1)=Ub2(iii,i)
9958         dipderi(iii)=Ub2der(iii,i)
9959         dipi(iii,2)=b1(iii,i+1)
9960         dipj(iii,1)=Ub2(iii,j)
9961         dipderj(iii)=Ub2der(iii,j)
9962         dipj(iii,2)=b1(iii,j+1)
9963       enddo
9964       kkk=0
9965       do iii=1,2
9966         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9967         do jjj=1,2
9968           kkk=kkk+1
9969           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9970         enddo
9971       enddo
9972       do kkk=1,5
9973         do lll=1,3
9974           mmm=0
9975           do iii=1,2
9976             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9977      &        auxvec(1))
9978             do jjj=1,2
9979               mmm=mmm+1
9980               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9981             enddo
9982           enddo
9983         enddo
9984       enddo
9985       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9986       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9987       do iii=1,2
9988         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9989       enddo
9990       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9991       do iii=1,2
9992         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9993       enddo
9994       return
9995       end
9996 #endif
9997 C---------------------------------------------------------------------------
9998       subroutine calc_eello(i,j,k,l,jj,kk)
9999 C
10000 C This subroutine computes matrices and vectors needed to calculate
10001 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
10002 C
10003       implicit real*8 (a-h,o-z)
10004       include 'DIMENSIONS'
10005       include 'COMMON.IOUNITS'
10006       include 'COMMON.CHAIN'
10007       include 'COMMON.DERIV'
10008       include 'COMMON.INTERACT'
10009       include 'COMMON.CONTACTS'
10010       include 'COMMON.CONTMAT'
10011       include 'COMMON.CORRMAT'
10012       include 'COMMON.TORSION'
10013       include 'COMMON.VAR'
10014       include 'COMMON.GEO'
10015       include 'COMMON.FFIELD'
10016       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
10017      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
10018       logical lprn
10019       common /kutas/ lprn
10020 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
10021 cd     & ' jj=',jj,' kk=',kk
10022 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
10023 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
10024 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
10025       do iii=1,2
10026         do jjj=1,2
10027           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
10028           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
10029         enddo
10030       enddo
10031       call transpose2(aa1(1,1),aa1t(1,1))
10032       call transpose2(aa2(1,1),aa2t(1,1))
10033       do kkk=1,5
10034         do lll=1,3
10035           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
10036      &      aa1tder(1,1,lll,kkk))
10037           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
10038      &      aa2tder(1,1,lll,kkk))
10039         enddo
10040       enddo
10041       if (l.eq.j+1) then
10042 C parallel orientation of the two CA-CA-CA frames.
10043         if (i.gt.1) then
10044           iti=itype2loc(itype(i))
10045         else
10046           iti=nloctyp
10047         endif
10048         itk1=itype2loc(itype(k+1))
10049         itj=itype2loc(itype(j))
10050         if (l.lt.nres-1) then
10051           itl1=itype2loc(itype(l+1))
10052         else
10053           itl1=nloctyp
10054         endif
10055 C A1 kernel(j+1) A2T
10056 cd        do iii=1,2
10057 cd          write (iout,'(3f10.5,5x,3f10.5)')
10058 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10059 cd        enddo
10060         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10061      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10062      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10063 C Following matrices are needed only for 6-th order cumulants
10064         IF (wcorr6.gt.0.0d0) THEN
10065         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10066      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10067      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10069      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10070      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10071      &   ADtEAderx(1,1,1,1,1,1))
10072         lprn=.false.
10073         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10074      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10075      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10076      &   ADtEA1derx(1,1,1,1,1,1))
10077         ENDIF
10078 C End 6-th order cumulants
10079 cd        lprn=.false.
10080 cd        if (lprn) then
10081 cd        write (2,*) 'In calc_eello6'
10082 cd        do iii=1,2
10083 cd          write (2,*) 'iii=',iii
10084 cd          do kkk=1,5
10085 cd            write (2,*) 'kkk=',kkk
10086 cd            do jjj=1,2
10087 cd              write (2,'(3(2f10.5),5x)')
10088 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10089 cd            enddo
10090 cd          enddo
10091 cd        enddo
10092 cd        endif
10093         call transpose2(EUgder(1,1,k),auxmat(1,1))
10094         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10095         call transpose2(EUg(1,1,k),auxmat(1,1))
10096         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10097         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10098 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10099 c    in theta; to be sriten later.
10100 c#ifdef NEWCORR
10101 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
10102 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10103 c        call transpose2(EUg(1,1,k),auxmat(1,1))
10104 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10105 c#endif
10106         do iii=1,2
10107           do kkk=1,5
10108             do lll=1,3
10109               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10110      &          EAEAderx(1,1,lll,kkk,iii,1))
10111             enddo
10112           enddo
10113         enddo
10114 C A1T kernel(i+1) A2
10115         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10116      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10117      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10118 C Following matrices are needed only for 6-th order cumulants
10119         IF (wcorr6.gt.0.0d0) THEN
10120         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10121      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10122      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10123         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10124      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10125      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10126      &   ADtEAderx(1,1,1,1,1,2))
10127         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10128      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10129      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10130      &   ADtEA1derx(1,1,1,1,1,2))
10131         ENDIF
10132 C End 6-th order cumulants
10133         call transpose2(EUgder(1,1,l),auxmat(1,1))
10134         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10135         call transpose2(EUg(1,1,l),auxmat(1,1))
10136         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10137         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10138         do iii=1,2
10139           do kkk=1,5
10140             do lll=1,3
10141               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10142      &          EAEAderx(1,1,lll,kkk,iii,2))
10143             enddo
10144           enddo
10145         enddo
10146 C AEAb1 and AEAb2
10147 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10148 C They are needed only when the fifth- or the sixth-order cumulants are
10149 C indluded.
10150         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10151         call transpose2(AEA(1,1,1),auxmat(1,1))
10152         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10153         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10154         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10155         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10156         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10157         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10158         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10159         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10160         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10161         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10162         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10163         call transpose2(AEA(1,1,2),auxmat(1,1))
10164         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10165         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10166         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10167         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10168         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10169         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10170         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10171         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10172         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10173         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10174         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10175 C Calculate the Cartesian derivatives of the vectors.
10176         do iii=1,2
10177           do kkk=1,5
10178             do lll=1,3
10179               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10180               call matvec2(auxmat(1,1),b1(1,i),
10181      &          AEAb1derx(1,lll,kkk,iii,1,1))
10182               call matvec2(auxmat(1,1),Ub2(1,i),
10183      &          AEAb2derx(1,lll,kkk,iii,1,1))
10184               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10185      &          AEAb1derx(1,lll,kkk,iii,2,1))
10186               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10187      &          AEAb2derx(1,lll,kkk,iii,2,1))
10188               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10189               call matvec2(auxmat(1,1),b1(1,j),
10190      &          AEAb1derx(1,lll,kkk,iii,1,2))
10191               call matvec2(auxmat(1,1),Ub2(1,j),
10192      &          AEAb2derx(1,lll,kkk,iii,1,2))
10193               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10194      &          AEAb1derx(1,lll,kkk,iii,2,2))
10195               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10196      &          AEAb2derx(1,lll,kkk,iii,2,2))
10197             enddo
10198           enddo
10199         enddo
10200         ENDIF
10201 C End vectors
10202       else
10203 C Antiparallel orientation of the two CA-CA-CA frames.
10204         if (i.gt.1) then
10205           iti=itype2loc(itype(i))
10206         else
10207           iti=nloctyp
10208         endif
10209         itk1=itype2loc(itype(k+1))
10210         itl=itype2loc(itype(l))
10211         itj=itype2loc(itype(j))
10212         if (j.lt.nres-1) then
10213           itj1=itype2loc(itype(j+1))
10214         else
10215           itj1=nloctyp
10216         endif
10217 C A2 kernel(j-1)T A1T
10218         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10219      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10220      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10221 C Following matrices are needed only for 6-th order cumulants
10222         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10223      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10224         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10225      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10226      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10227         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10228      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10229      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10230      &   ADtEAderx(1,1,1,1,1,1))
10231         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10232      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10233      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10234      &   ADtEA1derx(1,1,1,1,1,1))
10235         ENDIF
10236 C End 6-th order cumulants
10237         call transpose2(EUgder(1,1,k),auxmat(1,1))
10238         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10239         call transpose2(EUg(1,1,k),auxmat(1,1))
10240         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10241         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10242         do iii=1,2
10243           do kkk=1,5
10244             do lll=1,3
10245               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10246      &          EAEAderx(1,1,lll,kkk,iii,1))
10247             enddo
10248           enddo
10249         enddo
10250 C A2T kernel(i+1)T A1
10251         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10252      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10253      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10254 C Following matrices are needed only for 6-th order cumulants
10255         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10256      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10257         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10258      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10259      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10260         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10261      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10262      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10263      &   ADtEAderx(1,1,1,1,1,2))
10264         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10265      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10266      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10267      &   ADtEA1derx(1,1,1,1,1,2))
10268         ENDIF
10269 C End 6-th order cumulants
10270         call transpose2(EUgder(1,1,j),auxmat(1,1))
10271         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10272         call transpose2(EUg(1,1,j),auxmat(1,1))
10273         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10274         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10275         do iii=1,2
10276           do kkk=1,5
10277             do lll=1,3
10278               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10279      &          EAEAderx(1,1,lll,kkk,iii,2))
10280             enddo
10281           enddo
10282         enddo
10283 C AEAb1 and AEAb2
10284 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10285 C They are needed only when the fifth- or the sixth-order cumulants are
10286 C indluded.
10287         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10288      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10289         call transpose2(AEA(1,1,1),auxmat(1,1))
10290         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10291         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10292         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10293         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10294         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10295         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10296         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10297         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10298         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10299         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10300         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10301         call transpose2(AEA(1,1,2),auxmat(1,1))
10302         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10303         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10304         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10305         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10306         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10307         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10308         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10309         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10310         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10311         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10312         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10313 C Calculate the Cartesian derivatives of the vectors.
10314         do iii=1,2
10315           do kkk=1,5
10316             do lll=1,3
10317               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10318               call matvec2(auxmat(1,1),b1(1,i),
10319      &          AEAb1derx(1,lll,kkk,iii,1,1))
10320               call matvec2(auxmat(1,1),Ub2(1,i),
10321      &          AEAb2derx(1,lll,kkk,iii,1,1))
10322               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10323      &          AEAb1derx(1,lll,kkk,iii,2,1))
10324               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10325      &          AEAb2derx(1,lll,kkk,iii,2,1))
10326               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10327               call matvec2(auxmat(1,1),b1(1,l),
10328      &          AEAb1derx(1,lll,kkk,iii,1,2))
10329               call matvec2(auxmat(1,1),Ub2(1,l),
10330      &          AEAb2derx(1,lll,kkk,iii,1,2))
10331               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10332      &          AEAb1derx(1,lll,kkk,iii,2,2))
10333               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10334      &          AEAb2derx(1,lll,kkk,iii,2,2))
10335             enddo
10336           enddo
10337         enddo
10338         ENDIF
10339 C End vectors
10340       endif
10341       return
10342       end
10343 C---------------------------------------------------------------------------
10344       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10345      &  KK,KKderg,AKA,AKAderg,AKAderx)
10346       implicit none
10347       integer nderg
10348       logical transp
10349       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10350      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10351      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10352       integer iii,kkk,lll
10353       integer jjj,mmm
10354       logical lprn
10355       common /kutas/ lprn
10356       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10357       do iii=1,nderg
10358         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10359      &    AKAderg(1,1,iii))
10360       enddo
10361 cd      if (lprn) write (2,*) 'In kernel'
10362       do kkk=1,5
10363 cd        if (lprn) write (2,*) 'kkk=',kkk
10364         do lll=1,3
10365           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10366      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10367 cd          if (lprn) then
10368 cd            write (2,*) 'lll=',lll
10369 cd            write (2,*) 'iii=1'
10370 cd            do jjj=1,2
10371 cd              write (2,'(3(2f10.5),5x)')
10372 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10373 cd            enddo
10374 cd          endif
10375           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10376      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10377 cd          if (lprn) then
10378 cd            write (2,*) 'lll=',lll
10379 cd            write (2,*) 'iii=2'
10380 cd            do jjj=1,2
10381 cd              write (2,'(3(2f10.5),5x)')
10382 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10383 cd            enddo
10384 cd          endif
10385         enddo
10386       enddo
10387       return
10388       end
10389 C---------------------------------------------------------------------------
10390       double precision function eello4(i,j,k,l,jj,kk)
10391       implicit real*8 (a-h,o-z)
10392       include 'DIMENSIONS'
10393       include 'COMMON.IOUNITS'
10394       include 'COMMON.CHAIN'
10395       include 'COMMON.DERIV'
10396       include 'COMMON.INTERACT'
10397       include 'COMMON.CONTACTS'
10398       include 'COMMON.CONTMAT'
10399       include 'COMMON.CORRMAT'
10400       include 'COMMON.TORSION'
10401       include 'COMMON.VAR'
10402       include 'COMMON.GEO'
10403       double precision pizda(2,2),ggg1(3),ggg2(3)
10404 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10405 cd        eello4=0.0d0
10406 cd        return
10407 cd      endif
10408 cd      print *,'eello4:',i,j,k,l,jj,kk
10409 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10410 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10411 cold      eij=facont_hb(jj,i)
10412 cold      ekl=facont_hb(kk,k)
10413 cold      ekont=eij*ekl
10414       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10415 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10416       gcorr_loc(k-1)=gcorr_loc(k-1)
10417      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10418       if (l.eq.j+1) then
10419         gcorr_loc(l-1)=gcorr_loc(l-1)
10420      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10421 C Al 4/16/16: Derivatives in theta, to be added later.
10422 c#ifdef NEWCORR
10423 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10424 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10425 c#endif
10426       else
10427         gcorr_loc(j-1)=gcorr_loc(j-1)
10428      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10429 c#ifdef NEWCORR
10430 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10431 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10432 c#endif
10433       endif
10434       do iii=1,2
10435         do kkk=1,5
10436           do lll=1,3
10437             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10438      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10439 cd            derx(lll,kkk,iii)=0.0d0
10440           enddo
10441         enddo
10442       enddo
10443 cd      gcorr_loc(l-1)=0.0d0
10444 cd      gcorr_loc(j-1)=0.0d0
10445 cd      gcorr_loc(k-1)=0.0d0
10446 cd      eel4=1.0d0
10447 cd      write (iout,*)'Contacts have occurred for peptide groups',
10448 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10449 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10450       if (j.lt.nres-1) then
10451         j1=j+1
10452         j2=j-1
10453       else
10454         j1=j-1
10455         j2=j-2
10456       endif
10457       if (l.lt.nres-1) then
10458         l1=l+1
10459         l2=l-1
10460       else
10461         l1=l-1
10462         l2=l-2
10463       endif
10464       do ll=1,3
10465 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10466 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10467         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10468         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10469 cgrad        ghalf=0.5d0*ggg1(ll)
10470         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10471         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10472         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10473         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10474         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10475         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10476 cgrad        ghalf=0.5d0*ggg2(ll)
10477         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10478         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10479         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10480         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10481         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10482         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10483       enddo
10484 cgrad      do m=i+1,j-1
10485 cgrad        do ll=1,3
10486 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10487 cgrad        enddo
10488 cgrad      enddo
10489 cgrad      do m=k+1,l-1
10490 cgrad        do ll=1,3
10491 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10492 cgrad        enddo
10493 cgrad      enddo
10494 cgrad      do m=i+2,j2
10495 cgrad        do ll=1,3
10496 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10497 cgrad        enddo
10498 cgrad      enddo
10499 cgrad      do m=k+2,l2
10500 cgrad        do ll=1,3
10501 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10502 cgrad        enddo
10503 cgrad      enddo
10504 cd      do iii=1,nres-3
10505 cd        write (2,*) iii,gcorr_loc(iii)
10506 cd      enddo
10507       eello4=ekont*eel4
10508 cd      write (2,*) 'ekont',ekont
10509 cd      write (iout,*) 'eello4',ekont*eel4
10510       return
10511       end
10512 C---------------------------------------------------------------------------
10513       double precision function eello5(i,j,k,l,jj,kk)
10514       implicit real*8 (a-h,o-z)
10515       include 'DIMENSIONS'
10516       include 'COMMON.IOUNITS'
10517       include 'COMMON.CHAIN'
10518       include 'COMMON.DERIV'
10519       include 'COMMON.INTERACT'
10520       include 'COMMON.CONTACTS'
10521       include 'COMMON.CONTMAT'
10522       include 'COMMON.CORRMAT'
10523       include 'COMMON.TORSION'
10524       include 'COMMON.VAR'
10525       include 'COMMON.GEO'
10526       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10527       double precision ggg1(3),ggg2(3)
10528 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10529 C                                                                              C
10530 C                            Parallel chains                                   C
10531 C                                                                              C
10532 C          o             o                   o             o                   C
10533 C         /l\           / \             \   / \           / \   /              C
10534 C        /   \         /   \             \ /   \         /   \ /               C
10535 C       j| o |l1       | o |              o| o |         | o |o                C
10536 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10537 C      \i/   \         /   \ /             /   \         /   \                 C
10538 C       o    k1             o                                                  C
10539 C         (I)          (II)                (III)          (IV)                 C
10540 C                                                                              C
10541 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10542 C                                                                              C
10543 C                            Antiparallel chains                               C
10544 C                                                                              C
10545 C          o             o                   o             o                   C
10546 C         /j\           / \             \   / \           / \   /              C
10547 C        /   \         /   \             \ /   \         /   \ /               C
10548 C      j1| o |l        | o |              o| o |         | o |o                C
10549 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10550 C      \i/   \         /   \ /             /   \         /   \                 C
10551 C       o     k1            o                                                  C
10552 C         (I)          (II)                (III)          (IV)                 C
10553 C                                                                              C
10554 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10555 C                                                                              C
10556 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10557 C                                                                              C
10558 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10559 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10560 cd        eello5=0.0d0
10561 cd        return
10562 cd      endif
10563 cd      write (iout,*)
10564 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10565 cd     &   ' and',k,l
10566       itk=itype2loc(itype(k))
10567       itl=itype2loc(itype(l))
10568       itj=itype2loc(itype(j))
10569       eello5_1=0.0d0
10570       eello5_2=0.0d0
10571       eello5_3=0.0d0
10572       eello5_4=0.0d0
10573 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10574 cd     &   eel5_3_num,eel5_4_num)
10575       do iii=1,2
10576         do kkk=1,5
10577           do lll=1,3
10578             derx(lll,kkk,iii)=0.0d0
10579           enddo
10580         enddo
10581       enddo
10582 cd      eij=facont_hb(jj,i)
10583 cd      ekl=facont_hb(kk,k)
10584 cd      ekont=eij*ekl
10585 cd      write (iout,*)'Contacts have occurred for peptide groups',
10586 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10587 cd      goto 1111
10588 C Contribution from the graph I.
10589 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10590 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10591       call transpose2(EUg(1,1,k),auxmat(1,1))
10592       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10593       vv(1)=pizda(1,1)-pizda(2,2)
10594       vv(2)=pizda(1,2)+pizda(2,1)
10595       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10596      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10597 C Explicit gradient in virtual-dihedral angles.
10598       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10599      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10600      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10601       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10602       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10603       vv(1)=pizda(1,1)-pizda(2,2)
10604       vv(2)=pizda(1,2)+pizda(2,1)
10605       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10606      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10607      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10608       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10609       vv(1)=pizda(1,1)-pizda(2,2)
10610       vv(2)=pizda(1,2)+pizda(2,1)
10611       if (l.eq.j+1) then
10612         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10613      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10614      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10615       else
10616         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10617      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10618      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10619       endif
10620 C Cartesian gradient
10621       do iii=1,2
10622         do kkk=1,5
10623           do lll=1,3
10624             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10625      &        pizda(1,1))
10626             vv(1)=pizda(1,1)-pizda(2,2)
10627             vv(2)=pizda(1,2)+pizda(2,1)
10628             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10629      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10630      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10631           enddo
10632         enddo
10633       enddo
10634 c      goto 1112
10635 c1111  continue
10636 C Contribution from graph II
10637       call transpose2(EE(1,1,k),auxmat(1,1))
10638       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10639       vv(1)=pizda(1,1)+pizda(2,2)
10640       vv(2)=pizda(2,1)-pizda(1,2)
10641       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10642      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10643 C Explicit gradient in virtual-dihedral angles.
10644       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10645      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10646       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10647       vv(1)=pizda(1,1)+pizda(2,2)
10648       vv(2)=pizda(2,1)-pizda(1,2)
10649       if (l.eq.j+1) then
10650         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10651      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10652      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10653       else
10654         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10655      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10656      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10657       endif
10658 C Cartesian gradient
10659       do iii=1,2
10660         do kkk=1,5
10661           do lll=1,3
10662             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10663      &        pizda(1,1))
10664             vv(1)=pizda(1,1)+pizda(2,2)
10665             vv(2)=pizda(2,1)-pizda(1,2)
10666             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10667      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10668      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10669           enddo
10670         enddo
10671       enddo
10672 cd      goto 1112
10673 cd1111  continue
10674       if (l.eq.j+1) then
10675 cd        goto 1110
10676 C Parallel orientation
10677 C Contribution from graph III
10678         call transpose2(EUg(1,1,l),auxmat(1,1))
10679         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10680         vv(1)=pizda(1,1)-pizda(2,2)
10681         vv(2)=pizda(1,2)+pizda(2,1)
10682         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10683      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10684 C Explicit gradient in virtual-dihedral angles.
10685         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10686      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10687      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10688         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10689         vv(1)=pizda(1,1)-pizda(2,2)
10690         vv(2)=pizda(1,2)+pizda(2,1)
10691         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10692      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10693      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10694         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10695         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10696         vv(1)=pizda(1,1)-pizda(2,2)
10697         vv(2)=pizda(1,2)+pizda(2,1)
10698         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10699      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10700      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10701 C Cartesian gradient
10702         do iii=1,2
10703           do kkk=1,5
10704             do lll=1,3
10705               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10706      &          pizda(1,1))
10707               vv(1)=pizda(1,1)-pizda(2,2)
10708               vv(2)=pizda(1,2)+pizda(2,1)
10709               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10710      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10711      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10712             enddo
10713           enddo
10714         enddo
10715 cd        goto 1112
10716 C Contribution from graph IV
10717 cd1110    continue
10718         call transpose2(EE(1,1,l),auxmat(1,1))
10719         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10720         vv(1)=pizda(1,1)+pizda(2,2)
10721         vv(2)=pizda(2,1)-pizda(1,2)
10722         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10723      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10724 C Explicit gradient in virtual-dihedral angles.
10725         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10726      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10727         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10728         vv(1)=pizda(1,1)+pizda(2,2)
10729         vv(2)=pizda(2,1)-pizda(1,2)
10730         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10731      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10732      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10733 C Cartesian gradient
10734         do iii=1,2
10735           do kkk=1,5
10736             do lll=1,3
10737               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10738      &          pizda(1,1))
10739               vv(1)=pizda(1,1)+pizda(2,2)
10740               vv(2)=pizda(2,1)-pizda(1,2)
10741               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10742      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10743      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10744             enddo
10745           enddo
10746         enddo
10747       else
10748 C Antiparallel orientation
10749 C Contribution from graph III
10750 c        goto 1110
10751         call transpose2(EUg(1,1,j),auxmat(1,1))
10752         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10753         vv(1)=pizda(1,1)-pizda(2,2)
10754         vv(2)=pizda(1,2)+pizda(2,1)
10755         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10756      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10757 C Explicit gradient in virtual-dihedral angles.
10758         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10759      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10760      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10761         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10762         vv(1)=pizda(1,1)-pizda(2,2)
10763         vv(2)=pizda(1,2)+pizda(2,1)
10764         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10765      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10766      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10767         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10768         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10769         vv(1)=pizda(1,1)-pizda(2,2)
10770         vv(2)=pizda(1,2)+pizda(2,1)
10771         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10772      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10773      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10774 C Cartesian gradient
10775         do iii=1,2
10776           do kkk=1,5
10777             do lll=1,3
10778               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10779      &          pizda(1,1))
10780               vv(1)=pizda(1,1)-pizda(2,2)
10781               vv(2)=pizda(1,2)+pizda(2,1)
10782               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10783      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10784      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10785             enddo
10786           enddo
10787         enddo
10788 cd        goto 1112
10789 C Contribution from graph IV
10790 1110    continue
10791         call transpose2(EE(1,1,j),auxmat(1,1))
10792         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10793         vv(1)=pizda(1,1)+pizda(2,2)
10794         vv(2)=pizda(2,1)-pizda(1,2)
10795         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10796      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10797 C Explicit gradient in virtual-dihedral angles.
10798         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10799      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10800         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10801         vv(1)=pizda(1,1)+pizda(2,2)
10802         vv(2)=pizda(2,1)-pizda(1,2)
10803         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10804      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10805      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10806 C Cartesian gradient
10807         do iii=1,2
10808           do kkk=1,5
10809             do lll=1,3
10810               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10811      &          pizda(1,1))
10812               vv(1)=pizda(1,1)+pizda(2,2)
10813               vv(2)=pizda(2,1)-pizda(1,2)
10814               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10815      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10816      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10817             enddo
10818           enddo
10819         enddo
10820       endif
10821 1112  continue
10822       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10823 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10824 cd        write (2,*) 'ijkl',i,j,k,l
10825 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10826 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10827 cd      endif
10828 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10829 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10830 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10831 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10832       if (j.lt.nres-1) then
10833         j1=j+1
10834         j2=j-1
10835       else
10836         j1=j-1
10837         j2=j-2
10838       endif
10839       if (l.lt.nres-1) then
10840         l1=l+1
10841         l2=l-1
10842       else
10843         l1=l-1
10844         l2=l-2
10845       endif
10846 cd      eij=1.0d0
10847 cd      ekl=1.0d0
10848 cd      ekont=1.0d0
10849 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10850 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10851 C        summed up outside the subrouine as for the other subroutines
10852 C        handling long-range interactions. The old code is commented out
10853 C        with "cgrad" to keep track of changes.
10854       do ll=1,3
10855 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10856 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10857         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10858         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10859 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10860 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10861 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10862 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10863 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10864 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10865 c     &   gradcorr5ij,
10866 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10867 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10868 cgrad        ghalf=0.5d0*ggg1(ll)
10869 cd        ghalf=0.0d0
10870         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10871         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10872         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10873         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10874         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10875         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10876 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10877 cgrad        ghalf=0.5d0*ggg2(ll)
10878 cd        ghalf=0.0d0
10879         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10880         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10881         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10882         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10883         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10884         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10885       enddo
10886 cd      goto 1112
10887 cgrad      do m=i+1,j-1
10888 cgrad        do ll=1,3
10889 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10890 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10891 cgrad        enddo
10892 cgrad      enddo
10893 cgrad      do m=k+1,l-1
10894 cgrad        do ll=1,3
10895 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10896 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10897 cgrad        enddo
10898 cgrad      enddo
10899 c1112  continue
10900 cgrad      do m=i+2,j2
10901 cgrad        do ll=1,3
10902 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10903 cgrad        enddo
10904 cgrad      enddo
10905 cgrad      do m=k+2,l2
10906 cgrad        do ll=1,3
10907 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10908 cgrad        enddo
10909 cgrad      enddo
10910 cd      do iii=1,nres-3
10911 cd        write (2,*) iii,g_corr5_loc(iii)
10912 cd      enddo
10913       eello5=ekont*eel5
10914 cd      write (2,*) 'ekont',ekont
10915 cd      write (iout,*) 'eello5',ekont*eel5
10916       return
10917       end
10918 c--------------------------------------------------------------------------
10919       double precision function eello6(i,j,k,l,jj,kk)
10920       implicit real*8 (a-h,o-z)
10921       include 'DIMENSIONS'
10922       include 'COMMON.IOUNITS'
10923       include 'COMMON.CHAIN'
10924       include 'COMMON.DERIV'
10925       include 'COMMON.INTERACT'
10926       include 'COMMON.CONTACTS'
10927       include 'COMMON.CONTMAT'
10928       include 'COMMON.CORRMAT'
10929       include 'COMMON.TORSION'
10930       include 'COMMON.VAR'
10931       include 'COMMON.GEO'
10932       include 'COMMON.FFIELD'
10933       double precision ggg1(3),ggg2(3)
10934 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10935 cd        eello6=0.0d0
10936 cd        return
10937 cd      endif
10938 cd      write (iout,*)
10939 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10940 cd     &   ' and',k,l
10941       eello6_1=0.0d0
10942       eello6_2=0.0d0
10943       eello6_3=0.0d0
10944       eello6_4=0.0d0
10945       eello6_5=0.0d0
10946       eello6_6=0.0d0
10947 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10948 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10949       do iii=1,2
10950         do kkk=1,5
10951           do lll=1,3
10952             derx(lll,kkk,iii)=0.0d0
10953           enddo
10954         enddo
10955       enddo
10956 cd      eij=facont_hb(jj,i)
10957 cd      ekl=facont_hb(kk,k)
10958 cd      ekont=eij*ekl
10959 cd      eij=1.0d0
10960 cd      ekl=1.0d0
10961 cd      ekont=1.0d0
10962       if (l.eq.j+1) then
10963         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10964         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10965         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10966         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10967         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10968         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10969       else
10970         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10971         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10972         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10973         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10974         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10975           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10976         else
10977           eello6_5=0.0d0
10978         endif
10979         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10980       endif
10981 C If turn contributions are considered, they will be handled separately.
10982       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10983 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10984 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10985 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10986 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10987 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10988 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10989 cd      goto 1112
10990       if (j.lt.nres-1) then
10991         j1=j+1
10992         j2=j-1
10993       else
10994         j1=j-1
10995         j2=j-2
10996       endif
10997       if (l.lt.nres-1) then
10998         l1=l+1
10999         l2=l-1
11000       else
11001         l1=l-1
11002         l2=l-2
11003       endif
11004       do ll=1,3
11005 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
11006 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
11007 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
11008 cgrad        ghalf=0.5d0*ggg1(ll)
11009 cd        ghalf=0.0d0
11010         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
11011         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
11012         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
11013         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
11014         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
11015         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
11016         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
11017         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
11018 cgrad        ghalf=0.5d0*ggg2(ll)
11019 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
11020 cd        ghalf=0.0d0
11021         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
11022         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
11023         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
11024         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
11025         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
11026         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
11027       enddo
11028 cd      goto 1112
11029 cgrad      do m=i+1,j-1
11030 cgrad        do ll=1,3
11031 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
11032 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
11033 cgrad        enddo
11034 cgrad      enddo
11035 cgrad      do m=k+1,l-1
11036 cgrad        do ll=1,3
11037 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
11038 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
11039 cgrad        enddo
11040 cgrad      enddo
11041 cgrad1112  continue
11042 cgrad      do m=i+2,j2
11043 cgrad        do ll=1,3
11044 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
11045 cgrad        enddo
11046 cgrad      enddo
11047 cgrad      do m=k+2,l2
11048 cgrad        do ll=1,3
11049 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
11050 cgrad        enddo
11051 cgrad      enddo
11052 cd      do iii=1,nres-3
11053 cd        write (2,*) iii,g_corr6_loc(iii)
11054 cd      enddo
11055       eello6=ekont*eel6
11056 cd      write (2,*) 'ekont',ekont
11057 cd      write (iout,*) 'eello6',ekont*eel6
11058       return
11059       end
11060 c--------------------------------------------------------------------------
11061       double precision function eello6_graph1(i,j,k,l,imat,swap)
11062       implicit real*8 (a-h,o-z)
11063       include 'DIMENSIONS'
11064       include 'COMMON.IOUNITS'
11065       include 'COMMON.CHAIN'
11066       include 'COMMON.DERIV'
11067       include 'COMMON.INTERACT'
11068       include 'COMMON.CONTACTS'
11069       include 'COMMON.CONTMAT'
11070       include 'COMMON.CORRMAT'
11071       include 'COMMON.TORSION'
11072       include 'COMMON.VAR'
11073       include 'COMMON.GEO'
11074       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11075       logical swap
11076       logical lprn
11077       common /kutas/ lprn
11078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11079 C                                                                              C
11080 C      Parallel       Antiparallel                                             C
11081 C                                                                              C
11082 C          o             o                                                     C
11083 C         /l\           /j\                                                    C
11084 C        /   \         /   \                                                   C
11085 C       /| o |         | o |\                                                  C
11086 C     \ j|/k\|  /   \  |/k\|l /                                                C
11087 C      \ /   \ /     \ /   \ /                                                 C
11088 C       o     o       o     o                                                  C
11089 C       i             i                                                        C
11090 C                                                                              C
11091 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11092       itk=itype2loc(itype(k))
11093       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11094       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11095       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11096       call transpose2(EUgC(1,1,k),auxmat(1,1))
11097       call matmat2(AEA(1,1,imat),auxmat(1,1),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)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11102       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11103       s5=scalar2(vv(1),Dtobr2(1,i))
11104 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11105       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11106       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11107      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11108      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11109      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11110      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11111      & +scalar2(vv(1),Dtobr2der(1,i)))
11112       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11113       vv1(1)=pizda1(1,1)-pizda1(2,2)
11114       vv1(2)=pizda1(1,2)+pizda1(2,1)
11115       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11116       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11117       if (l.eq.j+1) then
11118         g_corr6_loc(l-1)=g_corr6_loc(l-1)
11119      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11120      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11121      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11122      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11123       else
11124         g_corr6_loc(j-1)=g_corr6_loc(j-1)
11125      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11126      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11127      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11128      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11129       endif
11130       call transpose2(EUgCder(1,1,k),auxmat(1,1))
11131       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11132       vv1(1)=pizda1(1,1)-pizda1(2,2)
11133       vv1(2)=pizda1(1,2)+pizda1(2,1)
11134       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11135      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11136      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11137      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11138       do iii=1,2
11139         if (swap) then
11140           ind=3-iii
11141         else
11142           ind=iii
11143         endif
11144         do kkk=1,5
11145           do lll=1,3
11146             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11147             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11148             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11149             call transpose2(EUgC(1,1,k),auxmat(1,1))
11150             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11151      &        pizda1(1,1))
11152             vv1(1)=pizda1(1,1)-pizda1(2,2)
11153             vv1(2)=pizda1(1,2)+pizda1(2,1)
11154             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11155             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11156      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11157             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11158      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11159             s5=scalar2(vv(1),Dtobr2(1,i))
11160             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11161           enddo
11162         enddo
11163       enddo
11164       return
11165       end
11166 c----------------------------------------------------------------------------
11167       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11168       implicit real*8 (a-h,o-z)
11169       include 'DIMENSIONS'
11170       include 'COMMON.IOUNITS'
11171       include 'COMMON.CHAIN'
11172       include 'COMMON.DERIV'
11173       include 'COMMON.INTERACT'
11174       include 'COMMON.CONTACTS'
11175       include 'COMMON.CONTMAT'
11176       include 'COMMON.CORRMAT'
11177       include 'COMMON.TORSION'
11178       include 'COMMON.VAR'
11179       include 'COMMON.GEO'
11180       logical swap
11181       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11182      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11183       logical lprn
11184       common /kutas/ lprn
11185 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11186 C                                                                              C
11187 C      Parallel       Antiparallel                                             C
11188 C                                                                              C
11189 C          o             o                                                     C
11190 C     \   /l\           /j\   /                                                C
11191 C      \ /   \         /   \ /                                                 C
11192 C       o| o |         | o |o                                                  C
11193 C     \ j|/k\|      \  |/k\|l                                                  C
11194 C      \ /   \       \ /   \                                                   C
11195 C       o             o                                                        C
11196 C       i             i                                                        C
11197 C                                                                              C
11198 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11199 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11200 C AL 7/4/01 s1 would occur in the sixth-order moment,
11201 C           but not in a cluster cumulant
11202 #ifdef MOMENT
11203       s1=dip(1,jj,i)*dip(1,kk,k)
11204 #endif
11205       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11206       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11207       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11208       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11209       call transpose2(EUg(1,1,k),auxmat(1,1))
11210       call matmat2(ADtEA1(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 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11215 #ifdef MOMENT
11216       eello6_graph2=-(s1+s2+s3+s4)
11217 #else
11218       eello6_graph2=-(s2+s3+s4)
11219 #endif
11220 c      eello6_graph2=-s3
11221 C Derivatives in gamma(i-1)
11222       if (i.gt.1) then
11223 #ifdef MOMENT
11224         s1=dipderg(1,jj,i)*dip(1,kk,k)
11225 #endif
11226         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11227         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11228         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11229         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11230 #ifdef MOMENT
11231         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11232 #else
11233         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11234 #endif
11235 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11236       endif
11237 C Derivatives in gamma(k-1)
11238 #ifdef MOMENT
11239       s1=dip(1,jj,i)*dipderg(1,kk,k)
11240 #endif
11241       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11242       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11243       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11244       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11245       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11246       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11247       vv(1)=pizda(1,1)-pizda(2,2)
11248       vv(2)=pizda(1,2)+pizda(2,1)
11249       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11250 #ifdef MOMENT
11251       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11252 #else
11253       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11254 #endif
11255 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11256 C Derivatives in gamma(j-1) or gamma(l-1)
11257       if (j.gt.1) then
11258 #ifdef MOMENT
11259         s1=dipderg(3,jj,i)*dip(1,kk,k)
11260 #endif
11261         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11262         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11263         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11264         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11265         vv(1)=pizda(1,1)-pizda(2,2)
11266         vv(2)=pizda(1,2)+pizda(2,1)
11267         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11268 #ifdef MOMENT
11269         if (swap) then
11270           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11271         else
11272           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11273         endif
11274 #endif
11275         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11276 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11277       endif
11278 C Derivatives in gamma(l-1) or gamma(j-1)
11279       if (l.gt.1) then
11280 #ifdef MOMENT
11281         s1=dip(1,jj,i)*dipderg(3,kk,k)
11282 #endif
11283         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11284         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11285         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11286         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11287         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11288         vv(1)=pizda(1,1)-pizda(2,2)
11289         vv(2)=pizda(1,2)+pizda(2,1)
11290         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11291 #ifdef MOMENT
11292         if (swap) then
11293           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11294         else
11295           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11296         endif
11297 #endif
11298         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11299 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11300       endif
11301 C Cartesian derivatives.
11302       if (lprn) then
11303         write (2,*) 'In eello6_graph2'
11304         do iii=1,2
11305           write (2,*) 'iii=',iii
11306           do kkk=1,5
11307             write (2,*) 'kkk=',kkk
11308             do jjj=1,2
11309               write (2,'(3(2f10.5),5x)')
11310      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11311             enddo
11312           enddo
11313         enddo
11314       endif
11315       do iii=1,2
11316         do kkk=1,5
11317           do lll=1,3
11318 #ifdef MOMENT
11319             if (iii.eq.1) then
11320               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11321             else
11322               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11323             endif
11324 #endif
11325             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11326      &        auxvec(1))
11327             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11328             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11329      &        auxvec(1))
11330             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11331             call transpose2(EUg(1,1,k),auxmat(1,1))
11332             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11333      &        pizda(1,1))
11334             vv(1)=pizda(1,1)-pizda(2,2)
11335             vv(2)=pizda(1,2)+pizda(2,1)
11336             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11337 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11338 #ifdef MOMENT
11339             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11340 #else
11341             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11342 #endif
11343             if (swap) then
11344               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11345             else
11346               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11347             endif
11348           enddo
11349         enddo
11350       enddo
11351       return
11352       end
11353 c----------------------------------------------------------------------------
11354       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11355       implicit real*8 (a-h,o-z)
11356       include 'DIMENSIONS'
11357       include 'COMMON.IOUNITS'
11358       include 'COMMON.CHAIN'
11359       include 'COMMON.DERIV'
11360       include 'COMMON.INTERACT'
11361       include 'COMMON.CONTACTS'
11362       include 'COMMON.CONTMAT'
11363       include 'COMMON.CORRMAT'
11364       include 'COMMON.TORSION'
11365       include 'COMMON.VAR'
11366       include 'COMMON.GEO'
11367       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11368       logical swap
11369 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11370 C                                                                              C
11371 C      Parallel       Antiparallel                                             C
11372 C                                                                              C
11373 C          o             o                                                     C
11374 C         /l\   /   \   /j\                                                    C
11375 C        /   \ /     \ /   \                                                   C
11376 C       /| o |o       o| o |\                                                  C
11377 C       j|/k\|  /      |/k\|l /                                                C
11378 C        /   \ /       /   \ /                                                 C
11379 C       /     o       /     o                                                  C
11380 C       i             i                                                        C
11381 C                                                                              C
11382 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11383 C
11384 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11385 C           energy moment and not to the cluster cumulant.
11386       iti=itortyp(itype(i))
11387       if (j.lt.nres-1) then
11388         itj1=itype2loc(itype(j+1))
11389       else
11390         itj1=nloctyp
11391       endif
11392       itk=itype2loc(itype(k))
11393       itk1=itype2loc(itype(k+1))
11394       if (l.lt.nres-1) then
11395         itl1=itype2loc(itype(l+1))
11396       else
11397         itl1=nloctyp
11398       endif
11399 #ifdef MOMENT
11400       s1=dip(4,jj,i)*dip(4,kk,k)
11401 #endif
11402       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11403       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11404       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11405       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11406       call transpose2(EE(1,1,k),auxmat(1,1))
11407       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11408       vv(1)=pizda(1,1)+pizda(2,2)
11409       vv(2)=pizda(2,1)-pizda(1,2)
11410       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11411 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11412 cd     & "sum",-(s2+s3+s4)
11413 #ifdef MOMENT
11414       eello6_graph3=-(s1+s2+s3+s4)
11415 #else
11416       eello6_graph3=-(s2+s3+s4)
11417 #endif
11418 c      eello6_graph3=-s4
11419 C Derivatives in gamma(k-1)
11420       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11421       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11422       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11423       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11424 C Derivatives in gamma(l-1)
11425       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11426       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11427       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11428       vv(1)=pizda(1,1)+pizda(2,2)
11429       vv(2)=pizda(2,1)-pizda(1,2)
11430       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11431       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11432 C Cartesian derivatives.
11433       do iii=1,2
11434         do kkk=1,5
11435           do lll=1,3
11436 #ifdef MOMENT
11437             if (iii.eq.1) then
11438               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11439             else
11440               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11441             endif
11442 #endif
11443             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11444      &        auxvec(1))
11445             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11446             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11447      &        auxvec(1))
11448             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11449             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11450      &        pizda(1,1))
11451             vv(1)=pizda(1,1)+pizda(2,2)
11452             vv(2)=pizda(2,1)-pizda(1,2)
11453             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11454 #ifdef MOMENT
11455             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11456 #else
11457             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11458 #endif
11459             if (swap) then
11460               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11461             else
11462               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11463             endif
11464 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11465           enddo
11466         enddo
11467       enddo
11468       return
11469       end
11470 c----------------------------------------------------------------------------
11471       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11472       implicit real*8 (a-h,o-z)
11473       include 'DIMENSIONS'
11474       include 'COMMON.IOUNITS'
11475       include 'COMMON.CHAIN'
11476       include 'COMMON.DERIV'
11477       include 'COMMON.INTERACT'
11478       include 'COMMON.CONTACTS'
11479       include 'COMMON.CONTMAT'
11480       include 'COMMON.CORRMAT'
11481       include 'COMMON.TORSION'
11482       include 'COMMON.VAR'
11483       include 'COMMON.GEO'
11484       include 'COMMON.FFIELD'
11485       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11486      & auxvec1(2),auxmat1(2,2)
11487       logical swap
11488 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11489 C                                                                              C
11490 C      Parallel       Antiparallel                                             C
11491 C                                                                              C
11492 C          o             o                                                     C
11493 C         /l\   /   \   /j\                                                    C
11494 C        /   \ /     \ /   \                                                   C
11495 C       /| o |o       o| o |\                                                  C
11496 C     \ j|/k\|      \  |/k\|l                                                  C
11497 C      \ /   \       \ /   \                                                   C
11498 C       o     \       o     \                                                  C
11499 C       i             i                                                        C
11500 C                                                                              C
11501 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11502 C
11503 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11504 C           energy moment and not to the cluster cumulant.
11505 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11506       iti=itype2loc(itype(i))
11507       itj=itype2loc(itype(j))
11508       if (j.lt.nres-1) then
11509         itj1=itype2loc(itype(j+1))
11510       else
11511         itj1=nloctyp
11512       endif
11513       itk=itype2loc(itype(k))
11514       if (k.lt.nres-1) then
11515         itk1=itype2loc(itype(k+1))
11516       else
11517         itk1=nloctyp
11518       endif
11519       itl=itype2loc(itype(l))
11520       if (l.lt.nres-1) then
11521         itl1=itype2loc(itype(l+1))
11522       else
11523         itl1=nloctyp
11524       endif
11525 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11526 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11527 cd     & ' itl',itl,' itl1',itl1
11528 #ifdef MOMENT
11529       if (imat.eq.1) then
11530         s1=dip(3,jj,i)*dip(3,kk,k)
11531       else
11532         s1=dip(2,jj,j)*dip(2,kk,l)
11533       endif
11534 #endif
11535       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11536       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11537       if (j.eq.l+1) then
11538         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11539         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11540       else
11541         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11542         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11543       endif
11544       call transpose2(EUg(1,1,k),auxmat(1,1))
11545       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11546       vv(1)=pizda(1,1)-pizda(2,2)
11547       vv(2)=pizda(2,1)+pizda(1,2)
11548       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11549 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11550 #ifdef MOMENT
11551       eello6_graph4=-(s1+s2+s3+s4)
11552 #else
11553       eello6_graph4=-(s2+s3+s4)
11554 #endif
11555 C Derivatives in gamma(i-1)
11556       if (i.gt.1) then
11557 #ifdef MOMENT
11558         if (imat.eq.1) then
11559           s1=dipderg(2,jj,i)*dip(3,kk,k)
11560         else
11561           s1=dipderg(4,jj,j)*dip(2,kk,l)
11562         endif
11563 #endif
11564         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11565         if (j.eq.l+1) then
11566           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11567           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11568         else
11569           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11570           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11571         endif
11572         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11573         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11574 cd          write (2,*) 'turn6 derivatives'
11575 #ifdef MOMENT
11576           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11577 #else
11578           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11579 #endif
11580         else
11581 #ifdef MOMENT
11582           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11583 #else
11584           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11585 #endif
11586         endif
11587       endif
11588 C Derivatives in gamma(k-1)
11589 #ifdef MOMENT
11590       if (imat.eq.1) then
11591         s1=dip(3,jj,i)*dipderg(2,kk,k)
11592       else
11593         s1=dip(2,jj,j)*dipderg(4,kk,l)
11594       endif
11595 #endif
11596       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11597       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11598       if (j.eq.l+1) then
11599         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11600         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11601       else
11602         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11603         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11604       endif
11605       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11606       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11607       vv(1)=pizda(1,1)-pizda(2,2)
11608       vv(2)=pizda(2,1)+pizda(1,2)
11609       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11610       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11611 #ifdef MOMENT
11612         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11613 #else
11614         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11615 #endif
11616       else
11617 #ifdef MOMENT
11618         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11619 #else
11620         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11621 #endif
11622       endif
11623 C Derivatives in gamma(j-1) or gamma(l-1)
11624       if (l.eq.j+1 .and. l.gt.1) then
11625         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11626         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11627         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11628         vv(1)=pizda(1,1)-pizda(2,2)
11629         vv(2)=pizda(2,1)+pizda(1,2)
11630         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11631         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11632       else if (j.gt.1) then
11633         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11634         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11635         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11636         vv(1)=pizda(1,1)-pizda(2,2)
11637         vv(2)=pizda(2,1)+pizda(1,2)
11638         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11639         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11640           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11641         else
11642           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11643         endif
11644       endif
11645 C Cartesian derivatives.
11646       do iii=1,2
11647         do kkk=1,5
11648           do lll=1,3
11649 #ifdef MOMENT
11650             if (iii.eq.1) then
11651               if (imat.eq.1) then
11652                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11653               else
11654                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11655               endif
11656             else
11657               if (imat.eq.1) then
11658                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11659               else
11660                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11661               endif
11662             endif
11663 #endif
11664             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11665      &        auxvec(1))
11666             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11667             if (j.eq.l+1) then
11668               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11669      &          b1(1,j+1),auxvec(1))
11670               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11671             else
11672               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11673      &          b1(1,l+1),auxvec(1))
11674               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11675             endif
11676             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11677      &        pizda(1,1))
11678             vv(1)=pizda(1,1)-pizda(2,2)
11679             vv(2)=pizda(2,1)+pizda(1,2)
11680             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11681             if (swap) then
11682               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11683 #ifdef MOMENT
11684                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11685      &             -(s1+s2+s4)
11686 #else
11687                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11688      &             -(s2+s4)
11689 #endif
11690                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11691               else
11692 #ifdef MOMENT
11693                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11694 #else
11695                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11696 #endif
11697                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11698               endif
11699             else
11700 #ifdef MOMENT
11701               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11702 #else
11703               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11704 #endif
11705               if (l.eq.j+1) then
11706                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11707               else
11708                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11709               endif
11710             endif
11711           enddo
11712         enddo
11713       enddo
11714       return
11715       end
11716 c----------------------------------------------------------------------------
11717       double precision function eello_turn6(i,jj,kk)
11718       implicit real*8 (a-h,o-z)
11719       include 'DIMENSIONS'
11720       include 'COMMON.IOUNITS'
11721       include 'COMMON.CHAIN'
11722       include 'COMMON.DERIV'
11723       include 'COMMON.INTERACT'
11724       include 'COMMON.CONTACTS'
11725       include 'COMMON.CONTMAT'
11726       include 'COMMON.CORRMAT'
11727       include 'COMMON.TORSION'
11728       include 'COMMON.VAR'
11729       include 'COMMON.GEO'
11730       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11731      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11732      &  ggg1(3),ggg2(3)
11733       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11734      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11735 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11736 C           the respective energy moment and not to the cluster cumulant.
11737       s1=0.0d0
11738       s8=0.0d0
11739       s13=0.0d0
11740 c
11741       eello_turn6=0.0d0
11742       j=i+4
11743       k=i+1
11744       l=i+3
11745       iti=itype2loc(itype(i))
11746       itk=itype2loc(itype(k))
11747       itk1=itype2loc(itype(k+1))
11748       itl=itype2loc(itype(l))
11749       itj=itype2loc(itype(j))
11750 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11751 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11752 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11753 cd        eello6=0.0d0
11754 cd        return
11755 cd      endif
11756 cd      write (iout,*)
11757 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11758 cd     &   ' and',k,l
11759 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11760       do iii=1,2
11761         do kkk=1,5
11762           do lll=1,3
11763             derx_turn(lll,kkk,iii)=0.0d0
11764           enddo
11765         enddo
11766       enddo
11767 cd      eij=1.0d0
11768 cd      ekl=1.0d0
11769 cd      ekont=1.0d0
11770       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11771 cd      eello6_5=0.0d0
11772 cd      write (2,*) 'eello6_5',eello6_5
11773 #ifdef MOMENT
11774       call transpose2(AEA(1,1,1),auxmat(1,1))
11775       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11776       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11777       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11778 #endif
11779       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11780       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11781       s2 = scalar2(b1(1,k),vtemp1(1))
11782 #ifdef MOMENT
11783       call transpose2(AEA(1,1,2),atemp(1,1))
11784       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11785       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11786       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11787 #endif
11788       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11789       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11790       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11791 #ifdef MOMENT
11792       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11793       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11794       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11795       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11796       ss13 = scalar2(b1(1,k),vtemp4(1))
11797       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11798 #endif
11799 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11800 c      s1=0.0d0
11801 c      s2=0.0d0
11802 c      s8=0.0d0
11803 c      s12=0.0d0
11804 c      s13=0.0d0
11805       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11806 C Derivatives in gamma(i+2)
11807       s1d =0.0d0
11808       s8d =0.0d0
11809 #ifdef MOMENT
11810       call transpose2(AEA(1,1,1),auxmatd(1,1))
11811       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11812       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11813       call transpose2(AEAderg(1,1,2),atempd(1,1))
11814       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11815       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11816 #endif
11817       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11818       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11819       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11820 c      s1d=0.0d0
11821 c      s2d=0.0d0
11822 c      s8d=0.0d0
11823 c      s12d=0.0d0
11824 c      s13d=0.0d0
11825       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11826 C Derivatives in gamma(i+3)
11827 #ifdef MOMENT
11828       call transpose2(AEA(1,1,1),auxmatd(1,1))
11829       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11830       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11831       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11832 #endif
11833       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11834       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11835       s2d = scalar2(b1(1,k),vtemp1d(1))
11836 #ifdef MOMENT
11837       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11838       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11839 #endif
11840       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11841 #ifdef MOMENT
11842       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11843       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11844       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11845 #endif
11846 c      s1d=0.0d0
11847 c      s2d=0.0d0
11848 c      s8d=0.0d0
11849 c      s12d=0.0d0
11850 c      s13d=0.0d0
11851 #ifdef MOMENT
11852       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11853      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11854 #else
11855       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11856      &               -0.5d0*ekont*(s2d+s12d)
11857 #endif
11858 C Derivatives in gamma(i+4)
11859       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11860       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11861       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11862 #ifdef MOMENT
11863       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11864       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11865       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11866 #endif
11867 c      s1d=0.0d0
11868 c      s2d=0.0d0
11869 c      s8d=0.0d0
11870 C      s12d=0.0d0
11871 c      s13d=0.0d0
11872 #ifdef MOMENT
11873       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11874 #else
11875       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11876 #endif
11877 C Derivatives in gamma(i+5)
11878 #ifdef MOMENT
11879       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11880       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11881       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11882 #endif
11883       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11884       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11885       s2d = scalar2(b1(1,k),vtemp1d(1))
11886 #ifdef MOMENT
11887       call transpose2(AEA(1,1,2),atempd(1,1))
11888       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11889       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11890 #endif
11891       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11892       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11893 #ifdef MOMENT
11894       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11895       ss13d = scalar2(b1(1,k),vtemp4d(1))
11896       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11897 #endif
11898 c      s1d=0.0d0
11899 c      s2d=0.0d0
11900 c      s8d=0.0d0
11901 c      s12d=0.0d0
11902 c      s13d=0.0d0
11903 #ifdef MOMENT
11904       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11905      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11906 #else
11907       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11908      &               -0.5d0*ekont*(s2d+s12d)
11909 #endif
11910 C Cartesian derivatives
11911       do iii=1,2
11912         do kkk=1,5
11913           do lll=1,3
11914 #ifdef MOMENT
11915             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11916             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11917             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11918 #endif
11919             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11920             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11921      &          vtemp1d(1))
11922             s2d = scalar2(b1(1,k),vtemp1d(1))
11923 #ifdef MOMENT
11924             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11925             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11926             s8d = -(atempd(1,1)+atempd(2,2))*
11927      &           scalar2(cc(1,1,l),vtemp2(1))
11928 #endif
11929             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11930      &           auxmatd(1,1))
11931             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11932             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11933 c      s1d=0.0d0
11934 c      s2d=0.0d0
11935 c      s8d=0.0d0
11936 c      s12d=0.0d0
11937 c      s13d=0.0d0
11938 #ifdef MOMENT
11939             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11940      &        - 0.5d0*(s1d+s2d)
11941 #else
11942             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11943      &        - 0.5d0*s2d
11944 #endif
11945 #ifdef MOMENT
11946             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11947      &        - 0.5d0*(s8d+s12d)
11948 #else
11949             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11950      &        - 0.5d0*s12d
11951 #endif
11952           enddo
11953         enddo
11954       enddo
11955 #ifdef MOMENT
11956       do kkk=1,5
11957         do lll=1,3
11958           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11959      &      achuj_tempd(1,1))
11960           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11961           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11962           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11963           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11964           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11965      &      vtemp4d(1))
11966           ss13d = scalar2(b1(1,k),vtemp4d(1))
11967           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11968           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11969         enddo
11970       enddo
11971 #endif
11972 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11973 cd     &  16*eel_turn6_num
11974 cd      goto 1112
11975       if (j.lt.nres-1) then
11976         j1=j+1
11977         j2=j-1
11978       else
11979         j1=j-1
11980         j2=j-2
11981       endif
11982       if (l.lt.nres-1) then
11983         l1=l+1
11984         l2=l-1
11985       else
11986         l1=l-1
11987         l2=l-2
11988       endif
11989       do ll=1,3
11990 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11991 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11992 cgrad        ghalf=0.5d0*ggg1(ll)
11993 cd        ghalf=0.0d0
11994         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11995         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11996         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11997      &    +ekont*derx_turn(ll,2,1)
11998         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11999         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
12000      &    +ekont*derx_turn(ll,4,1)
12001         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
12002         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
12003         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
12004 cgrad        ghalf=0.5d0*ggg2(ll)
12005 cd        ghalf=0.0d0
12006         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
12007      &    +ekont*derx_turn(ll,2,2)
12008         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
12009         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
12010      &    +ekont*derx_turn(ll,4,2)
12011         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
12012         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
12013         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
12014       enddo
12015 cd      goto 1112
12016 cgrad      do m=i+1,j-1
12017 cgrad        do ll=1,3
12018 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
12019 cgrad        enddo
12020 cgrad      enddo
12021 cgrad      do m=k+1,l-1
12022 cgrad        do ll=1,3
12023 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
12024 cgrad        enddo
12025 cgrad      enddo
12026 cgrad1112  continue
12027 cgrad      do m=i+2,j2
12028 cgrad        do ll=1,3
12029 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
12030 cgrad        enddo
12031 cgrad      enddo
12032 cgrad      do m=k+2,l2
12033 cgrad        do ll=1,3
12034 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
12035 cgrad        enddo
12036 cgrad      enddo
12037 cd      do iii=1,nres-3
12038 cd        write (2,*) iii,g_corr6_loc(iii)
12039 cd      enddo
12040       eello_turn6=ekont*eel_turn6
12041 cd      write (2,*) 'ekont',ekont
12042 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
12043       return
12044       end
12045 C-----------------------------------------------------------------------------
12046 #endif
12047       double precision function scalar(u,v)
12048 !DIR$ INLINEALWAYS scalar
12049 #ifndef OSF
12050 cDEC$ ATTRIBUTES FORCEINLINE::scalar
12051 #endif
12052       implicit none
12053       double precision u(3),v(3)
12054 cd      double precision sc
12055 cd      integer i
12056 cd      sc=0.0d0
12057 cd      do i=1,3
12058 cd        sc=sc+u(i)*v(i)
12059 cd      enddo
12060 cd      scalar=sc
12061
12062       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12063       return
12064       end
12065 crc-------------------------------------------------
12066       SUBROUTINE MATVEC2(A1,V1,V2)
12067 !DIR$ INLINEALWAYS MATVEC2
12068 #ifndef OSF
12069 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12070 #endif
12071       implicit real*8 (a-h,o-z)
12072       include 'DIMENSIONS'
12073       DIMENSION A1(2,2),V1(2),V2(2)
12074 c      DO 1 I=1,2
12075 c        VI=0.0
12076 c        DO 3 K=1,2
12077 c    3     VI=VI+A1(I,K)*V1(K)
12078 c        Vaux(I)=VI
12079 c    1 CONTINUE
12080
12081       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12082       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12083
12084       v2(1)=vaux1
12085       v2(2)=vaux2
12086       END
12087 C---------------------------------------
12088       SUBROUTINE MATMAT2(A1,A2,A3)
12089 #ifndef OSF
12090 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12091 #endif
12092       implicit real*8 (a-h,o-z)
12093       include 'DIMENSIONS'
12094       DIMENSION A1(2,2),A2(2,2),A3(2,2)
12095 c      DIMENSION AI3(2,2)
12096 c        DO  J=1,2
12097 c          A3IJ=0.0
12098 c          DO K=1,2
12099 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
12100 c          enddo
12101 c          A3(I,J)=A3IJ
12102 c       enddo
12103 c      enddo
12104
12105       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12106       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12107       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12108       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12109
12110       A3(1,1)=AI3_11
12111       A3(2,1)=AI3_21
12112       A3(1,2)=AI3_12
12113       A3(2,2)=AI3_22
12114       END
12115
12116 c-------------------------------------------------------------------------
12117       double precision function scalar2(u,v)
12118 !DIR$ INLINEALWAYS scalar2
12119       implicit none
12120       double precision u(2),v(2)
12121       double precision sc
12122       integer i
12123       scalar2=u(1)*v(1)+u(2)*v(2)
12124       return
12125       end
12126
12127 C-----------------------------------------------------------------------------
12128
12129       subroutine transpose2(a,at)
12130 !DIR$ INLINEALWAYS transpose2
12131 #ifndef OSF
12132 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12133 #endif
12134       implicit none
12135       double precision a(2,2),at(2,2)
12136       at(1,1)=a(1,1)
12137       at(1,2)=a(2,1)
12138       at(2,1)=a(1,2)
12139       at(2,2)=a(2,2)
12140       return
12141       end
12142 c--------------------------------------------------------------------------
12143       subroutine transpose(n,a,at)
12144       implicit none
12145       integer n,i,j
12146       double precision a(n,n),at(n,n)
12147       do i=1,n
12148         do j=1,n
12149           at(j,i)=a(i,j)
12150         enddo
12151       enddo
12152       return
12153       end
12154 C---------------------------------------------------------------------------
12155       subroutine prodmat3(a1,a2,kk,transp,prod)
12156 !DIR$ INLINEALWAYS prodmat3
12157 #ifndef OSF
12158 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12159 #endif
12160       implicit none
12161       integer i,j
12162       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12163       logical transp
12164 crc      double precision auxmat(2,2),prod_(2,2)
12165
12166       if (transp) then
12167 crc        call transpose2(kk(1,1),auxmat(1,1))
12168 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12169 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12170
12171            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12172      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12173            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12174      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12175            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12176      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12177            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12178      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12179
12180       else
12181 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12182 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12183
12184            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12185      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12186            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12187      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12188            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12189      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12190            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12191      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12192
12193       endif
12194 c      call transpose2(a2(1,1),a2t(1,1))
12195
12196 crc      print *,transp
12197 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12198 crc      print *,((prod(i,j),i=1,2),j=1,2)
12199
12200       return
12201       end
12202 CCC----------------------------------------------
12203       subroutine Eliptransfer(eliptran)
12204       implicit real*8 (a-h,o-z)
12205       include 'DIMENSIONS'
12206       include 'COMMON.GEO'
12207       include 'COMMON.VAR'
12208       include 'COMMON.LOCAL'
12209       include 'COMMON.CHAIN'
12210       include 'COMMON.DERIV'
12211       include 'COMMON.NAMES'
12212       include 'COMMON.INTERACT'
12213       include 'COMMON.IOUNITS'
12214       include 'COMMON.CALC'
12215       include 'COMMON.CONTROL'
12216       include 'COMMON.SPLITELE'
12217       include 'COMMON.SBRIDGE'
12218 C this is done by Adasko
12219 C      print *,"wchodze"
12220 C structure of box:
12221 C      water
12222 C--bordliptop-- buffore starts
12223 C--bufliptop--- here true lipid starts
12224 C      lipid
12225 C--buflipbot--- lipid ends buffore starts
12226 C--bordlipbot--buffore ends
12227       eliptran=0.0
12228       do i=ilip_start,ilip_end
12229 C       do i=1,1
12230         if (itype(i).eq.ntyp1) cycle
12231
12232         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12233         if (positi.le.0.0) positi=positi+boxzsize
12234 C        print *,i
12235 C first for peptide groups
12236 c for each residue check if it is in lipid or lipid water border area
12237        if ((positi.gt.bordlipbot)
12238      &.and.(positi.lt.bordliptop)) then
12239 C the energy transfer exist
12240         if (positi.lt.buflipbot) then
12241 C what fraction I am in
12242          fracinbuf=1.0d0-
12243      &        ((positi-bordlipbot)/lipbufthick)
12244 C lipbufthick is thickenes of lipid buffore
12245          sslip=sscalelip(fracinbuf)
12246          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12247          eliptran=eliptran+sslip*pepliptran
12248          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12249          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12250 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12251
12252 C        print *,"doing sccale for lower part"
12253 C         print *,i,sslip,fracinbuf,ssgradlip
12254         elseif (positi.gt.bufliptop) then
12255          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12256          sslip=sscalelip(fracinbuf)
12257          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12258          eliptran=eliptran+sslip*pepliptran
12259          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12260          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12261 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12262 C          print *, "doing sscalefor top part"
12263 C         print *,i,sslip,fracinbuf,ssgradlip
12264         else
12265          eliptran=eliptran+pepliptran
12266 C         print *,"I am in true lipid"
12267         endif
12268 C       else
12269 C       eliptran=elpitran+0.0 ! I am in water
12270        endif
12271        enddo
12272 C       print *, "nic nie bylo w lipidzie?"
12273 C now multiply all by the peptide group transfer factor
12274 C       eliptran=eliptran*pepliptran
12275 C now the same for side chains
12276 CV       do i=1,1
12277        do i=ilip_start,ilip_end
12278         if (itype(i).eq.ntyp1) cycle
12279         positi=(mod(c(3,i+nres),boxzsize))
12280         if (positi.le.0) positi=positi+boxzsize
12281 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12282 c for each residue check if it is in lipid or lipid water border area
12283 C       respos=mod(c(3,i+nres),boxzsize)
12284 C       print *,positi,bordlipbot,buflipbot
12285        if ((positi.gt.bordlipbot)
12286      & .and.(positi.lt.bordliptop)) then
12287 C the energy transfer exist
12288         if (positi.lt.buflipbot) then
12289          fracinbuf=1.0d0-
12290      &     ((positi-bordlipbot)/lipbufthick)
12291 C lipbufthick is thickenes of lipid buffore
12292          sslip=sscalelip(fracinbuf)
12293          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12294          eliptran=eliptran+sslip*liptranene(itype(i))
12295          gliptranx(3,i)=gliptranx(3,i)
12296      &+ssgradlip*liptranene(itype(i))
12297          gliptranc(3,i-1)= gliptranc(3,i-1)
12298      &+ssgradlip*liptranene(itype(i))
12299 C         print *,"doing sccale for lower part"
12300         elseif (positi.gt.bufliptop) then
12301          fracinbuf=1.0d0-
12302      &((bordliptop-positi)/lipbufthick)
12303          sslip=sscalelip(fracinbuf)
12304          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12305          eliptran=eliptran+sslip*liptranene(itype(i))
12306          gliptranx(3,i)=gliptranx(3,i)
12307      &+ssgradlip*liptranene(itype(i))
12308          gliptranc(3,i-1)= gliptranc(3,i-1)
12309      &+ssgradlip*liptranene(itype(i))
12310 C          print *, "doing sscalefor top part",sslip,fracinbuf
12311         else
12312          eliptran=eliptran+liptranene(itype(i))
12313 C         print *,"I am in true lipid"
12314         endif
12315         endif ! if in lipid or buffor
12316 C       else
12317 C       eliptran=elpitran+0.0 ! I am in water
12318        enddo
12319        return
12320        end
12321 C---------------------------------------------------------
12322 C AFM soubroutine for constant force
12323        subroutine AFMforce(Eafmforce)
12324        implicit real*8 (a-h,o-z)
12325       include 'DIMENSIONS'
12326       include 'COMMON.GEO'
12327       include 'COMMON.VAR'
12328       include 'COMMON.LOCAL'
12329       include 'COMMON.CHAIN'
12330       include 'COMMON.DERIV'
12331       include 'COMMON.NAMES'
12332       include 'COMMON.INTERACT'
12333       include 'COMMON.IOUNITS'
12334       include 'COMMON.CALC'
12335       include 'COMMON.CONTROL'
12336       include 'COMMON.SPLITELE'
12337       include 'COMMON.SBRIDGE'
12338       real*8 diffafm(3)
12339       dist=0.0d0
12340       Eafmforce=0.0d0
12341       do i=1,3
12342       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12343       dist=dist+diffafm(i)**2
12344       enddo
12345       dist=dsqrt(dist)
12346       Eafmforce=-forceAFMconst*(dist-distafminit)
12347       do i=1,3
12348       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12349       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12350       enddo
12351 C      print *,'AFM',Eafmforce
12352       return
12353       end
12354 C---------------------------------------------------------
12355 C AFM subroutine with pseudoconstant velocity
12356        subroutine AFMvel(Eafmforce)
12357        implicit real*8 (a-h,o-z)
12358       include 'DIMENSIONS'
12359       include 'COMMON.GEO'
12360       include 'COMMON.VAR'
12361       include 'COMMON.LOCAL'
12362       include 'COMMON.CHAIN'
12363       include 'COMMON.DERIV'
12364       include 'COMMON.NAMES'
12365       include 'COMMON.INTERACT'
12366       include 'COMMON.IOUNITS'
12367       include 'COMMON.CALC'
12368       include 'COMMON.CONTROL'
12369       include 'COMMON.SPLITELE'
12370       include 'COMMON.SBRIDGE'
12371       real*8 diffafm(3)
12372 C Only for check grad COMMENT if not used for checkgrad
12373 C      totT=3.0d0
12374 C--------------------------------------------------------
12375 C      print *,"wchodze"
12376       dist=0.0d0
12377       Eafmforce=0.0d0
12378       do i=1,3
12379       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12380       dist=dist+diffafm(i)**2
12381       enddo
12382       dist=dsqrt(dist)
12383       Eafmforce=0.5d0*forceAFMconst
12384      & *(distafminit+totTafm*velAFMconst-dist)**2
12385 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12386       do i=1,3
12387       gradafm(i,afmend-1)=-forceAFMconst*
12388      &(distafminit+totTafm*velAFMconst-dist)
12389      &*diffafm(i)/dist
12390       gradafm(i,afmbeg-1)=forceAFMconst*
12391      &(distafminit+totTafm*velAFMconst-dist)
12392      &*diffafm(i)/dist
12393       enddo
12394 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12395       return
12396       end
12397 C-----------------------------------------------------------
12398 C first for shielding is setting of function of side-chains
12399        subroutine set_shield_fac
12400       implicit real*8 (a-h,o-z)
12401       include 'DIMENSIONS'
12402       include 'COMMON.CHAIN'
12403       include 'COMMON.DERIV'
12404       include 'COMMON.IOUNITS'
12405       include 'COMMON.SHIELD'
12406       include 'COMMON.INTERACT'
12407 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12408       double precision div77_81/0.974996043d0/,
12409      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12410
12411 C the vector between center of side_chain and peptide group
12412        double precision pep_side(3),long,side_calf(3),
12413      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12414      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12415 C the line belowe needs to be changed for FGPROC>1
12416       do i=1,nres-1
12417       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12418       ishield_list(i)=0
12419 Cif there two consequtive dummy atoms there is no peptide group between them
12420 C the line below has to be changed for FGPROC>1
12421       VolumeTotal=0.0
12422       do k=1,nres
12423        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12424        dist_pep_side=0.0
12425        dist_side_calf=0.0
12426        do j=1,3
12427 C first lets set vector conecting the ithe side-chain with kth side-chain
12428       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12429 C      pep_side(j)=2.0d0
12430 C and vector conecting the side-chain with its proper calfa
12431       side_calf(j)=c(j,k+nres)-c(j,k)
12432 C      side_calf(j)=2.0d0
12433       pept_group(j)=c(j,i)-c(j,i+1)
12434 C lets have their lenght
12435       dist_pep_side=pep_side(j)**2+dist_pep_side
12436       dist_side_calf=dist_side_calf+side_calf(j)**2
12437       dist_pept_group=dist_pept_group+pept_group(j)**2
12438       enddo
12439        dist_pep_side=dsqrt(dist_pep_side)
12440        dist_pept_group=dsqrt(dist_pept_group)
12441        dist_side_calf=dsqrt(dist_side_calf)
12442       do j=1,3
12443         pep_side_norm(j)=pep_side(j)/dist_pep_side
12444         side_calf_norm(j)=dist_side_calf
12445       enddo
12446 C now sscale fraction
12447        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12448 C       print *,buff_shield,"buff"
12449 C now sscale
12450         if (sh_frac_dist.le.0.0) cycle
12451 C If we reach here it means that this side chain reaches the shielding sphere
12452 C Lets add him to the list for gradient
12453         ishield_list(i)=ishield_list(i)+1
12454 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12455 C this list is essential otherwise problem would be O3
12456         shield_list(ishield_list(i),i)=k
12457 C Lets have the sscale value
12458         if (sh_frac_dist.gt.1.0) then
12459          scale_fac_dist=1.0d0
12460          do j=1,3
12461          sh_frac_dist_grad(j)=0.0d0
12462          enddo
12463         else
12464          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12465      &                   *(2.0*sh_frac_dist-3.0d0)
12466          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12467      &                  /dist_pep_side/buff_shield*0.5
12468 C remember for the final gradient multiply sh_frac_dist_grad(j)
12469 C for side_chain by factor -2 !
12470          do j=1,3
12471          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12472 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12473 C     &                    sh_frac_dist_grad(j)
12474          enddo
12475         endif
12476 C        if ((i.eq.3).and.(k.eq.2)) then
12477 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12478 C     & ,"TU"
12479 C        endif
12480
12481 C this is what is now we have the distance scaling now volume...
12482       short=short_r_sidechain(itype(k))
12483       long=long_r_sidechain(itype(k))
12484       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12485 C now costhet_grad
12486 C       costhet=0.0d0
12487        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12488 C       costhet_fac=0.0d0
12489        do j=1,3
12490          costhet_grad(j)=costhet_fac*pep_side(j)
12491        enddo
12492 C remember for the final gradient multiply costhet_grad(j)
12493 C for side_chain by factor -2 !
12494 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12495 C pep_side0pept_group is vector multiplication
12496       pep_side0pept_group=0.0
12497       do j=1,3
12498       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12499       enddo
12500       cosalfa=(pep_side0pept_group/
12501      & (dist_pep_side*dist_side_calf))
12502       fac_alfa_sin=1.0-cosalfa**2
12503       fac_alfa_sin=dsqrt(fac_alfa_sin)
12504       rkprim=fac_alfa_sin*(long-short)+short
12505 C now costhet_grad
12506        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12507        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12508
12509        do j=1,3
12510          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12511      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12512      &*(long-short)/fac_alfa_sin*cosalfa/
12513      &((dist_pep_side*dist_side_calf))*
12514      &((side_calf(j))-cosalfa*
12515      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12516
12517         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12518      &*(long-short)/fac_alfa_sin*cosalfa
12519      &/((dist_pep_side*dist_side_calf))*
12520      &(pep_side(j)-
12521      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12522        enddo
12523
12524       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12525      &                    /VSolvSphere_div
12526      &                    *wshield
12527 C now the gradient...
12528 C grad_shield is gradient of Calfa for peptide groups
12529 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12530 C     &               costhet,cosphi
12531 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12532 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12533       do j=1,3
12534       grad_shield(j,i)=grad_shield(j,i)
12535 C gradient po skalowaniu
12536      &                +(sh_frac_dist_grad(j)
12537 C  gradient po costhet
12538      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12539      &-scale_fac_dist*(cosphi_grad_long(j))
12540      &/(1.0-cosphi) )*div77_81
12541      &*VofOverlap
12542 C grad_shield_side is Cbeta sidechain gradient
12543       grad_shield_side(j,ishield_list(i),i)=
12544      &        (sh_frac_dist_grad(j)*(-2.0d0)
12545      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12546      &       +scale_fac_dist*(cosphi_grad_long(j))
12547      &        *2.0d0/(1.0-cosphi))
12548      &        *div77_81*VofOverlap
12549
12550        grad_shield_loc(j,ishield_list(i),i)=
12551      &   scale_fac_dist*cosphi_grad_loc(j)
12552      &        *2.0d0/(1.0-cosphi)
12553      &        *div77_81*VofOverlap
12554       enddo
12555       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12556       enddo
12557       fac_shield(i)=VolumeTotal*div77_81+div4_81
12558 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12559       enddo
12560       return
12561       end
12562 C--------------------------------------------------------------------------
12563       double precision function tschebyshev(m,n,x,y)
12564       implicit none
12565       include "DIMENSIONS"
12566       integer i,m,n
12567       double precision x(n),y,yy(0:maxvar),aux
12568 c Tschebyshev polynomial. Note that the first term is omitted
12569 c m=0: the constant term is included
12570 c m=1: the constant term is not included
12571       yy(0)=1.0d0
12572       yy(1)=y
12573       do i=2,n
12574         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12575       enddo
12576       aux=0.0d0
12577       do i=m,n
12578         aux=aux+x(i)*yy(i)
12579       enddo
12580       tschebyshev=aux
12581       return
12582       end
12583 C--------------------------------------------------------------------------
12584       double precision function gradtschebyshev(m,n,x,y)
12585       implicit none
12586       include "DIMENSIONS"
12587       integer i,m,n
12588       double precision x(n+1),y,yy(0:maxvar),aux
12589 c Tschebyshev polynomial. Note that the first term is omitted
12590 c m=0: the constant term is included
12591 c m=1: the constant term is not included
12592       yy(0)=1.0d0
12593       yy(1)=2.0d0*y
12594       do i=2,n
12595         yy(i)=2*y*yy(i-1)-yy(i-2)
12596       enddo
12597       aux=0.0d0
12598       do i=m,n
12599         aux=aux+x(i+1)*yy(i)*(i+1)
12600 C        print *, x(i+1),yy(i),i
12601       enddo
12602       gradtschebyshev=aux
12603       return
12604       end
12605 C------------------------------------------------------------------------
12606 C first for shielding is setting of function of side-chains
12607        subroutine set_shield_fac2
12608       implicit real*8 (a-h,o-z)
12609       include 'DIMENSIONS'
12610       include 'COMMON.CHAIN'
12611       include 'COMMON.DERIV'
12612       include 'COMMON.IOUNITS'
12613       include 'COMMON.SHIELD'
12614       include 'COMMON.INTERACT'
12615 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12616       double precision div77_81/0.974996043d0/,
12617      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12618
12619 C the vector between center of side_chain and peptide group
12620        double precision pep_side(3),long,side_calf(3),
12621      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12622      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12623 C the line belowe needs to be changed for FGPROC>1
12624       do i=1,nres-1
12625       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12626       ishield_list(i)=0
12627 Cif there two consequtive dummy atoms there is no peptide group between them
12628 C the line below has to be changed for FGPROC>1
12629       VolumeTotal=0.0
12630       do k=1,nres
12631        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12632        dist_pep_side=0.0
12633        dist_side_calf=0.0
12634        do j=1,3
12635 C first lets set vector conecting the ithe side-chain with kth side-chain
12636       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12637 C      pep_side(j)=2.0d0
12638 C and vector conecting the side-chain with its proper calfa
12639       side_calf(j)=c(j,k+nres)-c(j,k)
12640 C      side_calf(j)=2.0d0
12641       pept_group(j)=c(j,i)-c(j,i+1)
12642 C lets have their lenght
12643       dist_pep_side=pep_side(j)**2+dist_pep_side
12644       dist_side_calf=dist_side_calf+side_calf(j)**2
12645       dist_pept_group=dist_pept_group+pept_group(j)**2
12646       enddo
12647        dist_pep_side=dsqrt(dist_pep_side)
12648        dist_pept_group=dsqrt(dist_pept_group)
12649        dist_side_calf=dsqrt(dist_side_calf)
12650       do j=1,3
12651         pep_side_norm(j)=pep_side(j)/dist_pep_side
12652         side_calf_norm(j)=dist_side_calf
12653       enddo
12654 C now sscale fraction
12655        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12656 C       print *,buff_shield,"buff"
12657 C now sscale
12658         if (sh_frac_dist.le.0.0) cycle
12659 C If we reach here it means that this side chain reaches the shielding sphere
12660 C Lets add him to the list for gradient
12661         ishield_list(i)=ishield_list(i)+1
12662 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12663 C this list is essential otherwise problem would be O3
12664         shield_list(ishield_list(i),i)=k
12665 C Lets have the sscale value
12666         if (sh_frac_dist.gt.1.0) then
12667          scale_fac_dist=1.0d0
12668          do j=1,3
12669          sh_frac_dist_grad(j)=0.0d0
12670          enddo
12671         else
12672          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12673      &                   *(2.0d0*sh_frac_dist-3.0d0)
12674          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12675      &                  /dist_pep_side/buff_shield*0.5d0
12676 C remember for the final gradient multiply sh_frac_dist_grad(j)
12677 C for side_chain by factor -2 !
12678          do j=1,3
12679          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12680 C         sh_frac_dist_grad(j)=0.0d0
12681 C         scale_fac_dist=1.0d0
12682 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12683 C     &                    sh_frac_dist_grad(j)
12684          enddo
12685         endif
12686 C this is what is now we have the distance scaling now volume...
12687       short=short_r_sidechain(itype(k))
12688       long=long_r_sidechain(itype(k))
12689       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12690       sinthet=short/dist_pep_side*costhet
12691 C now costhet_grad
12692 C       costhet=0.6d0
12693 C       sinthet=0.8
12694        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12695 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12696 C     &             -short/dist_pep_side**2/costhet)
12697 C       costhet_fac=0.0d0
12698        do j=1,3
12699          costhet_grad(j)=costhet_fac*pep_side(j)
12700        enddo
12701 C remember for the final gradient multiply costhet_grad(j)
12702 C for side_chain by factor -2 !
12703 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12704 C pep_side0pept_group is vector multiplication
12705       pep_side0pept_group=0.0d0
12706       do j=1,3
12707       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12708       enddo
12709       cosalfa=(pep_side0pept_group/
12710      & (dist_pep_side*dist_side_calf))
12711       fac_alfa_sin=1.0d0-cosalfa**2
12712       fac_alfa_sin=dsqrt(fac_alfa_sin)
12713       rkprim=fac_alfa_sin*(long-short)+short
12714 C      rkprim=short
12715
12716 C now costhet_grad
12717        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12718 C       cosphi=0.6
12719        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12720        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12721      &      dist_pep_side**2)
12722 C       sinphi=0.8
12723        do j=1,3
12724          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12725      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12726      &*(long-short)/fac_alfa_sin*cosalfa/
12727      &((dist_pep_side*dist_side_calf))*
12728      &((side_calf(j))-cosalfa*
12729      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12730 C       cosphi_grad_long(j)=0.0d0
12731         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12732      &*(long-short)/fac_alfa_sin*cosalfa
12733      &/((dist_pep_side*dist_side_calf))*
12734      &(pep_side(j)-
12735      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12736 C       cosphi_grad_loc(j)=0.0d0
12737        enddo
12738 C      print *,sinphi,sinthet
12739 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12740 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12741       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12742      &                    /VSolvSphere_div
12743 C     &                    *wshield
12744 C now the gradient...
12745       do j=1,3
12746       grad_shield(j,i)=grad_shield(j,i)
12747 C gradient po skalowaniu
12748      &                +(sh_frac_dist_grad(j)*VofOverlap
12749 C  gradient po costhet
12750      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12751      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12752      &       sinphi/sinthet*costhet*costhet_grad(j)
12753      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12754      & )*wshield
12755 C grad_shield_side is Cbeta sidechain gradient
12756       grad_shield_side(j,ishield_list(i),i)=
12757      &        (sh_frac_dist_grad(j)*(-2.0d0)
12758      &        *VofOverlap
12759      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12760      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12761      &       sinphi/sinthet*costhet*costhet_grad(j)
12762      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12763      &       )*wshield
12764
12765        grad_shield_loc(j,ishield_list(i),i)=
12766      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12767      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12768      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12769      &        ))
12770      &        *wshield
12771       enddo
12772 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12773 c     & scale_fac_dist
12774       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12775       enddo
12776       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12777 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12778 c     &  " wshield",wshield
12779 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12780       enddo
12781       return
12782       end
12783 C-----------------------------------------------------------------------
12784 C-----------------------------------------------------------
12785 C This subroutine is to mimic the histone like structure but as well can be
12786 C utilizet to nanostructures (infinit) small modification has to be used to
12787 C make it finite (z gradient at the ends has to be changes as well as the x,y
12788 C gradient has to be modified at the ends
12789 C The energy function is Kihara potential
12790 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12791 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12792 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12793 C simple Kihara potential
12794       subroutine calctube(Etube)
12795        implicit real*8 (a-h,o-z)
12796       include 'DIMENSIONS'
12797       include 'COMMON.GEO'
12798       include 'COMMON.VAR'
12799       include 'COMMON.LOCAL'
12800       include 'COMMON.CHAIN'
12801       include 'COMMON.DERIV'
12802       include 'COMMON.NAMES'
12803       include 'COMMON.INTERACT'
12804       include 'COMMON.IOUNITS'
12805       include 'COMMON.CALC'
12806       include 'COMMON.CONTROL'
12807       include 'COMMON.SPLITELE'
12808       include 'COMMON.SBRIDGE'
12809       double precision tub_r,vectube(3),enetube(maxres*2)
12810       Etube=0.0d0
12811       do i=1,2*nres
12812         enetube(i)=0.0d0
12813       enddo
12814 C first we calculate the distance from tube center
12815 C first sugare-phosphate group for NARES this would be peptide group
12816 C for UNRES
12817       do i=1,nres
12818 C lets ommit dummy atoms for now
12819        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12820 C now calculate distance from center of tube and direction vectors
12821       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12822           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12823       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12824           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12825       vectube(1)=vectube(1)-tubecenter(1)
12826       vectube(2)=vectube(2)-tubecenter(2)
12827
12828 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12829 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12830
12831 C as the tube is infinity we do not calculate the Z-vector use of Z
12832 C as chosen axis
12833       vectube(3)=0.0d0
12834 C now calculte the distance
12835        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12836 C now normalize vector
12837       vectube(1)=vectube(1)/tub_r
12838       vectube(2)=vectube(2)/tub_r
12839 C calculte rdiffrence between r and r0
12840       rdiff=tub_r-tubeR0
12841 C and its 6 power
12842       rdiff6=rdiff**6.0d0
12843 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12844        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12845 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12846 C       print *,rdiff,rdiff6,pep_aa_tube
12847 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12848 C now we calculate gradient
12849        fac=(-12.0d0*pep_aa_tube/rdiff6+
12850      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12851 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12852 C     &rdiff,fac
12853
12854 C now direction of gg_tube vector
12855         do j=1,3
12856         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12857         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12858         enddo
12859         enddo
12860 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12861         do i=1,nres
12862 C Lets not jump over memory as we use many times iti
12863          iti=itype(i)
12864 C lets ommit dummy atoms for now
12865          if ((iti.eq.ntyp1)
12866 C in UNRES uncomment the line below as GLY has no side-chain...
12867 C      .or.(iti.eq.10)
12868      &   ) cycle
12869           vectube(1)=c(1,i+nres)
12870           vectube(1)=mod(vectube(1),boxxsize)
12871           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12872           vectube(2)=c(2,i+nres)
12873           vectube(2)=mod(vectube(2),boxxsize)
12874           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12875
12876       vectube(1)=vectube(1)-tubecenter(1)
12877       vectube(2)=vectube(2)-tubecenter(2)
12878
12879 C as the tube is infinity we do not calculate the Z-vector use of Z
12880 C as chosen axis
12881       vectube(3)=0.0d0
12882 C now calculte the distance
12883        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12884 C now normalize vector
12885       vectube(1)=vectube(1)/tub_r
12886       vectube(2)=vectube(2)/tub_r
12887 C calculte rdiffrence between r and r0
12888       rdiff=tub_r-tubeR0
12889 C and its 6 power
12890       rdiff6=rdiff**6.0d0
12891 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12892        sc_aa_tube=sc_aa_tube_par(iti)
12893        sc_bb_tube=sc_bb_tube_par(iti)
12894        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12895 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12896 C now we calculate gradient
12897        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12898      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12899 C now direction of gg_tube vector
12900          do j=1,3
12901           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12902           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12903          enddo
12904         enddo
12905         do i=1,2*nres
12906           Etube=Etube+enetube(i)
12907         enddo
12908 C        print *,"ETUBE", etube
12909         return
12910         end
12911 C TO DO 1) add to total energy
12912 C       2) add to gradient summation
12913 C       3) add reading parameters (AND of course oppening of PARAM file)
12914 C       4) add reading the center of tube
12915 C       5) add COMMONs
12916 C       6) add to zerograd
12917
12918 C-----------------------------------------------------------------------
12919 C-----------------------------------------------------------
12920 C This subroutine is to mimic the histone like structure but as well can be
12921 C utilizet to nanostructures (infinit) small modification has to be used to
12922 C make it finite (z gradient at the ends has to be changes as well as the x,y
12923 C gradient has to be modified at the ends
12924 C The energy function is Kihara potential
12925 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12926 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12927 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12928 C simple Kihara potential
12929       subroutine calctube2(Etube)
12930        implicit real*8 (a-h,o-z)
12931       include 'DIMENSIONS'
12932       include 'COMMON.GEO'
12933       include 'COMMON.VAR'
12934       include 'COMMON.LOCAL'
12935       include 'COMMON.CHAIN'
12936       include 'COMMON.DERIV'
12937       include 'COMMON.NAMES'
12938       include 'COMMON.INTERACT'
12939       include 'COMMON.IOUNITS'
12940       include 'COMMON.CALC'
12941       include 'COMMON.CONTROL'
12942       include 'COMMON.SPLITELE'
12943       include 'COMMON.SBRIDGE'
12944       double precision tub_r,vectube(3),enetube(maxres*2)
12945       Etube=0.0d0
12946       do i=1,2*nres
12947         enetube(i)=0.0d0
12948       enddo
12949 C first we calculate the distance from tube center
12950 C first sugare-phosphate group for NARES this would be peptide group
12951 C for UNRES
12952       do i=1,nres
12953 C lets ommit dummy atoms for now
12954        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12955 C now calculate distance from center of tube and direction vectors
12956       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12957           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12958       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12959           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12960       vectube(1)=vectube(1)-tubecenter(1)
12961       vectube(2)=vectube(2)-tubecenter(2)
12962
12963 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12964 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12965
12966 C as the tube is infinity we do not calculate the Z-vector use of Z
12967 C as chosen axis
12968       vectube(3)=0.0d0
12969 C now calculte the distance
12970        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12971 C now normalize vector
12972       vectube(1)=vectube(1)/tub_r
12973       vectube(2)=vectube(2)/tub_r
12974 C calculte rdiffrence between r and r0
12975       rdiff=tub_r-tubeR0
12976 C and its 6 power
12977       rdiff6=rdiff**6.0d0
12978 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12979        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12980 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12981 C       print *,rdiff,rdiff6,pep_aa_tube
12982 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12983 C now we calculate gradient
12984        fac=(-12.0d0*pep_aa_tube/rdiff6+
12985      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12986 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12987 C     &rdiff,fac
12988
12989 C now direction of gg_tube vector
12990         do j=1,3
12991         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12992         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12993         enddo
12994         enddo
12995 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12996         do i=1,nres
12997 C Lets not jump over memory as we use many times iti
12998          iti=itype(i)
12999 C lets ommit dummy atoms for now
13000          if ((iti.eq.ntyp1)
13001 C in UNRES uncomment the line below as GLY has no side-chain...
13002      &      .or.(iti.eq.10)
13003      &   ) cycle
13004           vectube(1)=c(1,i+nres)
13005           vectube(1)=mod(vectube(1),boxxsize)
13006           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
13007           vectube(2)=c(2,i+nres)
13008           vectube(2)=mod(vectube(2),boxxsize)
13009           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
13010
13011       vectube(1)=vectube(1)-tubecenter(1)
13012       vectube(2)=vectube(2)-tubecenter(2)
13013 C THIS FRAGMENT MAKES TUBE FINITE
13014         positi=(mod(c(3,i+nres),boxzsize))
13015         if (positi.le.0) positi=positi+boxzsize
13016 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
13017 c for each residue check if it is in lipid or lipid water border area
13018 C       respos=mod(c(3,i+nres),boxzsize)
13019        print *,positi,bordtubebot,buftubebot,bordtubetop
13020        if ((positi.gt.bordtubebot)
13021      & .and.(positi.lt.bordtubetop)) then
13022 C the energy transfer exist
13023         if (positi.lt.buftubebot) then
13024          fracinbuf=1.0d0-
13025      &     ((positi-bordtubebot)/tubebufthick)
13026 C lipbufthick is thickenes of lipid buffore
13027          sstube=sscalelip(fracinbuf)
13028          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
13029          print *,ssgradtube, sstube,tubetranene(itype(i))
13030          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13031          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13032      &+ssgradtube*tubetranene(itype(i))
13033          gg_tube(3,i-1)= gg_tube(3,i-1)
13034      &+ssgradtube*tubetranene(itype(i))
13035 C         print *,"doing sccale for lower part"
13036         elseif (positi.gt.buftubetop) then
13037          fracinbuf=1.0d0-
13038      &((bordtubetop-positi)/tubebufthick)
13039          sstube=sscalelip(fracinbuf)
13040          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
13041          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13042 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
13043 C     &+ssgradtube*tubetranene(itype(i))
13044 C         gg_tube(3,i-1)= gg_tube(3,i-1)
13045 C     &+ssgradtube*tubetranene(itype(i))
13046 C          print *, "doing sscalefor top part",sslip,fracinbuf
13047         else
13048          sstube=1.0d0
13049          ssgradtube=0.0d0
13050          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13051 C         print *,"I am in true lipid"
13052         endif
13053         else
13054 C          sstube=0.0d0
13055 C          ssgradtube=0.0d0
13056         cycle
13057         endif ! if in lipid or buffor
13058 CEND OF FINITE FRAGMENT
13059 C as the tube is infinity we do not calculate the Z-vector use of Z
13060 C as chosen axis
13061       vectube(3)=0.0d0
13062 C now calculte the distance
13063        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13064 C now normalize vector
13065       vectube(1)=vectube(1)/tub_r
13066       vectube(2)=vectube(2)/tub_r
13067 C calculte rdiffrence between r and r0
13068       rdiff=tub_r-tubeR0
13069 C and its 6 power
13070       rdiff6=rdiff**6.0d0
13071 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13072        sc_aa_tube=sc_aa_tube_par(iti)
13073        sc_bb_tube=sc_bb_tube_par(iti)
13074        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13075      &                 *sstube+enetube(i+nres)
13076 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13077 C now we calculate gradient
13078        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13079      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13080 C now direction of gg_tube vector
13081          do j=1,3
13082           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13083           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13084          enddo
13085          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13086      &+ssgradtube*enetube(i+nres)/sstube
13087          gg_tube(3,i-1)= gg_tube(3,i-1)
13088      &+ssgradtube*enetube(i+nres)/sstube
13089
13090         enddo
13091         do i=1,2*nres
13092           Etube=Etube+enetube(i)
13093         enddo
13094 C        print *,"ETUBE", etube
13095         return
13096         end
13097 C TO DO 1) add to total energy
13098 C       2) add to gradient summation
13099 C       3) add reading parameters (AND of course oppening of PARAM file)
13100 C       4) add reading the center of tube
13101 C       5) add COMMONs
13102 C       6) add to zerograd
13103 c----------------------------------------------------------------------------
13104       subroutine e_saxs(Esaxs_constr)
13105       implicit none
13106       include 'DIMENSIONS'
13107 #ifdef MPI
13108       include "mpif.h"
13109       include "COMMON.SETUP"
13110       integer IERR
13111 #endif
13112       include 'COMMON.SBRIDGE'
13113       include 'COMMON.CHAIN'
13114       include 'COMMON.GEO'
13115       include 'COMMON.DERIV'
13116       include 'COMMON.LOCAL'
13117       include 'COMMON.INTERACT'
13118       include 'COMMON.VAR'
13119       include 'COMMON.IOUNITS'
13120 c      include 'COMMON.MD'
13121 #ifdef LANG0
13122 #ifdef FIVEDIAG
13123       include 'COMMON.LANGEVIN.lang0.5diag'
13124 #else
13125       include 'COMMON.LANGEVIN.lang0'
13126 #endif
13127 #else
13128       include 'COMMON.LANGEVIN'
13129 #endif
13130       include 'COMMON.CONTROL'
13131       include 'COMMON.SAXS'
13132       include 'COMMON.NAMES'
13133       include 'COMMON.TIME1'
13134       include 'COMMON.FFIELD'
13135 c
13136       double precision Esaxs_constr
13137       integer i,iint,j,k,l
13138       double precision PgradC(maxSAXS,3,maxres),
13139      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13140 #ifdef MPI
13141       double precision PgradC_(maxSAXS,3,maxres),
13142      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13143 #endif
13144       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13145      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13146      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13147      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13148       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13149       double precision dist,mygauss,mygaussder
13150       external dist
13151       integer llicz,lllicz
13152       double precision time01
13153 c  SAXS restraint penalty function
13154 #ifdef DEBUG
13155       write(iout,*) "------- SAXS penalty function start -------"
13156       write (iout,*) "nsaxs",nsaxs
13157       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13158       write (iout,*) "Psaxs"
13159       do i=1,nsaxs
13160         write (iout,'(i5,e15.5)') i, Psaxs(i)
13161       enddo
13162 #endif
13163 #ifdef TIMING
13164       time01=MPI_Wtime()
13165 #endif
13166       Esaxs_constr = 0.0d0
13167       do k=1,nsaxs
13168         Pcalc(k)=0.0d0
13169         do j=1,nres
13170           do l=1,3
13171             PgradC(k,l,j)=0.0d0
13172             PgradX(k,l,j)=0.0d0
13173           enddo
13174         enddo
13175       enddo
13176 c      lllicz=0
13177       do i=iatsc_s,iatsc_e
13178        if (itype(i).eq.ntyp1) cycle
13179        do iint=1,nint_gr(i)
13180          do j=istart(i,iint),iend(i,iint)
13181            if (itype(j).eq.ntyp1) cycle
13182 #ifdef ALLSAXS
13183            dijCACA=dist(i,j)
13184            dijCASC=dist(i,j+nres)
13185            dijSCCA=dist(i+nres,j)
13186            dijSCSC=dist(i+nres,j+nres)
13187            sigma2CACA=2.0d0/(pstok**2)
13188            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13189            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13190            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13191            do k=1,nsaxs
13192              dk = distsaxs(k)
13193              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13194              if (itype(j).ne.10) then
13195              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13196              else
13197              endif
13198              expCASC = 0.0d0
13199              if (itype(i).ne.10) then
13200              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13201              else
13202              expSCCA = 0.0d0
13203              endif
13204              if (itype(i).ne.10 .and. itype(j).ne.10) then
13205              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13206              else
13207              expSCSC = 0.0d0
13208              endif
13209              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13210 #ifdef DEBUG
13211              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13212 #endif
13213              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13214              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13215              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13216              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13217              do l=1,3
13218 c CA CA
13219                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13220                PgradC(k,l,i) = PgradC(k,l,i)-aux
13221                PgradC(k,l,j) = PgradC(k,l,j)+aux
13222 c CA SC
13223                if (itype(j).ne.10) then
13224                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13225                PgradC(k,l,i) = PgradC(k,l,i)-aux
13226                PgradC(k,l,j) = PgradC(k,l,j)+aux
13227                PgradX(k,l,j) = PgradX(k,l,j)+aux
13228                endif
13229 c SC CA
13230                if (itype(i).ne.10) then
13231                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13232                PgradX(k,l,i) = PgradX(k,l,i)-aux
13233                PgradC(k,l,i) = PgradC(k,l,i)-aux
13234                PgradC(k,l,j) = PgradC(k,l,j)+aux
13235                endif
13236 c SC SC
13237                if (itype(i).ne.10 .and. itype(j).ne.10) then
13238                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13239                PgradC(k,l,i) = PgradC(k,l,i)-aux
13240                PgradC(k,l,j) = PgradC(k,l,j)+aux
13241                PgradX(k,l,i) = PgradX(k,l,i)-aux
13242                PgradX(k,l,j) = PgradX(k,l,j)+aux
13243                endif
13244              enddo ! l
13245            enddo ! k
13246 #else
13247            dijCACA=dist(i,j)
13248            sigma2CACA=scal_rad**2*0.25d0/
13249      &        (restok(itype(j))**2+restok(itype(i))**2)
13250 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13251 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13252 #ifdef MYGAUSS
13253            sigmaCACA=dsqrt(sigma2CACA)
13254            threesig=3.0d0/sigmaCACA
13255 c           llicz=0
13256            do k=1,nsaxs
13257              dk = distsaxs(k)
13258              if (dabs(dijCACA-dk).ge.threesig) cycle
13259 c             llicz=llicz+1
13260 c             lllicz=lllicz+1
13261              aux = sigmaCACA*(dijCACA-dk)
13262              expCACA = mygauss(aux)
13263 c             if (expcaca.eq.0.0d0) cycle
13264              Pcalc(k) = Pcalc(k)+expCACA
13265              CACAgrad = -sigmaCACA*mygaussder(aux)
13266 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13267              do l=1,3
13268                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13269                PgradC(k,l,i) = PgradC(k,l,i)-aux
13270                PgradC(k,l,j) = PgradC(k,l,j)+aux
13271              enddo ! l
13272            enddo ! k
13273 c           write (iout,*) "i",i," j",j," llicz",llicz
13274 #else
13275            IF (saxs_cutoff.eq.0) THEN
13276            do k=1,nsaxs
13277              dk = distsaxs(k)
13278              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13279              Pcalc(k) = Pcalc(k)+expCACA
13280              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13281              do l=1,3
13282                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13283                PgradC(k,l,i) = PgradC(k,l,i)-aux
13284                PgradC(k,l,j) = PgradC(k,l,j)+aux
13285              enddo ! l
13286            enddo ! k
13287            ELSE
13288            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13289            do k=1,nsaxs
13290              dk = distsaxs(k)
13291 c             write (2,*) "ijk",i,j,k
13292              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13293              if (sss2.eq.0.0d0) cycle
13294              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13295              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13296      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13297      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13298      &           sss2,ssgrad2
13299              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13300              Pcalc(k) = Pcalc(k)+expCACA
13301 #ifdef DEBUG
13302              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13303 #endif
13304              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13305      &             ssgrad2*expCACA/sss2
13306              do l=1,3
13307 c CA CA
13308                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13309                PgradC(k,l,i) = PgradC(k,l,i)+aux
13310                PgradC(k,l,j) = PgradC(k,l,j)-aux
13311              enddo ! l
13312            enddo ! k
13313            ENDIF
13314 #endif
13315 #endif
13316          enddo ! j
13317        enddo ! iint
13318       enddo ! i
13319 c#ifdef TIMING
13320 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13321 c#endif
13322 c      write (iout,*) "lllicz",lllicz
13323 c#ifdef TIMING
13324 c      time01=MPI_Wtime()
13325 c#endif
13326 #ifdef MPI
13327       if (nfgtasks.gt.1) then
13328        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13329      &    MPI_SUM,FG_COMM,IERR)
13330 c        if (fg_rank.eq.king) then
13331           do k=1,nsaxs
13332             Pcalc(k) = Pcalc_(k)
13333           enddo
13334 c        endif
13335 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13336 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13337 c        if (fg_rank.eq.king) then
13338 c          do i=1,nres
13339 c            do l=1,3
13340 c              do k=1,nsaxs
13341 c                PgradC(k,l,i) = PgradC_(k,l,i)
13342 c              enddo
13343 c            enddo
13344 c          enddo
13345 c        endif
13346 #ifdef ALLSAXS
13347 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13348 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13349 c        if (fg_rank.eq.king) then
13350 c          do i=1,nres
13351 c            do l=1,3
13352 c              do k=1,nsaxs
13353 c                PgradX(k,l,i) = PgradX_(k,l,i)
13354 c              enddo
13355 c            enddo
13356 c          enddo
13357 c        endif
13358 #endif
13359       endif
13360 #endif
13361       Cnorm = 0.0d0
13362       do k=1,nsaxs
13363         Cnorm = Cnorm + Pcalc(k)
13364       enddo
13365 #ifdef MPI
13366       if (fg_rank.eq.king) then
13367 #endif
13368       Esaxs_constr = dlog(Cnorm)-wsaxs0
13369       do k=1,nsaxs
13370         if (Pcalc(k).gt.0.0d0)
13371      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13372 #ifdef DEBUG
13373         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13374 #endif
13375       enddo
13376 #ifdef DEBUG
13377       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13378 #endif
13379 #ifdef MPI
13380       endif
13381 #endif
13382       gsaxsC=0.0d0
13383       gsaxsX=0.0d0
13384       do i=nnt,nct
13385         do l=1,3
13386           auxC=0.0d0
13387           auxC1=0.0d0
13388           auxX=0.0d0
13389           auxX1=0.d0
13390           do k=1,nsaxs
13391             if (Pcalc(k).gt.0)
13392      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13393             auxC1 = auxC1+PgradC(k,l,i)
13394 #ifdef ALLSAXS
13395             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13396             auxX1 = auxX1+PgradX(k,l,i)
13397 #endif
13398           enddo
13399           gsaxsC(l,i) = auxC - auxC1/Cnorm
13400 #ifdef ALLSAXS
13401           gsaxsX(l,i) = auxX - auxX1/Cnorm
13402 #endif
13403 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13404 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13405 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13406 c     *     " gradX",wsaxs*gsaxsX(l,i)
13407         enddo
13408       enddo
13409 #ifdef TIMING
13410       time_SAXS=time_SAXS+MPI_Wtime()-time01
13411 #endif
13412 #ifdef DEBUG
13413       write (iout,*) "gsaxsc"
13414       do i=nnt,nct
13415         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13416       enddo
13417 #endif
13418 #ifdef MPI
13419 c      endif
13420 #endif
13421       return
13422       end
13423 c----------------------------------------------------------------------------
13424       subroutine e_saxsC(Esaxs_constr)
13425       implicit none
13426       include 'DIMENSIONS'
13427 #ifdef MPI
13428       include "mpif.h"
13429       include "COMMON.SETUP"
13430       integer IERR
13431 #endif
13432       include 'COMMON.SBRIDGE'
13433       include 'COMMON.CHAIN'
13434       include 'COMMON.GEO'
13435       include 'COMMON.DERIV'
13436       include 'COMMON.LOCAL'
13437       include 'COMMON.INTERACT'
13438       include 'COMMON.VAR'
13439       include 'COMMON.IOUNITS'
13440 c      include 'COMMON.MD'
13441 #ifdef LANG0
13442 #ifdef FIVEDIAG
13443       include 'COMMON.LANGEVIN.lang0.5diag'
13444 #else
13445       include 'COMMON.LANGEVIN.lang0'
13446 #endif
13447 #else
13448       include 'COMMON.LANGEVIN'
13449 #endif
13450       include 'COMMON.CONTROL'
13451       include 'COMMON.SAXS'
13452       include 'COMMON.NAMES'
13453       include 'COMMON.TIME1'
13454       include 'COMMON.FFIELD'
13455 c
13456       double precision Esaxs_constr
13457       integer i,iint,j,k,l
13458       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13459 #ifdef MPI
13460       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13461 #endif
13462       double precision dk,dijCASPH,dijSCSPH,
13463      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13464      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13465      & auxX,auxX1,Cnorm
13466 c  SAXS restraint penalty function
13467 #ifdef DEBUG
13468       write(iout,*) "------- SAXS penalty function start -------"
13469       write (iout,*) "nsaxs",nsaxs
13470
13471       do i=nnt,nct
13472         print *,MyRank,"C",i,(C(j,i),j=1,3)
13473       enddo
13474       do i=nnt,nct
13475         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13476       enddo
13477 #endif
13478       Esaxs_constr = 0.0d0
13479       logPtot=0.0d0
13480       do j=isaxs_start,isaxs_end
13481         Pcalc=0.0d0
13482         do i=1,nres
13483           do l=1,3
13484             PgradC(l,i)=0.0d0
13485             PgradX(l,i)=0.0d0
13486           enddo
13487         enddo
13488         do i=nnt,nct
13489           if (itype(i).eq.ntyp1) cycle
13490           dijCASPH=0.0d0
13491           dijSCSPH=0.0d0
13492           do l=1,3
13493             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13494           enddo
13495           if (itype(i).ne.10) then
13496           do l=1,3
13497             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13498           enddo
13499           endif
13500           sigma2CA=2.0d0/pstok**2
13501           sigma2SC=4.0d0/restok(itype(i))**2
13502           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13503           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13504           Pcalc = Pcalc+expCASPH+expSCSPH
13505 #ifdef DEBUG
13506           write(*,*) "processor i j Pcalc",
13507      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13508 #endif
13509           CASPHgrad = sigma2CA*expCASPH
13510           SCSPHgrad = sigma2SC*expSCSPH
13511           do l=1,3
13512             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13513             PgradX(l,i) = PgradX(l,i) + aux
13514             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13515           enddo ! l
13516         enddo ! i
13517         do i=nnt,nct
13518           do l=1,3
13519             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13520             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13521           enddo
13522         enddo
13523         logPtot = logPtot - dlog(Pcalc)
13524 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13525 c     &    " logPtot",logPtot
13526       enddo ! j
13527 #ifdef MPI
13528       if (nfgtasks.gt.1) then
13529 c        write (iout,*) "logPtot before reduction",logPtot
13530         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13531      &    MPI_SUM,king,FG_COMM,IERR)
13532         logPtot = logPtot_
13533 c        write (iout,*) "logPtot after reduction",logPtot
13534         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13535      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13536         if (fg_rank.eq.king) then
13537           do i=1,nres
13538             do l=1,3
13539               gsaxsC(l,i) = gsaxsC_(l,i)
13540             enddo
13541           enddo
13542         endif
13543         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13544      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13545         if (fg_rank.eq.king) then
13546           do i=1,nres
13547             do l=1,3
13548               gsaxsX(l,i) = gsaxsX_(l,i)
13549             enddo
13550           enddo
13551         endif
13552       endif
13553 #endif
13554       Esaxs_constr = logPtot
13555       return
13556       end
13557 c----------------------------------------------------------------------------
13558       double precision function sscale2(r,r_cut,r0,rlamb)
13559       implicit none
13560       double precision r,gamm,r_cut,r0,rlamb,rr
13561       rr = dabs(r-r0)
13562 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13563 c      write (2,*) "rr",rr
13564       if(rr.lt.r_cut-rlamb) then
13565         sscale2=1.0d0
13566       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13567         gamm=(rr-(r_cut-rlamb))/rlamb
13568         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13569       else
13570         sscale2=0d0
13571       endif
13572       return
13573       end
13574 C-----------------------------------------------------------------------
13575       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13576       implicit none
13577       double precision r,gamm,r_cut,r0,rlamb,rr
13578       rr = dabs(r-r0)
13579       if(rr.lt.r_cut-rlamb) then
13580         sscalgrad2=0.0d0
13581       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13582         gamm=(rr-(r_cut-rlamb))/rlamb
13583         if (r.ge.r0) then
13584           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13585         else
13586           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13587         endif
13588       else
13589         sscalgrad2=0.0d0
13590       endif
13591       return
13592       end