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

   1       subroutine etotal(energia)
   2       implicit none
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       include 'COMMON.MD'
  34       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  35      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  36      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  37      & eliptran,Eafmforce,Etube,
  38      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  39       integer n_corr,n_corr1
  40 #ifdef MPI
  41 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  42 c     & " nfgtasks",nfgtasks
  43       if (nfgtasks.gt.1) then
  44         time00=MPI_Wtime()
  45 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  46         if (fg_rank.eq.0) then
  47           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  48 c          print *,"Processor",myrank," BROADCAST iorder"
  49 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  50 C FG slaves as WEIGHTS array.
  51           weights_(1)=wsc
  52           weights_(2)=wscp
  53           weights_(3)=welec
  54           weights_(4)=wcorr
  55           weights_(5)=wcorr5
  56           weights_(6)=wcorr6
  57           weights_(7)=wel_loc
  58           weights_(8)=wturn3
  59           weights_(9)=wturn4
  60           weights_(10)=wturn6
  61           weights_(11)=wang
  62           weights_(12)=wscloc
  63           weights_(13)=wtor
  64           weights_(14)=wtor_d
  65           weights_(15)=wstrain
  66           weights_(16)=wvdwpp
  67           weights_(17)=wbond
  68           weights_(18)=scal14
  69           weights_(21)=wsccor
  70           weights_(22)=wliptran
  71           weights_(25)=wtube
  72           weights_(26)=wsaxs
  73           weights_(28)=wdfa_dist
  74           weights_(29)=wdfa_tor
  75           weights_(30)=wdfa_nei
  76           weights_(31)=wdfa_beta
  77 C FG Master broadcasts the WEIGHTS_ array
  78           call MPI_Bcast(weights_(1),n_ene,
  79      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  80         else
  81 C FG slaves receive the WEIGHTS array
  82           call MPI_Bcast(weights(1),n_ene,
  83      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  84           wsc=weights(1)
  85           wscp=weights(2)
  86           welec=weights(3)
  87           wcorr=weights(4)
  88           wcorr5=weights(5)
  89           wcorr6=weights(6)
  90           wel_loc=weights(7)
  91           wturn3=weights(8)
  92           wturn4=weights(9)
  93           wturn6=weights(10)
  94           wang=weights(11)
  95           wscloc=weights(12)
  96           wtor=weights(13)
  97           wtor_d=weights(14)
  98           wstrain=weights(15)
  99           wvdwpp=weights(16)
 100           wbond=weights(17)
 101           scal14=weights(18)
 102           wsccor=weights(21)
 103           wliptran=weights(22)
 104           wtube=weights(25)
 105           wsaxs=weights(26)
 106           wdfa_dist=weights_(28)
 107           wdfa_tor=weights_(29)
 108           wdfa_nei=weights_(30)
 109           wdfa_beta=weights_(31)
 110         endif
 111         time_Bcast=time_Bcast+MPI_Wtime()-time00
 112         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 113 c        call chainbuild_cart
 114       endif
 115       if (nfgtasks.gt.1) then
 116         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 117       endif
 118       if (mod(itime_mat,imatupdate).eq.0) then
 119         call make_SCp_inter_list
 120         call make_SCSC_inter_list
 121         call make_pp_inter_list
 122         call make_pp_vdw_inter_list
 123       endif
 124 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 125 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 126 #else
 127 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 128 c        call int_from_cart1(.false.)
 129 c      endif
 130 #endif
 131 #ifdef TIMING
 132       time00=MPI_Wtime()
 133 #endif
 134
 135 #ifndef DFA
 136       edfadis=0.0d0
 137       edfator=0.0d0
 138       edfanei=0.0d0
 139       edfabet=0.0d0
 140 #endif
 141 C
 142 C Compute the side-chain and electrostatic interaction energy
 143 C
 144 C      print *,ipot
 145       goto (101,102,103,104,105,106) ipot
 146 C Lennard-Jones potential.
 147   101 call elj(evdw)
 148 cd    print '(a)','Exit ELJ'
 149       goto 107
 150 C Lennard-Jones-Kihara potential (shifted).
 151   102 call eljk(evdw)
 152       goto 107
 153 C Berne-Pechukas potential (dilated LJ, angular dependence).
 154   103 call ebp(evdw)
 155       goto 107
 156 C Gay-Berne potential (shifted LJ, angular dependence).
 157   104 call egb(evdw)
 158 C      print *,"bylem w egb"
 159       goto 107
 160 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 161   105 call egbv(evdw)
 162       goto 107
 163 C Soft-sphere potential
 164   106 call e_softsphere(evdw)
 165 C
 166 C Calculate electrostatic (H-bonding) energy of the main chain.
 167 C
 168   107 continue
 169 #ifdef DFA
 170 C     BARTEK for dfa test!
 171       if (wdfa_dist.gt.0) then
 172         call edfad(edfadis)
 173       else
 174         edfadis=0
 175       endif
 176 c      print*, 'edfad is finished!', edfadis
 177       if (wdfa_tor.gt.0) then
 178         call edfat(edfator)
 179       else
 180         edfator=0
 181       endif
 182 c      print*, 'edfat is finished!', edfator
 183       if (wdfa_nei.gt.0) then
 184         call edfan(edfanei)
 185       else
 186         edfanei=0
 187       endif
 188 c      print*, 'edfan is finished!', edfanei
 189       if (wdfa_beta.gt.0) then
 190         call edfab(edfabet)
 191       else
 192         edfabet=0
 193       endif
 194 #endif
 195 cmc
 196 cmc Sep-06: egb takes care of dynamic ss bonds too
 197 cmc
 198 c      if (dyn_ss) call dyn_set_nss
 199
 200 c      print *,"Processor",myrank," computed USCSC"
 201 #ifdef TIMING
 202       time01=MPI_Wtime()
 203 #endif
 204       call vec_and_deriv
 205 #ifdef TIMING
 206       time_vec=time_vec+MPI_Wtime()-time01
 207 #endif
 208 C Introduction of shielding effect first for each peptide group
 209 C the shielding factor is set this factor is describing how each
 210 C peptide group is shielded by side-chains
 211 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 212 C      write (iout,*) "shield_mode",shield_mode
 213       if (shield_mode.eq.1) then
 214        call set_shield_fac
 215       else if  (shield_mode.eq.2) then
 216        call set_shield_fac2
 217       endif
 218 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 219       if (ipot.lt.6) then
 220 #ifdef SPLITELE
 221          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 222      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 223      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 224      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 225 #else
 226          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 227      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 228      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 229      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 230 #endif
 231             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 232          else
 233             ees=0.0d0
 234             evdw1=0.0d0
 235             eel_loc=0.0d0
 236             eello_turn3=0.0d0
 237             eello_turn4=0.0d0
 238          endif
 239       else
 240         write (iout,*) "Soft-spheer ELEC potential"
 241 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 242 c     &   eello_turn4)
 243       endif
 244 c#ifdef TIMING
 245 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 246 c#endif
 247 c      print *,"Processor",myrank," computed UELEC"
 248 C
 249 C Calculate excluded-volume interaction energy between peptide groups
 250 C and side chains.
 251 C
 252       if (ipot.lt.6) then
 253        if(wscp.gt.0d0) then
 254         call escp(evdw2,evdw2_14)
 255        else
 256         evdw2=0
 257         evdw2_14=0
 258        endif
 259       else
 260 c        write (iout,*) "Soft-sphere SCP potential"
 261         call escp_soft_sphere(evdw2,evdw2_14)
 262       endif
 263 c
 264 c Calculate the bond-stretching energy
 265 c
 266       call ebond(estr)
 267 C
 268 C Calculate the disulfide-bridge and other energy and the contributions
 269 C from other distance constraints.
 270 cd      write (iout,*) 'Calling EHPB'
 271       call edis(ehpb)
 272 cd    print *,'EHPB exitted succesfully.'
 273 C
 274 C Calculate the virtual-bond-angle energy.
 275 C
 276       if (wang.gt.0d0) then
 277        if (tor_mode.eq.0) then
 278          call ebend(ebe)
 279        else
 280 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 281 C energy function
 282          call ebend_kcc(ebe)
 283        endif
 284       else
 285         ebe=0.0d0
 286       endif
 287       ethetacnstr=0.0d0
 288       if (with_theta_constr) call etheta_constr(ethetacnstr)
 289 c      print *,"Processor",myrank," computed UB"
 290 C
 291 C Calculate the SC local energy.
 292 C
 293 C      print *,"TU DOCHODZE?"
 294       call esc(escloc)
 295 c      print *,"Processor",myrank," computed USC"
 296 C
 297 C Calculate the virtual-bond torsional energy.
 298 C
 299 cd    print *,'nterm=',nterm
 300 C      print *,"tor",tor_mode
 301       if (wtor.gt.0.0d0) then
 302          if (tor_mode.eq.0) then
 303            call etor(etors)
 304          else
 305 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 306 C energy function
 307            call etor_kcc(etors)
 308          endif
 309       else
 310         etors=0.0d0
 311       endif
 312       edihcnstr=0.0d0
 313       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 314 c      print *,"Processor",myrank," computed Utor"
 315       if (constr_homology.ge.1) then
 316         call e_modeller(ehomology_constr)
 317 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 318 c     &  'Processor',fg_rank,' CG group',kolor,
 319 c     &  ' absolute rank',MyRank
 320       else
 321         ehomology_constr=0.0d0
 322       endif
 323 C
 324 C 6/23/01 Calculate double-torsional energy
 325 C
 326       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 327         call etor_d(etors_d)
 328       else
 329         etors_d=0
 330       endif
 331 c      print *,"Processor",myrank," computed Utord"
 332 C
 333 C 21/5/07 Calculate local sicdechain correlation energy
 334 C
 335       if (wsccor.gt.0.0d0) then
 336         call eback_sc_corr(esccor)
 337       else
 338         esccor=0.0d0
 339       endif
 340 #ifdef FOURBODY
 341 C      print *,"PRZED MULIt"
 342 c      print *,"Processor",myrank," computed Usccorr"
 343 C
 344 C 12/1/95 Multi-body terms
 345 C
 346       n_corr=0
 347       n_corr1=0
 348       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 349      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 350          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 351 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 352 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 353 c        call flush(iout)
 354       else
 355          ecorr=0.0d0
 356          ecorr5=0.0d0
 357          ecorr6=0.0d0
 358          eturn6=0.0d0
 359       endif
 360       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 361 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 362 c     &     n_corr,n_corr1
 363 c         call flush(iout)
 364          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 365 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 366 c     &     n_corr1
 367 c         call flush(iout)
 368       endif
 369 #endif
 370 c      print *,"Processor",myrank," computed Ucorr"
 371 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 372       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 373         call e_saxs(Esaxs_constr)
 374 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 375       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 376         call e_saxsC(Esaxs_constr)
 377 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 378       else
 379         Esaxs_constr = 0.0d0
 380       endif
 381 C
 382 C If performing constraint dynamics, call the constraint energy
 383 C  after the equilibration time
 384 c      if(usampl.and.totT.gt.eq_time) then
 385 c      write (iout,*) "usampl",usampl
 386       if(usampl) then
 387          call EconstrQ
 388          if (loc_qlike) then
 389            call Econstr_back_qlike
 390          else
 391            call Econstr_back
 392          endif
 393       else
 394          Uconst=0.0d0
 395          Uconst_back=0.0d0
 396       endif
 397 C 01/27/2015 added by adasko
 398 C the energy component below is energy transfer into lipid environment
 399 C based on partition function
 400 C      print *,"przed lipidami"
 401       if (wliptran.gt.0) then
 402         call Eliptransfer(eliptran)
 403       else
 404         eliptran=0.0d0
 405       endif
 406 C      print *,"za lipidami"
 407       if (AFMlog.gt.0) then
 408         call AFMforce(Eafmforce)
 409       else if (selfguide.gt.0) then
 410         call AFMvel(Eafmforce)
 411       endif
 412       if (TUBElog.eq.1) then
 413 C      print *,"just before call"
 414         call calctube(Etube)
 415        elseif (TUBElog.eq.2) then
 416         call calctube2(Etube)
 417        else
 418        Etube=0.0d0
 419        endif
 420
 421 #ifdef TIMING
 422       time_enecalc=time_enecalc+MPI_Wtime()-time00
 423 #endif
 424 c      print *,"Processor",myrank," computed Uconstr"
 425 #ifdef TIMING
 426       time00=MPI_Wtime()
 427 #endif
 428 c
 429 C Sum the energies
 430 C
 431       energia(1)=evdw
 432 #ifdef SCP14
 433       energia(2)=evdw2-evdw2_14
 434       energia(18)=evdw2_14
 435 #else
 436       energia(2)=evdw2
 437       energia(18)=0.0d0
 438 #endif
 439 #ifdef SPLITELE
 440       energia(3)=ees
 441       energia(16)=evdw1
 442 #else
 443       energia(3)=ees+evdw1
 444       energia(16)=0.0d0
 445 #endif
 446       energia(4)=ecorr
 447       energia(5)=ecorr5
 448       energia(6)=ecorr6
 449       energia(7)=eel_loc
 450       energia(8)=eello_turn3
 451       energia(9)=eello_turn4
 452       energia(10)=eturn6
 453       energia(11)=ebe
 454       energia(12)=escloc
 455       energia(13)=etors
 456       energia(14)=etors_d
 457       energia(15)=ehpb
 458       energia(19)=edihcnstr
 459       energia(17)=estr
 460       energia(20)=Uconst+Uconst_back
 461       energia(21)=esccor
 462       energia(22)=eliptran
 463       energia(23)=Eafmforce
 464       energia(24)=ethetacnstr
 465       energia(25)=Etube
 466       energia(26)=Esaxs_constr
 467       energia(27)=ehomology_constr
 468       energia(28)=edfadis
 469       energia(29)=edfator
 470       energia(30)=edfanei
 471       energia(31)=edfabet
 472 c      write (iout,*) "esaxs_constr",energia(26)
 473 c    Here are the energies showed per procesor if the are more processors
 474 c    per molecule then we sum it up in sum_energy subroutine
 475 c      print *," Processor",myrank," calls SUM_ENERGY"
 476       call sum_energy(energia,.true.)
 477 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 478       if (dyn_ss) call dyn_set_nss
 479 c      print *," Processor",myrank," left SUM_ENERGY"
 480 #ifdef TIMING
 481       time_sumene=time_sumene+MPI_Wtime()-time00
 482 #endif
 483       return
 484       end
 485 c-------------------------------------------------------------------------------
 486       subroutine sum_energy(energia,reduce)
 487       implicit none
 488       include 'DIMENSIONS'
 489 #ifndef ISNAN
 490       external proc_proc
 491 #ifdef WINPGI
 492 cMS$ATTRIBUTES C ::  proc_proc
 493 #endif
 494 #endif
 495 #ifdef MPI
 496       include "mpif.h"
 497       integer ierr
 498       double precision time00
 499 #endif
 500       include 'COMMON.SETUP'
 501       include 'COMMON.IOUNITS'
 502       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 503       include 'COMMON.FFIELD'
 504       include 'COMMON.DERIV'
 505       include 'COMMON.INTERACT'
 506       include 'COMMON.SBRIDGE'
 507       include 'COMMON.CHAIN'
 508       include 'COMMON.VAR'
 509       include 'COMMON.CONTROL'
 510       include 'COMMON.TIME1'
 511       logical reduce
 512       integer i
 513       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 514      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 515      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 516      & eliptran,Eafmforce,Etube,
 517      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 518       double precision Uconst,etot
 519 #ifdef MPI
 520       if (nfgtasks.gt.1 .and. reduce) then
 521 #ifdef DEBUG
 522         write (iout,*) "energies before REDUCE"
 523         call enerprint(energia)
 524         call flush(iout)
 525 #endif
 526         do i=0,n_ene
 527           enebuff(i)=energia(i)
 528         enddo
 529         time00=MPI_Wtime()
 530         call MPI_Barrier(FG_COMM,IERR)
 531         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 532         time00=MPI_Wtime()
 533         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 534      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 535 #ifdef DEBUG
 536         write (iout,*) "energies after REDUCE"
 537         call enerprint(energia)
 538         call flush(iout)
 539 #endif
 540         time_Reduce=time_Reduce+MPI_Wtime()-time00
 541       endif
 542       if (fg_rank.eq.0) then
 543 #endif
 544       evdw=energia(1)
 545 #ifdef SCP14
 546       evdw2=energia(2)+energia(18)
 547       evdw2_14=energia(18)
 548 #else
 549       evdw2=energia(2)
 550 #endif
 551 #ifdef SPLITELE
 552       ees=energia(3)
 553       evdw1=energia(16)
 554 #else
 555       ees=energia(3)
 556       evdw1=0.0d0
 557 #endif
 558       ecorr=energia(4)
 559       ecorr5=energia(5)
 560       ecorr6=energia(6)
 561       eel_loc=energia(7)
 562       eello_turn3=energia(8)
 563       eello_turn4=energia(9)
 564       eturn6=energia(10)
 565       ebe=energia(11)
 566       escloc=energia(12)
 567       etors=energia(13)
 568       etors_d=energia(14)
 569       ehpb=energia(15)
 570       edihcnstr=energia(19)
 571       estr=energia(17)
 572       Uconst=energia(20)
 573       esccor=energia(21)
 574       eliptran=energia(22)
 575       Eafmforce=energia(23)
 576       ethetacnstr=energia(24)
 577       Etube=energia(25)
 578       esaxs_constr=energia(26)
 579       ehomology_constr=energia(27)
 580       edfadis=energia(28)
 581       edfator=energia(29)
 582       edfanei=energia(30)
 583       edfabet=energia(31)
 584 #ifdef SPLITELE
 585       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 586      & +wang*ebe+wtor*etors+wscloc*escloc
 587      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 588      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 589      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 590      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 591      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 592      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 593      & +wdfa_beta*edfabet
 594 #else
 595       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 596      & +wang*ebe+wtor*etors+wscloc*escloc
 597      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 598      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 599      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 600      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 601      & +Eafmforce
 602      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 603      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 604      & +wdfa_beta*edfabet
 605 #endif
 606       energia(0)=etot
 607 c detecting NaNQ
 608 #ifdef ISNAN
 609 #ifdef AIX
 610       if (isnan(etot).ne.0) energia(0)=1.0d+99
 611 #else
 612       if (isnan(etot)) energia(0)=1.0d+99
 613 #endif
 614 #else
 615       i=0
 616 #ifdef WINPGI
 617       idumm=proc_proc(etot,i)
 618 #else
 619       call proc_proc(etot,i)
 620 #endif
 621       if(i.eq.1)energia(0)=1.0d+99
 622 #endif
 623 #ifdef MPI
 624       endif
 625 #endif
 626       return
 627       end
 628 c-------------------------------------------------------------------------------
 629       subroutine sum_gradient
 630       implicit none
 631       include 'DIMENSIONS'
 632 #ifndef ISNAN
 633       external proc_proc
 634 #ifdef WINPGI
 635 cMS$ATTRIBUTES C ::  proc_proc
 636 #endif
 637 #endif
 638 #ifdef MPI
 639       include 'mpif.h'
 640       integer ierror,ierr
 641       double precision time00,time01
 642 #endif
 643       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 644      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 645      & ,gloc_scbuf(3,-1:maxres)
 646       include 'COMMON.SETUP'
 647       include 'COMMON.IOUNITS'
 648       include 'COMMON.FFIELD'
 649       include 'COMMON.DERIV'
 650       include 'COMMON.INTERACT'
 651       include 'COMMON.SBRIDGE'
 652       include 'COMMON.CHAIN'
 653       include 'COMMON.VAR'
 654       include 'COMMON.CONTROL'
 655       include 'COMMON.TIME1'
 656       include 'COMMON.MAXGRAD'
 657       include 'COMMON.SCCOR'
 658 c      include 'COMMON.MD'
 659       include 'COMMON.QRESTR'
 660       integer i,j,k
 661       double precision scalar
 662       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 663      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 664      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 665      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 666      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 667      &gsclocx_norm
 668 #ifdef TIMING
 669       time01=MPI_Wtime()
 670 #endif
 671 #ifdef DEBUG
 672       write (iout,*) "sum_gradient gvdwc, gvdwx"
 673       do i=1,nres
 674         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 675      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 676       enddo
 677       call flush(iout)
 678 #endif
 679 #ifdef DEBUG
 680       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 681       do i=0,nres
 682         write (iout,'(i3,3e15.5,5x,3e15.5)')
 683      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 684       enddo
 685       call flush(iout)
 686 #endif
 687 #ifdef MPI
 688 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 689         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 690      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 691 #endif
 692 C
 693 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 694 C            in virtual-bond-vector coordinates
 695 C
 696 #ifdef DEBUG
 697 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 698 c      do i=1,nres-1
 699 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 700 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 701 c      enddo
 702 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 703 c      do i=1,nres-1
 704 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 705 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 706 c      enddo
 707       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 708       do i=1,nres
 709         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 710      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 711      &   g_corr5_loc(i)
 712       enddo
 713       call flush(iout)
 714 #endif
 715 #ifdef DEBUG
 716       write (iout,*) "gsaxsc"
 717       do i=1,nres
 718         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 719       enddo
 720       call flush(iout)
 721 #endif
 722 #ifdef SPLITELE
 723       do i=0,nct
 724         do j=1,3
 725           gradbufc(j,i)=wsc*gvdwc(j,i)+
 726      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 727      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 728      &                wel_loc*gel_loc_long(j,i)+
 729      &                wcorr*gradcorr_long(j,i)+
 730      &                wcorr5*gradcorr5_long(j,i)+
 731      &                wcorr6*gradcorr6_long(j,i)+
 732      &                wturn6*gcorr6_turn_long(j,i)+
 733      &                wstrain*ghpbc(j,i)
 734      &                +wliptran*gliptranc(j,i)
 735      &                +gradafm(j,i)
 736      &                +welec*gshieldc(j,i)
 737      &                +wcorr*gshieldc_ec(j,i)
 738      &                +wturn3*gshieldc_t3(j,i)
 739      &                +wturn4*gshieldc_t4(j,i)
 740      &                +wel_loc*gshieldc_ll(j,i)
 741      &                +wtube*gg_tube(j,i)
 742      &                +wsaxs*gsaxsc(j,i)
 743         enddo
 744       enddo
 745 #else
 746       do i=0,nct
 747         do j=1,3
 748           gradbufc(j,i)=wsc*gvdwc(j,i)+
 749      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 750      &                welec*gelc_long(j,i)+
 751      &                wbond*gradb(j,i)+
 752      &                wel_loc*gel_loc_long(j,i)+
 753      &                wcorr*gradcorr_long(j,i)+
 754      &                wcorr5*gradcorr5_long(j,i)+
 755      &                wcorr6*gradcorr6_long(j,i)+
 756      &                wturn6*gcorr6_turn_long(j,i)+
 757      &                wstrain*ghpbc(j,i)
 758      &                +wliptran*gliptranc(j,i)
 759      &                +gradafm(j,i)
 760      &                 +welec*gshieldc(j,i)
 761      &                 +wcorr*gshieldc_ec(j,i)
 762      &                 +wturn4*gshieldc_t4(j,i)
 763      &                 +wel_loc*gshieldc_ll(j,i)
 764      &                +wtube*gg_tube(j,i)
 765      &                +wsaxs*gsaxsc(j,i)
 766         enddo
 767       enddo
 768 #endif
 769       do i=1,nct
 770         do j=1,3
 771           gradbufc(j,i)=gradbufc(j,i)+
 772      &                wdfa_dist*gdfad(j,i)+
 773      &                wdfa_tor*gdfat(j,i)+
 774      &                wdfa_nei*gdfan(j,i)+
 775      &                wdfa_beta*gdfab(j,i)
 776         enddo
 777       enddo
 778 #ifdef DEBUG
 779       write (iout,*) "gradc from gradbufc"
 780       do i=1,nres
 781         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 782       enddo
 783       call flush(iout)
 784 #endif
 785 #ifdef MPI
 786       if (nfgtasks.gt.1) then
 787       time00=MPI_Wtime()
 788 #ifdef DEBUG
 789       write (iout,*) "gradbufc before allreduce"
 790       do i=1,nres
 791         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 792       enddo
 793       call flush(iout)
 794 #endif
 795       do i=0,nres
 796         do j=1,3
 797           gradbufc_sum(j,i)=gradbufc(j,i)
 798         enddo
 799       enddo
 800 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 801 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 802 c      time_reduce=time_reduce+MPI_Wtime()-time00
 803 #ifdef DEBUG
 804 c      write (iout,*) "gradbufc_sum after allreduce"
 805 c      do i=1,nres
 806 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 807 c      enddo
 808 c      call flush(iout)
 809 #endif
 810 #ifdef TIMING
 811 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 812 #endif
 813       do i=nnt,nres
 814         do k=1,3
 815           gradbufc(k,i)=0.0d0
 816         enddo
 817       enddo
 818 #ifdef DEBUG
 819       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 820       write (iout,*) (i," jgrad_start",jgrad_start(i),
 821      &                  " jgrad_end  ",jgrad_end(i),
 822      &                  i=igrad_start,igrad_end)
 823 #endif
 824 c
 825 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 826 c do not parallelize this part.
 827 c
 828 c      do i=igrad_start,igrad_end
 829 c        do j=jgrad_start(i),jgrad_end(i)
 830 c          do k=1,3
 831 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 832 c          enddo
 833 c        enddo
 834 c      enddo
 835       do j=1,3
 836         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 837       enddo
 838       do i=nres-2,-1,-1
 839         do j=1,3
 840           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 841         enddo
 842       enddo
 843 #ifdef DEBUG
 844       write (iout,*) "gradbufc after summing"
 845       do i=1,nres
 846         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 847       enddo
 848       call flush(iout)
 849 #endif
 850       else
 851 #endif
 852 #ifdef DEBUG
 853       write (iout,*) "gradbufc"
 854       do i=1,nres
 855         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 856       enddo
 857       call flush(iout)
 858 #endif
 859       do i=-1,nres
 860         do j=1,3
 861           gradbufc_sum(j,i)=gradbufc(j,i)
 862           gradbufc(j,i)=0.0d0
 863         enddo
 864       enddo
 865       do j=1,3
 866         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 867       enddo
 868       do i=nres-2,-1,-1
 869         do j=1,3
 870           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 871         enddo
 872       enddo
 873 c      do i=nnt,nres-1
 874 c        do k=1,3
 875 c          gradbufc(k,i)=0.0d0
 876 c        enddo
 877 c        do j=i+1,nres
 878 c          do k=1,3
 879 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 880 c          enddo
 881 c        enddo
 882 c      enddo
 883 #ifdef DEBUG
 884       write (iout,*) "gradbufc after summing"
 885       do i=1,nres
 886         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 887       enddo
 888       call flush(iout)
 889 #endif
 890 #ifdef MPI
 891       endif
 892 #endif
 893       do k=1,3
 894         gradbufc(k,nres)=0.0d0
 895       enddo
 896       do i=-1,nct
 897         do j=1,3
 898 #ifdef SPLITELE
 899 C          print *,gradbufc(1,13)
 900 C          print *,welec*gelc(1,13)
 901 C          print *,wel_loc*gel_loc(1,13)
 902 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 903 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 904 C          print *,wel_loc*gel_loc_long(1,13)
 905 C          print *,gradafm(1,13),"AFM"
 906           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 907      &                wel_loc*gel_loc(j,i)+
 908      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 909      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 910      &                wel_loc*gel_loc_long(j,i)+
 911      &                wcorr*gradcorr_long(j,i)+
 912      &                wcorr5*gradcorr5_long(j,i)+
 913      &                wcorr6*gradcorr6_long(j,i)+
 914      &                wturn6*gcorr6_turn_long(j,i))+
 915      &                wbond*gradb(j,i)+
 916      &                wcorr*gradcorr(j,i)+
 917      &                wturn3*gcorr3_turn(j,i)+
 918      &                wturn4*gcorr4_turn(j,i)+
 919      &                wcorr5*gradcorr5(j,i)+
 920      &                wcorr6*gradcorr6(j,i)+
 921      &                wturn6*gcorr6_turn(j,i)+
 922      &                wsccor*gsccorc(j,i)
 923      &               +wscloc*gscloc(j,i)
 924      &               +wliptran*gliptranc(j,i)
 925      &                +gradafm(j,i)
 926      &                 +welec*gshieldc(j,i)
 927      &                 +welec*gshieldc_loc(j,i)
 928      &                 +wcorr*gshieldc_ec(j,i)
 929      &                 +wcorr*gshieldc_loc_ec(j,i)
 930      &                 +wturn3*gshieldc_t3(j,i)
 931      &                 +wturn3*gshieldc_loc_t3(j,i)
 932      &                 +wturn4*gshieldc_t4(j,i)
 933      &                 +wturn4*gshieldc_loc_t4(j,i)
 934      &                 +wel_loc*gshieldc_ll(j,i)
 935      &                 +wel_loc*gshieldc_loc_ll(j,i)
 936      &                +wtube*gg_tube(j,i)
 937
 938 #else
 939           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 940      &                wel_loc*gel_loc(j,i)+
 941      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 942      &                welec*gelc_long(j,i)+
 943      &                wel_loc*gel_loc_long(j,i)+
 944      &                wcorr*gcorr_long(j,i)+
 945      &                wcorr5*gradcorr5_long(j,i)+
 946      &                wcorr6*gradcorr6_long(j,i)+
 947      &                wturn6*gcorr6_turn_long(j,i))+
 948      &                wbond*gradb(j,i)+
 949      &                wcorr*gradcorr(j,i)+
 950      &                wturn3*gcorr3_turn(j,i)+
 951      &                wturn4*gcorr4_turn(j,i)+
 952      &                wcorr5*gradcorr5(j,i)+
 953      &                wcorr6*gradcorr6(j,i)+
 954      &                wturn6*gcorr6_turn(j,i)+
 955      &                wsccor*gsccorc(j,i)
 956      &               +wscloc*gscloc(j,i)
 957      &               +wliptran*gliptranc(j,i)
 958      &                +gradafm(j,i)
 959      &                 +welec*gshieldc(j,i)
 960      &                 +welec*gshieldc_loc(j,i)
 961      &                 +wcorr*gshieldc_ec(j,i)
 962      &                 +wcorr*gshieldc_loc_ec(j,i)
 963      &                 +wturn3*gshieldc_t3(j,i)
 964      &                 +wturn3*gshieldc_loc_t3(j,i)
 965      &                 +wturn4*gshieldc_t4(j,i)
 966      &                 +wturn4*gshieldc_loc_t4(j,i)
 967      &                 +wel_loc*gshieldc_ll(j,i)
 968      &                 +wel_loc*gshieldc_loc_ll(j,i)
 969      &                +wtube*gg_tube(j,i)
 970
 971
 972 #endif
 973           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 974      &                  wbond*gradbx(j,i)+
 975      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 976      &                  wsccor*gsccorx(j,i)
 977      &                 +wscloc*gsclocx(j,i)
 978      &                 +wliptran*gliptranx(j,i)
 979      &                 +welec*gshieldx(j,i)
 980      &                 +wcorr*gshieldx_ec(j,i)
 981      &                 +wturn3*gshieldx_t3(j,i)
 982      &                 +wturn4*gshieldx_t4(j,i)
 983      &                 +wel_loc*gshieldx_ll(j,i)
 984      &                 +wtube*gg_tube_sc(j,i)
 985      &                 +wsaxs*gsaxsx(j,i)
 986
 987
 988
 989         enddo
 990       enddo
 991       if (constr_homology.gt.0) then
 992         do i=1,nct
 993           do j=1,3
 994             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 995             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 996           enddo
 997         enddo
 998       endif
 999 #ifdef DEBUG
1000       write (iout,*) "gradc gradx gloc after adding"
1001       do i=1,nres
1002         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1003      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1004       enddo
1005 #endif
1006 #ifdef DEBUG
1007       write (iout,*) "gloc before adding corr"
1008       do i=1,4*nres
1009         write (iout,*) i,gloc(i,icg)
1010       enddo
1011 #endif
1012       do i=1,nres-3
1013         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1014      &   +wcorr5*g_corr5_loc(i)
1015      &   +wcorr6*g_corr6_loc(i)
1016      &   +wturn4*gel_loc_turn4(i)
1017      &   +wturn3*gel_loc_turn3(i)
1018      &   +wturn6*gel_loc_turn6(i)
1019      &   +wel_loc*gel_loc_loc(i)
1020       enddo
1021 #ifdef DEBUG
1022       write (iout,*) "gloc after adding corr"
1023       do i=1,4*nres
1024         write (iout,*) i,gloc(i,icg)
1025       enddo
1026 #endif
1027 #ifdef MPI
1028       if (nfgtasks.gt.1) then
1029         do j=1,3
1030           do i=1,nres
1031             gradbufc(j,i)=gradc(j,i,icg)
1032             gradbufx(j,i)=gradx(j,i,icg)
1033           enddo
1034         enddo
1035         do i=1,4*nres
1036           glocbuf(i)=gloc(i,icg)
1037         enddo
1038 c#define DEBUG
1039 #ifdef DEBUG
1040       write (iout,*) "gloc_sc before reduce"
1041       do i=1,nres
1042        do j=1,1
1043         write (iout,*) i,j,gloc_sc(j,i,icg)
1044        enddo
1045       enddo
1046 #endif
1047 c#undef DEBUG
1048         do i=1,nres
1049          do j=1,3
1050           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1051          enddo
1052         enddo
1053         time00=MPI_Wtime()
1054         call MPI_Barrier(FG_COMM,IERR)
1055         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1056         time00=MPI_Wtime()
1057         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1058      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1059         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1060      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1061         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1062      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1063         time_reduce=time_reduce+MPI_Wtime()-time00
1064         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1065      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1066         time_reduce=time_reduce+MPI_Wtime()-time00
1067 #ifdef DEBUG
1068       write (iout,*) "gradc after reduce"
1069       do i=1,nres
1070        do j=1,3
1071         write (iout,*) i,j,gradc(j,i,icg)
1072        enddo
1073       enddo
1074 #endif
1075 #ifdef DEBUG
1076       write (iout,*) "gloc_sc after reduce"
1077       do i=1,nres
1078        do j=1,1
1079         write (iout,*) i,j,gloc_sc(j,i,icg)
1080        enddo
1081       enddo
1082 #endif
1083 #ifdef DEBUG
1084       write (iout,*) "gloc after reduce"
1085       do i=1,4*nres
1086         write (iout,*) i,gloc(i,icg)
1087       enddo
1088 #endif
1089       endif
1090 #endif
1091       if (gnorm_check) then
1092 c
1093 c Compute the maximum elements of the gradient
1094 c
1095       gvdwc_max=0.0d0
1096       gvdwc_scp_max=0.0d0
1097       gelc_max=0.0d0
1098       gvdwpp_max=0.0d0
1099       gradb_max=0.0d0
1100       ghpbc_max=0.0d0
1101       gradcorr_max=0.0d0
1102       gel_loc_max=0.0d0
1103       gcorr3_turn_max=0.0d0
1104       gcorr4_turn_max=0.0d0
1105       gradcorr5_max=0.0d0
1106       gradcorr6_max=0.0d0
1107       gcorr6_turn_max=0.0d0
1108       gsccorrc_max=0.0d0
1109       gscloc_max=0.0d0
1110       gvdwx_max=0.0d0
1111       gradx_scp_max=0.0d0
1112       ghpbx_max=0.0d0
1113       gradxorr_max=0.0d0
1114       gsccorrx_max=0.0d0
1115       gsclocx_max=0.0d0
1116       do i=1,nct
1117         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1118         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1119         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1120         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1121      &   gvdwc_scp_max=gvdwc_scp_norm
1122         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1123         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1124         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1125         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1126         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1127         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1128         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1129         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1130         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1131         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1132         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1133         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1134         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1135      &    gcorr3_turn(1,i)))
1136         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1137      &    gcorr3_turn_max=gcorr3_turn_norm
1138         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1139      &    gcorr4_turn(1,i)))
1140         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1141      &    gcorr4_turn_max=gcorr4_turn_norm
1142         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1143         if (gradcorr5_norm.gt.gradcorr5_max)
1144      &    gradcorr5_max=gradcorr5_norm
1145         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1146         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1147         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1148      &    gcorr6_turn(1,i)))
1149         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1150      &    gcorr6_turn_max=gcorr6_turn_norm
1151         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1152         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1153         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1154         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1155         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1156         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1157         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1158         if (gradx_scp_norm.gt.gradx_scp_max)
1159      &    gradx_scp_max=gradx_scp_norm
1160         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1161         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1162         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1163         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1164         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1165         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1166         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1167         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1168       enddo
1169       if (gradout) then
1170 #if (defined AIX || defined CRAY)
1171         open(istat,file=statname,position="append")
1172 #else
1173         open(istat,file=statname,access="append")
1174 #endif
1175         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1176      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1177      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1178      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1179      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1180      &     gsccorrx_max,gsclocx_max
1181         close(istat)
1182         if (gvdwc_max.gt.1.0d4) then
1183           write (iout,*) "gvdwc gvdwx gradb gradbx"
1184           do i=nnt,nct
1185             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1186      &        gradb(j,i),gradbx(j,i),j=1,3)
1187           enddo
1188           call pdbout(0.0d0,'cipiszcze',iout)
1189           call flush(iout)
1190         endif
1191       endif
1192       endif
1193 #ifdef DEBUG
1194       write (iout,*) "gradc gradx gloc"
1195       do i=1,nres
1196         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1197      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1198       enddo
1199 #endif
1200 #ifdef TIMING
1201       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1202 #endif
1203       return
1204       end
1205 c-------------------------------------------------------------------------------
1206       subroutine rescale_weights(t_bath)
1207       implicit none
1208 #ifdef MPI
1209       include 'mpif.h'
1210       integer ierror
1211 #endif
1212       include 'DIMENSIONS'
1213       include 'COMMON.IOUNITS'
1214       include 'COMMON.FFIELD'
1215       include 'COMMON.SBRIDGE'
1216       include 'COMMON.CONTROL'
1217       double precision t_bath
1218       double precision facT,facT2,facT3,facT4,facT5
1219       double precision kfac /2.4d0/
1220       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1221 c      facT=temp0/t_bath
1222 c      facT=2*temp0/(t_bath+temp0)
1223       if (rescale_mode.eq.0) then
1224         facT=1.0d0
1225         facT2=1.0d0
1226         facT3=1.0d0
1227         facT4=1.0d0
1228         facT5=1.0d0
1229       else if (rescale_mode.eq.1) then
1230         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1231         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1232         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1233         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1234         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1235       else if (rescale_mode.eq.2) then
1236         x=t_bath/temp0
1237         x2=x*x
1238         x3=x2*x
1239         x4=x3*x
1240         x5=x4*x
1241         facT=licznik/dlog(dexp(x)+dexp(-x))
1242         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1243         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1244         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1245         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1246       else
1247         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1248         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1249 #ifdef MPI
1250        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1251 #endif
1252        stop 555
1253       endif
1254       if (shield_mode.gt.0) then
1255        wscp=weights(2)*fact
1256        wsc=weights(1)*fact
1257        wvdwpp=weights(16)*fact
1258       endif
1259       welec=weights(3)*fact
1260       wcorr=weights(4)*fact3
1261       wcorr5=weights(5)*fact4
1262       wcorr6=weights(6)*fact5
1263       wel_loc=weights(7)*fact2
1264       wturn3=weights(8)*fact2
1265       wturn4=weights(9)*fact3
1266       wturn6=weights(10)*fact5
1267       wtor=weights(13)*fact
1268       wtor_d=weights(14)*fact2
1269       wsccor=weights(21)*fact
1270       if (scale_umb) wumb=t_bath/temp0
1271 c      write (iout,*) "scale_umb",scale_umb
1272 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1273
1274       return
1275       end
1276 C------------------------------------------------------------------------
1277       subroutine enerprint(energia)
1278       implicit none
1279       include 'DIMENSIONS'
1280       include 'COMMON.IOUNITS'
1281       include 'COMMON.FFIELD'
1282       include 'COMMON.SBRIDGE'
1283       include 'COMMON.QRESTR'
1284       double precision energia(0:n_ene)
1285       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1286      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1287      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1288      & eello_turn6,
1289      & eliptran,Eafmforce,Etube,
1290      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1291       etot=energia(0)
1292       evdw=energia(1)
1293       evdw2=energia(2)
1294 #ifdef SCP14
1295       evdw2=energia(2)+energia(18)
1296 #else
1297       evdw2=energia(2)
1298 #endif
1299       ees=energia(3)
1300 #ifdef SPLITELE
1301       evdw1=energia(16)
1302 #endif
1303       ecorr=energia(4)
1304       ecorr5=energia(5)
1305       ecorr6=energia(6)
1306       eel_loc=energia(7)
1307       eello_turn3=energia(8)
1308       eello_turn4=energia(9)
1309       eello_turn6=energia(10)
1310       ebe=energia(11)
1311       escloc=energia(12)
1312       etors=energia(13)
1313       etors_d=energia(14)
1314       ehpb=energia(15)
1315       edihcnstr=energia(19)
1316       estr=energia(17)
1317       Uconst=energia(20)
1318       esccor=energia(21)
1319       eliptran=energia(22)
1320       Eafmforce=energia(23)
1321       ethetacnstr=energia(24)
1322       etube=energia(25)
1323       esaxs=energia(26)
1324       ehomology_constr=energia(27)
1325 C     Bartek
1326       edfadis = energia(28)
1327       edfator = energia(29)
1328       edfanei = energia(30)
1329       edfabet = energia(31)
1330 #ifdef SPLITELE
1331       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1332      &  estr,wbond,ebe,wang,
1333      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1334 #ifdef FOURBODY
1335      &  ecorr,wcorr,
1336      &  ecorr5,wcorr5,ecorr6,wcorr6,
1337 #endif
1338      &  eel_loc,wel_loc,eello_turn3,wturn3,
1339      &  eello_turn4,wturn4,
1340 #ifdef FOURBODY
1341      &  eello_turn6,wturn6,
1342 #endif
1343      &  esccor,wsccor,edihcnstr,
1344      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1345      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1346      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1347      &  edfabet,wdfa_beta,
1348      &  etot
1349    10 format (/'Virtual-chain energies:'//
1350      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1351      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1352      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1353      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1354      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1355      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1356      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1357      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1358      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1359      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1360      & ' (SS bridges & dist. cnstr.)'/
1361 #ifdef FOURBODY
1362      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1363      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1364      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1365 #endif
1366      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1367      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1368      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1369 #ifdef FOURBODY
1370      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1371 #endif
1372      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1373      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1374      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1375      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1376      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1377      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1378      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1379      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1380      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1381      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1382      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1383      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1384      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1385      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1386      & 'ETOT=  ',1pE16.6,' (total)')
1387
1388 #else
1389       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1390      &  estr,wbond,ebe,wang,
1391      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1392 #ifdef FOURBODY
1393      &  ecorr,wcorr,
1394      &  ecorr5,wcorr5,ecorr6,wcorr6,
1395 #endif
1396      &  eel_loc,wel_loc,eello_turn3,wturn3,
1397      &  eello_turn4,wturn4,
1398 #ifdef FOURBODY
1399      &  eello_turn6,wturn6,
1400 #endif
1401      &  esccor,wsccor,edihcnstr,
1402      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1403      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1404      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1405      &  edfabet,wdfa_beta,
1406      &  etot
1407    10 format (/'Virtual-chain energies:'//
1408      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1409      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1410      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1411      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1412      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1413      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1414      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1415      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1416      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1417      & ' (SS bridges & dist. restr.)'/
1418 #ifdef FOURBODY
1419      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1420      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1421      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1422 #endif
1423      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1424      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1425      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1426 #ifdef FOURBODY
1427      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1428 #endif
1429      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1430      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1431      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1432      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1433      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1434      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1435      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1436      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1437      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1438      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1439      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1440      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1441      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1442      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1443      & 'ETOT=  ',1pE16.6,' (total)')
1444 #endif
1445       return
1446       end
1447 C-----------------------------------------------------------------------
1448       subroutine elj(evdw)
1449 C
1450 C This subroutine calculates the interaction energy of nonbonded side chains
1451 C assuming the LJ potential of interaction.
1452 C
1453       implicit none
1454       double precision accur
1455       include 'DIMENSIONS'
1456       parameter (accur=1.0d-10)
1457       include 'COMMON.GEO'
1458       include 'COMMON.VAR'
1459       include 'COMMON.LOCAL'
1460       include 'COMMON.CHAIN'
1461       include 'COMMON.DERIV'
1462       include 'COMMON.INTERACT'
1463       include 'COMMON.TORSION'
1464       include 'COMMON.SBRIDGE'
1465       include 'COMMON.NAMES'
1466       include 'COMMON.IOUNITS'
1467       include 'COMMON.SPLITELE'
1468 #ifdef FOURBODY
1469       include 'COMMON.CONTACTS'
1470       include 'COMMON.CONTMAT'
1471 #endif
1472       double precision gg(3)
1473       double precision evdw,evdwij
1474       integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1475       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1476      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1477       double precision fcont,fprimcont
1478       double precision sscale,sscagrad
1479 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1480       evdw=0.0D0
1481 c      do i=iatsc_s,iatsc_e
1482       do ikont=g_listscsc_start,g_listscsc_end
1483         i=newcontlisti(ikont)
1484         j=newcontlistj(ikont)
1485         itypi=iabs(itype(i))
1486         if (itypi.eq.ntyp1) cycle
1487         itypi1=iabs(itype(i+1))
1488         xi=c(1,nres+i)
1489         yi=c(2,nres+i)
1490         zi=c(3,nres+i)
1491 C Change 12/1/95
1492         num_conti=0
1493 C
1494 C Calculate SC interaction energy.
1495 C
1496 c        do iint=1,nint_gr(i)
1497 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1498 cd   &                  'iend=',iend(i,iint)
1499 c          do j=istart(i,iint),iend(i,iint)
1500             itypj=iabs(itype(j))
1501             if (itypj.eq.ntyp1) cycle
1502             xj=c(1,nres+j)-xi
1503             yj=c(2,nres+j)-yi
1504             zj=c(3,nres+j)-zi
1505 C Change 12/1/95 to calculate four-body interactions
1506             rij=xj*xj+yj*yj+zj*zj
1507             rrij=1.0D0/rij
1508             sqrij=dsqrt(rij)
1509             sss1=sscale(sqrij,r_cut_int)
1510             if (sss1.eq.0.0d0) cycle
1511             sssgrad1=sscagrad(sqrij,r_cut_int)
1512
1513 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1514             eps0ij=eps(itypi,itypj)
1515             fac=rrij**expon2
1516 C have you changed here?
1517             e1=fac*fac*aa
1518             e2=fac*bb
1519             evdwij=e1+e2
1520 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1521 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1522 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1523 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1524 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1525 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1526             evdw=evdw+sss1*evdwij
1527 C
1528 C Calculate the components of the gradient in DC and X
1529 C
1530             fac=-rrij*(e1+evdwij)*sss1
1531      &          +evdwij*sssgrad1/sqrij/expon
1532             gg(1)=xj*fac
1533             gg(2)=yj*fac
1534             gg(3)=zj*fac
1535             do k=1,3
1536               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1537               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1538               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1539               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1540             enddo
1541 cgrad            do k=i,j-1
1542 cgrad              do l=1,3
1543 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1544 cgrad              enddo
1545 cgrad            enddo
1546 C
1547 #ifdef FOURBODY
1548 C 12/1/95, revised on 5/20/97
1549 C
1550 C Calculate the contact function. The ith column of the array JCONT will
1551 C contain the numbers of atoms that make contacts with the atom I (of numbers
1552 C greater than I). The arrays FACONT and GACONT will contain the values of
1553 C the contact function and its derivative.
1554 C
1555 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1556 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1557 C Uncomment next line, if the correlation interactions are contact function only
1558             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1559               rij=dsqrt(rij)
1560               sigij=sigma(itypi,itypj)
1561               r0ij=rs0(itypi,itypj)
1562 C
1563 C Check whether the SC's are not too far to make a contact.
1564 C
1565               rcut=1.5d0*r0ij
1566               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1567 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1568 C
1569               if (fcont.gt.0.0D0) then
1570 C If the SC-SC distance if close to sigma, apply spline.
1571 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1572 cAdam &             fcont1,fprimcont1)
1573 cAdam           fcont1=1.0d0-fcont1
1574 cAdam           if (fcont1.gt.0.0d0) then
1575 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1576 cAdam             fcont=fcont*fcont1
1577 cAdam           endif
1578 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1579 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1580 cga             do k=1,3
1581 cga               gg(k)=gg(k)*eps0ij
1582 cga             enddo
1583 cga             eps0ij=-evdwij*eps0ij
1584 C Uncomment for AL's type of SC correlation interactions.
1585 cadam           eps0ij=-evdwij
1586                 num_conti=num_conti+1
1587                 jcont(num_conti,i)=j
1588                 facont(num_conti,i)=fcont*eps0ij
1589                 fprimcont=eps0ij*fprimcont/rij
1590                 fcont=expon*fcont
1591 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1592 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1593 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1594 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1595                 gacont(1,num_conti,i)=-fprimcont*xj
1596                 gacont(2,num_conti,i)=-fprimcont*yj
1597                 gacont(3,num_conti,i)=-fprimcont*zj
1598 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1599 cd              write (iout,'(2i3,3f10.5)')
1600 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1601               endif
1602             endif
1603 #endif
1604 c          enddo      ! j
1605 c        enddo        ! iint
1606 C Change 12/1/95
1607 #ifdef FOURBODY
1608         num_cont(i)=num_conti
1609 #endif
1610       enddo          ! i
1611       do i=1,nct
1612         do j=1,3
1613           gvdwc(j,i)=expon*gvdwc(j,i)
1614           gvdwx(j,i)=expon*gvdwx(j,i)
1615         enddo
1616       enddo
1617 C******************************************************************************
1618 C
1619 C                              N O T E !!!
1620 C
1621 C To save time, the factor of EXPON has been extracted from ALL components
1622 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1623 C use!
1624 C
1625 C******************************************************************************
1626       return
1627       end
1628 C-----------------------------------------------------------------------------
1629       subroutine eljk(evdw)
1630 C
1631 C This subroutine calculates the interaction energy of nonbonded side chains
1632 C assuming the LJK potential of interaction.
1633 C
1634       implicit none
1635       include 'DIMENSIONS'
1636       include 'COMMON.GEO'
1637       include 'COMMON.VAR'
1638       include 'COMMON.LOCAL'
1639       include 'COMMON.CHAIN'
1640       include 'COMMON.DERIV'
1641       include 'COMMON.INTERACT'
1642       include 'COMMON.IOUNITS'
1643       include 'COMMON.NAMES'
1644       include 'COMMON.SPLITELE'
1645       double precision gg(3)
1646       double precision evdw,evdwij
1647       integer i,j,k,itypi,itypj,itypi1,iint,ikont
1648       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1649      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1650       logical scheck
1651       double precision sscale,sscagrad
1652 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1653       evdw=0.0D0
1654 c      do i=iatsc_s,iatsc_e
1655       do ikont=g_listscsc_start,g_listscsc_end
1656         i=newcontlisti(ikont)
1657         j=newcontlistj(ikont)
1658         itypi=iabs(itype(i))
1659         if (itypi.eq.ntyp1) cycle
1660         itypi1=iabs(itype(i+1))
1661         xi=c(1,nres+i)
1662         yi=c(2,nres+i)
1663         zi=c(3,nres+i)
1664 C
1665 C Calculate SC interaction energy.
1666 C
1667 c        do iint=1,nint_gr(i)
1668 c          do j=istart(i,iint),iend(i,iint)
1669             itypj=iabs(itype(j))
1670             if (itypj.eq.ntyp1) cycle
1671             xj=c(1,nres+j)-xi
1672             yj=c(2,nres+j)-yi
1673             zj=c(3,nres+j)-zi
1674             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1675             fac_augm=rrij**expon
1676             e_augm=augm(itypi,itypj)*fac_augm
1677             r_inv_ij=dsqrt(rrij)
1678             rij=1.0D0/r_inv_ij
1679             sss1=sscale(rij,r_cut_int)
1680             if (sss1.eq.0.0d0) cycle
1681             sssgrad1=sscagrad(rij,r_cut_int)
1682             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1683             fac=r_shift_inv**expon
1684 C have you changed here?
1685             e1=fac*fac*aa
1686             e2=fac*bb
1687             evdwij=e_augm+e1+e2
1688 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1689 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1690 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1691 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1692 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1693 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1694 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1695             evdw=evdw+evdwij*sss1
1696 C
1697 C Calculate the components of the gradient in DC and X
1698 C
1699             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1700      &          +evdwij*sssgrad1*r_inv_ij/expon
1701             gg(1)=xj*fac
1702             gg(2)=yj*fac
1703             gg(3)=zj*fac
1704             do k=1,3
1705               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1706               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1707               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1708               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1709             enddo
1710 cgrad            do k=i,j-1
1711 cgrad              do l=1,3
1712 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1713 cgrad              enddo
1714 cgrad            enddo
1715 c          enddo      ! j
1716 c        enddo        ! iint
1717       enddo          ! i
1718       do i=1,nct
1719         do j=1,3
1720           gvdwc(j,i)=expon*gvdwc(j,i)
1721           gvdwx(j,i)=expon*gvdwx(j,i)
1722         enddo
1723       enddo
1724       return
1725       end
1726 C-----------------------------------------------------------------------------
1727       subroutine ebp(evdw)
1728 C
1729 C This subroutine calculates the interaction energy of nonbonded side chains
1730 C assuming the Berne-Pechukas potential of interaction.
1731 C
1732       implicit none
1733       include 'DIMENSIONS'
1734       include 'COMMON.GEO'
1735       include 'COMMON.VAR'
1736       include 'COMMON.LOCAL'
1737       include 'COMMON.CHAIN'
1738       include 'COMMON.DERIV'
1739       include 'COMMON.NAMES'
1740       include 'COMMON.INTERACT'
1741       include 'COMMON.IOUNITS'
1742       include 'COMMON.CALC'
1743       include 'COMMON.SPLITELE'
1744       integer icall
1745       common /srutu/ icall
1746       double precision evdw
1747       integer itypi,itypj,itypi1,iint,ind,ikont
1748       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1749      & sss1,sssgrad1
1750       double precision sscale,sscagrad
1751 c     double precision rrsave(maxdim)
1752       logical lprn
1753       evdw=0.0D0
1754 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1755       evdw=0.0D0
1756 c     if (icall.eq.0) then
1757 c       lprn=.true.
1758 c     else
1759         lprn=.false.
1760 c     endif
1761       ind=0
1762 c      do i=iatsc_s,iatsc_e
1763       do ikont=g_listscsc_start,g_listscsc_end
1764         i=newcontlisti(ikont)
1765         j=newcontlistj(ikont)
1766         itypi=iabs(itype(i))
1767         if (itypi.eq.ntyp1) cycle
1768         itypi1=iabs(itype(i+1))
1769         xi=c(1,nres+i)
1770         yi=c(2,nres+i)
1771         zi=c(3,nres+i)
1772         dxi=dc_norm(1,nres+i)
1773         dyi=dc_norm(2,nres+i)
1774         dzi=dc_norm(3,nres+i)
1775 c        dsci_inv=dsc_inv(itypi)
1776         dsci_inv=vbld_inv(i+nres)
1777 C
1778 C Calculate SC interaction energy.
1779 C
1780 c        do iint=1,nint_gr(i)
1781 c          do j=istart(i,iint),iend(i,iint)
1782             ind=ind+1
1783             itypj=iabs(itype(j))
1784             if (itypj.eq.ntyp1) cycle
1785 c            dscj_inv=dsc_inv(itypj)
1786             dscj_inv=vbld_inv(j+nres)
1787             chi1=chi(itypi,itypj)
1788             chi2=chi(itypj,itypi)
1789             chi12=chi1*chi2
1790             chip1=chip(itypi)
1791             chip2=chip(itypj)
1792             chip12=chip1*chip2
1793             alf1=alp(itypi)
1794             alf2=alp(itypj)
1795             alf12=0.5D0*(alf1+alf2)
1796 C For diagnostics only!!!
1797 c           chi1=0.0D0
1798 c           chi2=0.0D0
1799 c           chi12=0.0D0
1800 c           chip1=0.0D0
1801 c           chip2=0.0D0
1802 c           chip12=0.0D0
1803 c           alf1=0.0D0
1804 c           alf2=0.0D0
1805 c           alf12=0.0D0
1806             xj=c(1,nres+j)-xi
1807             yj=c(2,nres+j)-yi
1808             zj=c(3,nres+j)-zi
1809             dxj=dc_norm(1,nres+j)
1810             dyj=dc_norm(2,nres+j)
1811             dzj=dc_norm(3,nres+j)
1812             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1813 cd          if (icall.eq.0) then
1814 cd            rrsave(ind)=rrij
1815 cd          else
1816 cd            rrij=rrsave(ind)
1817 cd          endif
1818             rij=dsqrt(rrij)
1819             sss1=sscale(1.0d0/rij,r_cut_int)
1820             if (sss1.eq.0.0d0) cycle
1821             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1822 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1823             call sc_angular
1824 C Calculate whole angle-dependent part of epsilon and contributions
1825 C to its derivatives
1826 C have you changed here?
1827             fac=(rrij*sigsq)**expon2
1828             e1=fac*fac*aa
1829             e2=fac*bb
1830             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1831             eps2der=evdwij*eps3rt
1832             eps3der=evdwij*eps2rt
1833             evdwij=evdwij*eps2rt*eps3rt
1834             evdw=evdw+sss1*evdwij
1835             if (lprn) then
1836             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1837             epsi=bb**2/aa
1838 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1839 cd     &        restyp(itypi),i,restyp(itypj),j,
1840 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1841 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1842 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1843 cd     &        evdwij
1844             endif
1845 C Calculate gradient components.
1846             e1=e1*eps1*eps2rt**2*eps3rt**2
1847             fac=-expon*(e1+evdwij)
1848             sigder=fac/sigsq
1849             fac=rrij*fac
1850      &          +evdwij*sssgrad1/sss1*rij
1851 C Calculate radial part of the gradient
1852             gg(1)=xj*fac
1853             gg(2)=yj*fac
1854             gg(3)=zj*fac
1855 C Calculate the angular part of the gradient and sum add the contributions
1856 C to the appropriate components of the Cartesian gradient.
1857             call sc_grad
1858 !          enddo      ! j
1859 !        enddo        ! iint
1860       enddo          ! i
1861 c     stop
1862       return
1863       end
1864 C-----------------------------------------------------------------------------
1865       subroutine egb(evdw)
1866 C
1867 C This subroutine calculates the interaction energy of nonbonded side chains
1868 C assuming the Gay-Berne potential of interaction.
1869 C
1870       implicit none
1871       include 'DIMENSIONS'
1872       include 'COMMON.GEO'
1873       include 'COMMON.VAR'
1874       include 'COMMON.LOCAL'
1875       include 'COMMON.CHAIN'
1876       include 'COMMON.DERIV'
1877       include 'COMMON.NAMES'
1878       include 'COMMON.INTERACT'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.CALC'
1881       include 'COMMON.CONTROL'
1882       include 'COMMON.SPLITELE'
1883       include 'COMMON.SBRIDGE'
1884       logical lprn
1885       integer xshift,yshift,zshift,subchap
1886       double precision evdw
1887       integer itypi,itypj,itypi1,iint,ind,ikont
1888       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1889       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1890      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1891      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1892       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1893       evdw=0.0D0
1894 ccccc      energy_dec=.false.
1895 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1896       evdw=0.0D0
1897       lprn=.false.
1898 c     if (icall.eq.0) lprn=.false.
1899       ind=0
1900 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1901 C we have the original box)
1902 C      do xshift=-1,1
1903 C      do yshift=-1,1
1904 C      do zshift=-1,1
1905 c      do i=iatsc_s,iatsc_e
1906       do ikont=g_listscsc_start,g_listscsc_end
1907         i=newcontlisti(ikont)
1908         j=newcontlistj(ikont)
1909         itypi=iabs(itype(i))
1910         if (itypi.eq.ntyp1) cycle
1911         itypi1=iabs(itype(i+1))
1912         xi=c(1,nres+i)
1913         yi=c(2,nres+i)
1914         zi=c(3,nres+i)
1915 C Return atom into box, boxxsize is size of box in x dimension
1916 c  134   continue
1917 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1918 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1919 C Condition for being inside the proper box
1920 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1921 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1922 c        go to 134
1923 c        endif
1924 c  135   continue
1925 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1926 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1927 C Condition for being inside the proper box
1928 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1929 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1930 c        go to 135
1931 c        endif
1932 c  136   continue
1933 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1934 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1935 C Condition for being inside the proper box
1936 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1937 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1938 c        go to 136
1939 c        endif
1940           xi=mod(xi,boxxsize)
1941           if (xi.lt.0) xi=xi+boxxsize
1942           yi=mod(yi,boxysize)
1943           if (yi.lt.0) yi=yi+boxysize
1944           zi=mod(zi,boxzsize)
1945           if (zi.lt.0) zi=zi+boxzsize
1946 C define scaling factor for lipids
1947
1948 C        if (positi.le.0) positi=positi+boxzsize
1949 C        print *,i
1950 C first for peptide groups
1951 c for each residue check if it is in lipid or lipid water border area
1952        if ((zi.gt.bordlipbot)
1953      &.and.(zi.lt.bordliptop)) then
1954 C the energy transfer exist
1955         if (zi.lt.buflipbot) then
1956 C what fraction I am in
1957          fracinbuf=1.0d0-
1958      &        ((zi-bordlipbot)/lipbufthick)
1959 C lipbufthick is thickenes of lipid buffore
1960          sslipi=sscalelip(fracinbuf)
1961          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1962         elseif (zi.gt.bufliptop) then
1963          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1964          sslipi=sscalelip(fracinbuf)
1965          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1966         else
1967          sslipi=1.0d0
1968          ssgradlipi=0.0
1969         endif
1970        else
1971          sslipi=0.0d0
1972          ssgradlipi=0.0
1973        endif
1974
1975 C          xi=xi+xshift*boxxsize
1976 C          yi=yi+yshift*boxysize
1977 C          zi=zi+zshift*boxzsize
1978
1979         dxi=dc_norm(1,nres+i)
1980         dyi=dc_norm(2,nres+i)
1981         dzi=dc_norm(3,nres+i)
1982 c        dsci_inv=dsc_inv(itypi)
1983         dsci_inv=vbld_inv(i+nres)
1984 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1985 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1986 C
1987 C Calculate SC interaction energy.
1988 C
1989 c        do iint=1,nint_gr(i)
1990 c          do j=istart(i,iint),iend(i,iint)
1991             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1992
1993 c              write(iout,*) "PRZED ZWYKLE", evdwij
1994               call dyn_ssbond_ene(i,j,evdwij)
1995 c              write(iout,*) "PO ZWYKLE", evdwij
1996
1997               evdw=evdw+evdwij
1998               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1999      &                        'evdw',i,j,evdwij,' ss'
2000 C triple bond artifac removal
2001              do k=j+1,iend(i,iint)
2002 C search over all next residues
2003               if (dyn_ss_mask(k)) then
2004 C check if they are cysteins
2005 C              write(iout,*) 'k=',k
2006
2007 c              write(iout,*) "PRZED TRI", evdwij
2008                evdwij_przed_tri=evdwij
2009               call triple_ssbond_ene(i,j,k,evdwij)
2010 c               if(evdwij_przed_tri.ne.evdwij) then
2011 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2012 c               endif
2013
2014 c              write(iout,*) "PO TRI", evdwij
2015 C call the energy function that removes the artifical triple disulfide
2016 C bond the soubroutine is located in ssMD.F
2017               evdw=evdw+evdwij
2018               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2019      &                        'evdw',i,j,evdwij,'tss'
2020               endif!dyn_ss_mask(k)
2021              enddo! k
2022             ELSE
2023             ind=ind+1
2024             itypj=iabs(itype(j))
2025             if (itypj.eq.ntyp1) cycle
2026 c            dscj_inv=dsc_inv(itypj)
2027             dscj_inv=vbld_inv(j+nres)
2028 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2029 c     &       1.0d0/vbld(j+nres)
2030 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2031             sig0ij=sigma(itypi,itypj)
2032             chi1=chi(itypi,itypj)
2033             chi2=chi(itypj,itypi)
2034             chi12=chi1*chi2
2035             chip1=chip(itypi)
2036             chip2=chip(itypj)
2037             chip12=chip1*chip2
2038             alf1=alp(itypi)
2039             alf2=alp(itypj)
2040             alf12=0.5D0*(alf1+alf2)
2041 C For diagnostics only!!!
2042 c           chi1=0.0D0
2043 c           chi2=0.0D0
2044 c           chi12=0.0D0
2045 c           chip1=0.0D0
2046 c           chip2=0.0D0
2047 c           chip12=0.0D0
2048 c           alf1=0.0D0
2049 c           alf2=0.0D0
2050 c           alf12=0.0D0
2051             xj=c(1,nres+j)
2052             yj=c(2,nres+j)
2053             zj=c(3,nres+j)
2054 C Return atom J into box the original box
2055 c  137   continue
2056 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2057 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2058 C Condition for being inside the proper box
2059 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2060 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2061 c        go to 137
2062 c        endif
2063 c  138   continue
2064 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2065 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2066 C Condition for being inside the proper box
2067 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2068 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2069 c        go to 138
2070 c        endif
2071 c  139   continue
2072 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2073 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2074 C Condition for being inside the proper box
2075 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2076 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2077 c        go to 139
2078 c        endif
2079           xj=mod(xj,boxxsize)
2080           if (xj.lt.0) xj=xj+boxxsize
2081           yj=mod(yj,boxysize)
2082           if (yj.lt.0) yj=yj+boxysize
2083           zj=mod(zj,boxzsize)
2084           if (zj.lt.0) zj=zj+boxzsize
2085        if ((zj.gt.bordlipbot)
2086      &.and.(zj.lt.bordliptop)) then
2087 C the energy transfer exist
2088         if (zj.lt.buflipbot) then
2089 C what fraction I am in
2090          fracinbuf=1.0d0-
2091      &        ((zj-bordlipbot)/lipbufthick)
2092 C lipbufthick is thickenes of lipid buffore
2093          sslipj=sscalelip(fracinbuf)
2094          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2095         elseif (zj.gt.bufliptop) then
2096          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2097          sslipj=sscalelip(fracinbuf)
2098          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2099         else
2100          sslipj=1.0d0
2101          ssgradlipj=0.0
2102         endif
2103        else
2104          sslipj=0.0d0
2105          ssgradlipj=0.0
2106        endif
2107       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2108      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2109       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2110      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2111 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2112 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2113 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2114 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2115 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2116       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2117       xj_safe=xj
2118       yj_safe=yj
2119       zj_safe=zj
2120       subchap=0
2121       do xshift=-1,1
2122       do yshift=-1,1
2123       do zshift=-1,1
2124           xj=xj_safe+xshift*boxxsize
2125           yj=yj_safe+yshift*boxysize
2126           zj=zj_safe+zshift*boxzsize
2127           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2128           if(dist_temp.lt.dist_init) then
2129             dist_init=dist_temp
2130             xj_temp=xj
2131             yj_temp=yj
2132             zj_temp=zj
2133             subchap=1
2134           endif
2135        enddo
2136        enddo
2137        enddo
2138        if (subchap.eq.1) then
2139           xj=xj_temp-xi
2140           yj=yj_temp-yi
2141           zj=zj_temp-zi
2142        else
2143           xj=xj_safe-xi
2144           yj=yj_safe-yi
2145           zj=zj_safe-zi
2146        endif
2147             dxj=dc_norm(1,nres+j)
2148             dyj=dc_norm(2,nres+j)
2149             dzj=dc_norm(3,nres+j)
2150 C            xj=xj-xi
2151 C            yj=yj-yi
2152 C            zj=zj-zi
2153 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2154 c            write (iout,*) "j",j," dc_norm",
2155 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2156             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2157             rij=dsqrt(rrij)
2158             sss=sscale(1.0d0/rij,r_cut_int)
2159 c            write (iout,'(a7,4f8.3)')
2160 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2161             if (sss.eq.0.0d0) cycle
2162             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2163 C Calculate angle-dependent terms of energy and contributions to their
2164 C derivatives.
2165             call sc_angular
2166             sigsq=1.0D0/sigsq
2167             sig=sig0ij*dsqrt(sigsq)
2168             rij_shift=1.0D0/rij-sig+sig0ij
2169 c for diagnostics; uncomment
2170 c            rij_shift=1.2*sig0ij
2171 C I hate to put IF's in the loops, but here don't have another choice!!!!
2172             if (rij_shift.le.0.0D0) then
2173               evdw=1.0D20
2174 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2175 cd     &        restyp(itypi),i,restyp(itypj),j,
2176 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2177               return
2178             endif
2179             sigder=-sig*sigsq
2180 c---------------------------------------------------------------
2181             rij_shift=1.0D0/rij_shift
2182             fac=rij_shift**expon
2183 C here to start with
2184 C            if (c(i,3).gt.
2185             faclip=fac
2186             e1=fac*fac*aa
2187             e2=fac*bb
2188             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2189             eps2der=evdwij*eps3rt
2190             eps3der=evdwij*eps2rt
2191 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2192 C     &((sslipi+sslipj)/2.0d0+
2193 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2194 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2195 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2196             evdwij=evdwij*eps2rt*eps3rt
2197             evdw=evdw+evdwij*sss
2198             if (lprn) then
2199             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2200             epsi=bb**2/aa
2201             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2202      &        restyp(itypi),i,restyp(itypj),j,
2203      &        epsi,sigm,chi1,chi2,chip1,chip2,
2204      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2205      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2206      &        evdwij
2207             endif
2208
2209             if (energy_dec) write (iout,'(a,2i5,3f10.5)')
2210      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2211
2212 C Calculate gradient components.
2213             e1=e1*eps1*eps2rt**2*eps3rt**2
2214             fac=-expon*(e1+evdwij)*rij_shift
2215             sigder=fac*sigder
2216             fac=rij*fac
2217 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2218 c     &      evdwij,fac,sigma(itypi,itypj),expon
2219             fac=fac+evdwij*sssgrad/sss*rij
2220 c            fac=0.0d0
2221 C Calculate the radial part of the gradient
2222             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2223      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2224      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2225      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2226             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2227             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2228 C            gg_lipi(3)=0.0d0
2229 C            gg_lipj(3)=0.0d0
2230             gg(1)=xj*fac
2231             gg(2)=yj*fac
2232             gg(3)=zj*fac
2233 C Calculate angular part of the gradient.
2234 c            call sc_grad_scale(sss)
2235             call sc_grad
2236             ENDIF    ! dyn_ss
2237 c          enddo      ! j
2238 c        enddo        ! iint
2239       enddo          ! i
2240 C      enddo          ! zshift
2241 C      enddo          ! yshift
2242 C      enddo          ! xshift
2243 c      write (iout,*) "Number of loop steps in EGB:",ind
2244 cccc      energy_dec=.false.
2245       return
2246       end
2247 C-----------------------------------------------------------------------------
2248       subroutine egbv(evdw)
2249 C
2250 C This subroutine calculates the interaction energy of nonbonded side chains
2251 C assuming the Gay-Berne-Vorobjev potential of interaction.
2252 C
2253       implicit none
2254       include 'DIMENSIONS'
2255       include 'COMMON.GEO'
2256       include 'COMMON.VAR'
2257       include 'COMMON.LOCAL'
2258       include 'COMMON.CHAIN'
2259       include 'COMMON.DERIV'
2260       include 'COMMON.NAMES'
2261       include 'COMMON.INTERACT'
2262       include 'COMMON.IOUNITS'
2263       include 'COMMON.CALC'
2264       include 'COMMON.SPLITELE'
2265       integer xshift,yshift,zshift,subchap
2266       integer icall
2267       common /srutu/ icall
2268       logical lprn
2269       double precision evdw
2270       integer itypi,itypj,itypi1,iint,ind,ikont
2271       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2272      & xi,yi,zi,fac_augm,e_augm
2273       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2274      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2275      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip,sssgrad1
2276       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2277       evdw=0.0D0
2278 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2279       evdw=0.0D0
2280       lprn=.false.
2281 c     if (icall.eq.0) lprn=.true.
2282       ind=0
2283 c      do i=iatsc_s,iatsc_e
2284       do ikont=g_listscsc_start,g_listscsc_end
2285         i=newcontlisti(ikont)
2286         j=newcontlistj(ikont)
2287         itypi=iabs(itype(i))
2288         if (itypi.eq.ntyp1) cycle
2289         itypi1=iabs(itype(i+1))
2290         xi=c(1,nres+i)
2291         yi=c(2,nres+i)
2292         zi=c(3,nres+i)
2293           xi=mod(xi,boxxsize)
2294           if (xi.lt.0) xi=xi+boxxsize
2295           yi=mod(yi,boxysize)
2296           if (yi.lt.0) yi=yi+boxysize
2297           zi=mod(zi,boxzsize)
2298           if (zi.lt.0) zi=zi+boxzsize
2299 C define scaling factor for lipids
2300
2301 C        if (positi.le.0) positi=positi+boxzsize
2302 C        print *,i
2303 C first for peptide groups
2304 c for each residue check if it is in lipid or lipid water border area
2305        if ((zi.gt.bordlipbot)
2306      &.and.(zi.lt.bordliptop)) then
2307 C the energy transfer exist
2308         if (zi.lt.buflipbot) then
2309 C what fraction I am in
2310          fracinbuf=1.0d0-
2311      &        ((zi-bordlipbot)/lipbufthick)
2312 C lipbufthick is thickenes of lipid buffore
2313          sslipi=sscalelip(fracinbuf)
2314          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2315         elseif (zi.gt.bufliptop) then
2316          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2317          sslipi=sscalelip(fracinbuf)
2318          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2319         else
2320          sslipi=1.0d0
2321          ssgradlipi=0.0
2322         endif
2323        else
2324          sslipi=0.0d0
2325          ssgradlipi=0.0
2326        endif
2327
2328         dxi=dc_norm(1,nres+i)
2329         dyi=dc_norm(2,nres+i)
2330         dzi=dc_norm(3,nres+i)
2331 c        dsci_inv=dsc_inv(itypi)
2332         dsci_inv=vbld_inv(i+nres)
2333 C
2334 C Calculate SC interaction energy.
2335 C
2336 c        do iint=1,nint_gr(i)
2337 c          do j=istart(i,iint),iend(i,iint)
2338             ind=ind+1
2339             itypj=iabs(itype(j))
2340             if (itypj.eq.ntyp1) cycle
2341 c            dscj_inv=dsc_inv(itypj)
2342             dscj_inv=vbld_inv(j+nres)
2343             sig0ij=sigma(itypi,itypj)
2344             r0ij=r0(itypi,itypj)
2345             chi1=chi(itypi,itypj)
2346             chi2=chi(itypj,itypi)
2347             chi12=chi1*chi2
2348             chip1=chip(itypi)
2349             chip2=chip(itypj)
2350             chip12=chip1*chip2
2351             alf1=alp(itypi)
2352             alf2=alp(itypj)
2353             alf12=0.5D0*(alf1+alf2)
2354 C For diagnostics only!!!
2355 c           chi1=0.0D0
2356 c           chi2=0.0D0
2357 c           chi12=0.0D0
2358 c           chip1=0.0D0
2359 c           chip2=0.0D0
2360 c           chip12=0.0D0
2361 c           alf1=0.0D0
2362 c           alf2=0.0D0
2363 c           alf12=0.0D0
2364 C            xj=c(1,nres+j)-xi
2365 C            yj=c(2,nres+j)-yi
2366 C            zj=c(3,nres+j)-zi
2367           xj=mod(xj,boxxsize)
2368           if (xj.lt.0) xj=xj+boxxsize
2369           yj=mod(yj,boxysize)
2370           if (yj.lt.0) yj=yj+boxysize
2371           zj=mod(zj,boxzsize)
2372           if (zj.lt.0) zj=zj+boxzsize
2373        if ((zj.gt.bordlipbot)
2374      &.and.(zj.lt.bordliptop)) then
2375 C the energy transfer exist
2376         if (zj.lt.buflipbot) then
2377 C what fraction I am in
2378          fracinbuf=1.0d0-
2379      &        ((zj-bordlipbot)/lipbufthick)
2380 C lipbufthick is thickenes of lipid buffore
2381          sslipj=sscalelip(fracinbuf)
2382          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2383         elseif (zj.gt.bufliptop) then
2384          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2385          sslipj=sscalelip(fracinbuf)
2386          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2387         else
2388          sslipj=1.0d0
2389          ssgradlipj=0.0
2390         endif
2391        else
2392          sslipj=0.0d0
2393          ssgradlipj=0.0
2394        endif
2395       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2396      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2397       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2398      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2399 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2400 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2401 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2402       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2403       xj_safe=xj
2404       yj_safe=yj
2405       zj_safe=zj
2406       subchap=0
2407       do xshift=-1,1
2408       do yshift=-1,1
2409       do zshift=-1,1
2410           xj=xj_safe+xshift*boxxsize
2411           yj=yj_safe+yshift*boxysize
2412           zj=zj_safe+zshift*boxzsize
2413           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2414           if(dist_temp.lt.dist_init) then
2415             dist_init=dist_temp
2416             xj_temp=xj
2417             yj_temp=yj
2418             zj_temp=zj
2419             subchap=1
2420           endif
2421        enddo
2422        enddo
2423        enddo
2424        if (subchap.eq.1) then
2425           xj=xj_temp-xi
2426           yj=yj_temp-yi
2427           zj=zj_temp-zi
2428        else
2429           xj=xj_safe-xi
2430           yj=yj_safe-yi
2431           zj=zj_safe-zi
2432        endif
2433             dxj=dc_norm(1,nres+j)
2434             dyj=dc_norm(2,nres+j)
2435             dzj=dc_norm(3,nres+j)
2436             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2437             rij=dsqrt(rrij)
2438             sss=sscale(1.0d0/rij,r_cut_int)
2439             if (sss.eq.0.0d0) cycle
2440             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2441 C Calculate angle-dependent terms of energy and contributions to their
2442 C derivatives.
2443             call sc_angular
2444             sigsq=1.0D0/sigsq
2445             sig=sig0ij*dsqrt(sigsq)
2446             rij_shift=1.0D0/rij-sig+r0ij
2447 C I hate to put IF's in the loops, but here don't have another choice!!!!
2448             if (rij_shift.le.0.0D0) then
2449               evdw=1.0D20
2450               return
2451             endif
2452             sigder=-sig*sigsq
2453 c---------------------------------------------------------------
2454             rij_shift=1.0D0/rij_shift
2455             fac=rij_shift**expon
2456             e1=fac*fac*aa
2457             e2=fac*bb
2458             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2459             eps2der=evdwij*eps3rt
2460             eps3der=evdwij*eps2rt
2461             fac_augm=rrij**expon
2462             e_augm=augm(itypi,itypj)*fac_augm
2463             evdwij=evdwij*eps2rt*eps3rt
2464             evdw=evdw+evdwij+e_augm
2465             if (lprn) then
2466             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2467             epsi=bb**2/aa
2468             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2469      &        restyp(itypi),i,restyp(itypj),j,
2470      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2471      &        chi1,chi2,chip1,chip2,
2472      &        eps1,eps2rt**2,eps3rt**2,
2473      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2474      &        evdwij+e_augm
2475             endif
2476 C Calculate gradient components.
2477             e1=e1*eps1*eps2rt**2*eps3rt**2
2478             fac=-expon*(e1+evdwij)*rij_shift
2479             sigder=fac*sigder
2480             fac=rij*fac-2*expon*rrij*e_augm
2481             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2482 C Calculate the radial part of the gradient
2483             gg(1)=xj*fac
2484             gg(2)=yj*fac
2485             gg(3)=zj*fac
2486 C Calculate angular part of the gradient.
2487 c            call sc_grad_scale(sss)
2488             call sc_grad
2489 c          enddo      ! j
2490 c        enddo        ! iint
2491       enddo          ! i
2492       end
2493 C-----------------------------------------------------------------------------
2494       subroutine sc_angular
2495 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2496 C om12. Called by ebp, egb, and egbv.
2497       implicit none
2498       include 'COMMON.CALC'
2499       include 'COMMON.IOUNITS'
2500       erij(1)=xj*rij
2501       erij(2)=yj*rij
2502       erij(3)=zj*rij
2503       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2504       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2505       om12=dxi*dxj+dyi*dyj+dzi*dzj
2506       chiom12=chi12*om12
2507 C Calculate eps1(om12) and its derivative in om12
2508       faceps1=1.0D0-om12*chiom12
2509       faceps1_inv=1.0D0/faceps1
2510       eps1=dsqrt(faceps1_inv)
2511 C Following variable is eps1*deps1/dom12
2512       eps1_om12=faceps1_inv*chiom12
2513 c diagnostics only
2514 c      faceps1_inv=om12
2515 c      eps1=om12
2516 c      eps1_om12=1.0d0
2517 c      write (iout,*) "om12",om12," eps1",eps1
2518 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2519 C and om12.
2520       om1om2=om1*om2
2521       chiom1=chi1*om1
2522       chiom2=chi2*om2
2523       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2524       sigsq=1.0D0-facsig*faceps1_inv
2525       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2526       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2527       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2528 c diagnostics only
2529 c      sigsq=1.0d0
2530 c      sigsq_om1=0.0d0
2531 c      sigsq_om2=0.0d0
2532 c      sigsq_om12=0.0d0
2533 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2534 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2535 c     &    " eps1",eps1
2536 C Calculate eps2 and its derivatives in om1, om2, and om12.
2537       chipom1=chip1*om1
2538       chipom2=chip2*om2
2539       chipom12=chip12*om12
2540       facp=1.0D0-om12*chipom12
2541       facp_inv=1.0D0/facp
2542       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2543 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2544 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2545 C Following variable is the square root of eps2
2546       eps2rt=1.0D0-facp1*facp_inv
2547 C Following three variables are the derivatives of the square root of eps
2548 C in om1, om2, and om12.
2549       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2550       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2551       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2552 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2553       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2554 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2555 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2556 c     &  " eps2rt_om12",eps2rt_om12
2557 C Calculate whole angle-dependent part of epsilon and contributions
2558 C to its derivatives
2559       return
2560       end
2561 C----------------------------------------------------------------------------
2562       subroutine sc_grad
2563       implicit real*8 (a-h,o-z)
2564       include 'DIMENSIONS'
2565       include 'COMMON.CHAIN'
2566       include 'COMMON.DERIV'
2567       include 'COMMON.CALC'
2568       include 'COMMON.IOUNITS'
2569       double precision dcosom1(3),dcosom2(3)
2570 cc      print *,'sss=',sss
2571       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2572       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2573       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2574      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2575 c diagnostics only
2576 c      eom1=0.0d0
2577 c      eom2=0.0d0
2578 c      eom12=evdwij*eps1_om12
2579 c end diagnostics
2580 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2581 c     &  " sigder",sigder
2582 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2583 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2584       do k=1,3
2585         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2586         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2587       enddo
2588       do k=1,3
2589         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2590       enddo
2591 c      write (iout,*) "gg",(gg(k),k=1,3)
2592       do k=1,3
2593         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2594      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2595      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2596         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2597      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2598      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2599 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2600 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2601 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2602 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2603       enddo
2604 C
2605 C Calculate the components of the gradient in DC and X
2606 C
2607 cgrad      do k=i,j-1
2608 cgrad        do l=1,3
2609 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2610 cgrad        enddo
2611 cgrad      enddo
2612       do l=1,3
2613         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2614         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2615       enddo
2616       return
2617       end
2618 C-----------------------------------------------------------------------
2619       subroutine e_softsphere(evdw)
2620 C
2621 C This subroutine calculates the interaction energy of nonbonded side chains
2622 C assuming the LJ potential of interaction.
2623 C
2624       implicit real*8 (a-h,o-z)
2625       include 'DIMENSIONS'
2626       parameter (accur=1.0d-10)
2627       include 'COMMON.GEO'
2628       include 'COMMON.VAR'
2629       include 'COMMON.LOCAL'
2630       include 'COMMON.CHAIN'
2631       include 'COMMON.DERIV'
2632       include 'COMMON.INTERACT'
2633       include 'COMMON.TORSION'
2634       include 'COMMON.SBRIDGE'
2635       include 'COMMON.NAMES'
2636       include 'COMMON.IOUNITS'
2637 c      include 'COMMON.CONTACTS'
2638       dimension gg(3)
2639 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2640       evdw=0.0D0
2641 c      do i=iatsc_s,iatsc_e
2642       do ikont=g_listscsc_start,g_listscsc_end
2643         i=newcontlisti(ikont)
2644         j=newcontlistj(ikont)
2645         itypi=iabs(itype(i))
2646         if (itypi.eq.ntyp1) cycle
2647         itypi1=iabs(itype(i+1))
2648         xi=c(1,nres+i)
2649         yi=c(2,nres+i)
2650         zi=c(3,nres+i)
2651 C
2652 C Calculate SC interaction energy.
2653 C
2654 c        do iint=1,nint_gr(i)
2655 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2656 cd   &                  'iend=',iend(i,iint)
2657 c          do j=istart(i,iint),iend(i,iint)
2658             itypj=iabs(itype(j))
2659             if (itypj.eq.ntyp1) cycle
2660             xj=c(1,nres+j)-xi
2661             yj=c(2,nres+j)-yi
2662             zj=c(3,nres+j)-zi
2663             rij=xj*xj+yj*yj+zj*zj
2664 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2665             r0ij=r0(itypi,itypj)
2666             r0ijsq=r0ij*r0ij
2667 c            print *,i,j,r0ij,dsqrt(rij)
2668             if (rij.lt.r0ijsq) then
2669               evdwij=0.25d0*(rij-r0ijsq)**2
2670               fac=rij-r0ijsq
2671             else
2672               evdwij=0.0d0
2673               fac=0.0d0
2674             endif
2675             evdw=evdw+evdwij
2676 C
2677 C Calculate the components of the gradient in DC and X
2678 C
2679             gg(1)=xj*fac
2680             gg(2)=yj*fac
2681             gg(3)=zj*fac
2682             do k=1,3
2683               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2684               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2685               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2686               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2687             enddo
2688 cgrad            do k=i,j-1
2689 cgrad              do l=1,3
2690 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2691 cgrad              enddo
2692 cgrad            enddo
2693 c          enddo ! j
2694 c        enddo ! iint
2695       enddo ! i
2696       return
2697       end
2698 C--------------------------------------------------------------------------
2699       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2700      &              eello_turn4)
2701 C
2702 C Soft-sphere potential of p-p interaction
2703 C
2704       implicit real*8 (a-h,o-z)
2705       include 'DIMENSIONS'
2706       include 'COMMON.CONTROL'
2707       include 'COMMON.IOUNITS'
2708       include 'COMMON.GEO'
2709       include 'COMMON.VAR'
2710       include 'COMMON.LOCAL'
2711       include 'COMMON.CHAIN'
2712       include 'COMMON.DERIV'
2713       include 'COMMON.INTERACT'
2714 c      include 'COMMON.CONTACTS'
2715       include 'COMMON.TORSION'
2716       include 'COMMON.VECTORS'
2717       include 'COMMON.FFIELD'
2718       dimension ggg(3)
2719       integer xshift,yshift,zshift
2720 C      write(iout,*) 'In EELEC_soft_sphere'
2721       ees=0.0D0
2722       evdw1=0.0D0
2723       eel_loc=0.0d0
2724       eello_turn3=0.0d0
2725       eello_turn4=0.0d0
2726       ind=0
2727       do i=iatel_s,iatel_e
2728         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2729         dxi=dc(1,i)
2730         dyi=dc(2,i)
2731         dzi=dc(3,i)
2732         xmedi=c(1,i)+0.5d0*dxi
2733         ymedi=c(2,i)+0.5d0*dyi
2734         zmedi=c(3,i)+0.5d0*dzi
2735           xmedi=mod(xmedi,boxxsize)
2736           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2737           ymedi=mod(ymedi,boxysize)
2738           if (ymedi.lt.0) ymedi=ymedi+boxysize
2739           zmedi=mod(zmedi,boxzsize)
2740           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2741         num_conti=0
2742 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2743         do j=ielstart(i),ielend(i)
2744           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2745           ind=ind+1
2746           iteli=itel(i)
2747           itelj=itel(j)
2748           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2749           r0ij=rpp(iteli,itelj)
2750           r0ijsq=r0ij*r0ij
2751           dxj=dc(1,j)
2752           dyj=dc(2,j)
2753           dzj=dc(3,j)
2754           xj=c(1,j)+0.5D0*dxj
2755           yj=c(2,j)+0.5D0*dyj
2756           zj=c(3,j)+0.5D0*dzj
2757           xj=mod(xj,boxxsize)
2758           if (xj.lt.0) xj=xj+boxxsize
2759           yj=mod(yj,boxysize)
2760           if (yj.lt.0) yj=yj+boxysize
2761           zj=mod(zj,boxzsize)
2762           if (zj.lt.0) zj=zj+boxzsize
2763       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2764       xj_safe=xj
2765       yj_safe=yj
2766       zj_safe=zj
2767       isubchap=0
2768       do xshift=-1,1
2769       do yshift=-1,1
2770       do zshift=-1,1
2771           xj=xj_safe+xshift*boxxsize
2772           yj=yj_safe+yshift*boxysize
2773           zj=zj_safe+zshift*boxzsize
2774           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2775           if(dist_temp.lt.dist_init) then
2776             dist_init=dist_temp
2777             xj_temp=xj
2778             yj_temp=yj
2779             zj_temp=zj
2780             isubchap=1
2781           endif
2782        enddo
2783        enddo
2784        enddo
2785        if (isubchap.eq.1) then
2786           xj=xj_temp-xmedi
2787           yj=yj_temp-ymedi
2788           zj=zj_temp-zmedi
2789        else
2790           xj=xj_safe-xmedi
2791           yj=yj_safe-ymedi
2792           zj=zj_safe-zmedi
2793        endif
2794           rij=xj*xj+yj*yj+zj*zj
2795             sss=sscale(sqrt(rij),r_cut_int)
2796             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2797           if (rij.lt.r0ijsq) then
2798             evdw1ij=0.25d0*(rij-r0ijsq)**2
2799             fac=rij-r0ijsq
2800           else
2801             evdw1ij=0.0d0
2802             fac=0.0d0
2803           endif
2804           evdw1=evdw1+evdw1ij*sss
2805 C
2806 C Calculate contributions to the Cartesian gradient.
2807 C
2808           ggg(1)=fac*xj*sssgrad
2809           ggg(2)=fac*yj*sssgrad
2810           ggg(3)=fac*zj*sssgrad
2811           do k=1,3
2812             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2813             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2814           enddo
2815 *
2816 * Loop over residues i+1 thru j-1.
2817 *
2818 cgrad          do k=i+1,j-1
2819 cgrad            do l=1,3
2820 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2821 cgrad            enddo
2822 cgrad          enddo
2823         enddo ! j
2824       enddo   ! i
2825 cgrad      do i=nnt,nct-1
2826 cgrad        do k=1,3
2827 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2828 cgrad        enddo
2829 cgrad        do j=i+1,nct-1
2830 cgrad          do k=1,3
2831 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2832 cgrad          enddo
2833 cgrad        enddo
2834 cgrad      enddo
2835       return
2836       end
2837 c------------------------------------------------------------------------------
2838       subroutine vec_and_deriv
2839       implicit real*8 (a-h,o-z)
2840       include 'DIMENSIONS'
2841 #ifdef MPI
2842       include 'mpif.h'
2843 #endif
2844       include 'COMMON.IOUNITS'
2845       include 'COMMON.GEO'
2846       include 'COMMON.VAR'
2847       include 'COMMON.LOCAL'
2848       include 'COMMON.CHAIN'
2849       include 'COMMON.VECTORS'
2850       include 'COMMON.SETUP'
2851       include 'COMMON.TIME1'
2852       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2853 C Compute the local reference systems. For reference system (i), the
2854 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2855 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2856 #ifdef PARVEC
2857       do i=ivec_start,ivec_end
2858 #else
2859       do i=1,nres-1
2860 #endif
2861           if (i.eq.nres-1) then
2862 C Case of the last full residue
2863 C Compute the Z-axis
2864             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2865             costh=dcos(pi-theta(nres))
2866             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2867             do k=1,3
2868               uz(k,i)=fac*uz(k,i)
2869             enddo
2870 C Compute the derivatives of uz
2871             uzder(1,1,1)= 0.0d0
2872             uzder(2,1,1)=-dc_norm(3,i-1)
2873             uzder(3,1,1)= dc_norm(2,i-1)
2874             uzder(1,2,1)= dc_norm(3,i-1)
2875             uzder(2,2,1)= 0.0d0
2876             uzder(3,2,1)=-dc_norm(1,i-1)
2877             uzder(1,3,1)=-dc_norm(2,i-1)
2878             uzder(2,3,1)= dc_norm(1,i-1)
2879             uzder(3,3,1)= 0.0d0
2880             uzder(1,1,2)= 0.0d0
2881             uzder(2,1,2)= dc_norm(3,i)
2882             uzder(3,1,2)=-dc_norm(2,i)
2883             uzder(1,2,2)=-dc_norm(3,i)
2884             uzder(2,2,2)= 0.0d0
2885             uzder(3,2,2)= dc_norm(1,i)
2886             uzder(1,3,2)= dc_norm(2,i)
2887             uzder(2,3,2)=-dc_norm(1,i)
2888             uzder(3,3,2)= 0.0d0
2889 C Compute the Y-axis
2890             facy=fac
2891             do k=1,3
2892               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2893             enddo
2894 C Compute the derivatives of uy
2895             do j=1,3
2896               do k=1,3
2897                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2898      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2899                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2900               enddo
2901               uyder(j,j,1)=uyder(j,j,1)-costh
2902               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2903             enddo
2904             do j=1,2
2905               do k=1,3
2906                 do l=1,3
2907                   uygrad(l,k,j,i)=uyder(l,k,j)
2908                   uzgrad(l,k,j,i)=uzder(l,k,j)
2909                 enddo
2910               enddo
2911             enddo
2912             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2913             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2914             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2915             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2916           else
2917 C Other residues
2918 C Compute the Z-axis
2919             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2920             costh=dcos(pi-theta(i+2))
2921             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2922             do k=1,3
2923               uz(k,i)=fac*uz(k,i)
2924             enddo
2925 C Compute the derivatives of uz
2926             uzder(1,1,1)= 0.0d0
2927             uzder(2,1,1)=-dc_norm(3,i+1)
2928             uzder(3,1,1)= dc_norm(2,i+1)
2929             uzder(1,2,1)= dc_norm(3,i+1)
2930             uzder(2,2,1)= 0.0d0
2931             uzder(3,2,1)=-dc_norm(1,i+1)
2932             uzder(1,3,1)=-dc_norm(2,i+1)
2933             uzder(2,3,1)= dc_norm(1,i+1)
2934             uzder(3,3,1)= 0.0d0
2935             uzder(1,1,2)= 0.0d0
2936             uzder(2,1,2)= dc_norm(3,i)
2937             uzder(3,1,2)=-dc_norm(2,i)
2938             uzder(1,2,2)=-dc_norm(3,i)
2939             uzder(2,2,2)= 0.0d0
2940             uzder(3,2,2)= dc_norm(1,i)
2941             uzder(1,3,2)= dc_norm(2,i)
2942             uzder(2,3,2)=-dc_norm(1,i)
2943             uzder(3,3,2)= 0.0d0
2944 C Compute the Y-axis
2945             facy=fac
2946             do k=1,3
2947               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2948             enddo
2949 C Compute the derivatives of uy
2950             do j=1,3
2951               do k=1,3
2952                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2953      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2954                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2955               enddo
2956               uyder(j,j,1)=uyder(j,j,1)-costh
2957               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2958             enddo
2959             do j=1,2
2960               do k=1,3
2961                 do l=1,3
2962                   uygrad(l,k,j,i)=uyder(l,k,j)
2963                   uzgrad(l,k,j,i)=uzder(l,k,j)
2964                 enddo
2965               enddo
2966             enddo
2967             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2968             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2969             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2970             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2971           endif
2972       enddo
2973       do i=1,nres-1
2974         vbld_inv_temp(1)=vbld_inv(i+1)
2975         if (i.lt.nres-1) then
2976           vbld_inv_temp(2)=vbld_inv(i+2)
2977           else
2978           vbld_inv_temp(2)=vbld_inv(i)
2979           endif
2980         do j=1,2
2981           do k=1,3
2982             do l=1,3
2983               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2984               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2985             enddo
2986           enddo
2987         enddo
2988       enddo
2989 #if defined(PARVEC) && defined(MPI)
2990       if (nfgtasks1.gt.1) then
2991         time00=MPI_Wtime()
2992 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2993 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2994 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2995         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2996      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2997      &   FG_COMM1,IERR)
2998         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2999      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
3000      &   FG_COMM1,IERR)
3001         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
3002      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
3003      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
3004         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
3005      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
3006      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
3007         time_gather=time_gather+MPI_Wtime()-time00
3008       endif
3009 #endif
3010 #ifdef DEBUG
3011       if (fg_rank.eq.0) then
3012         write (iout,*) "Arrays UY and UZ"
3013         do i=1,nres-1
3014           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
3015      &     (uz(k,i),k=1,3)
3016         enddo
3017       endif
3018 #endif
3019       return
3020       end
3021 C--------------------------------------------------------------------------
3022       subroutine set_matrices
3023       implicit real*8 (a-h,o-z)
3024       include 'DIMENSIONS'
3025 #ifdef MPI
3026       include "mpif.h"
3027       include "COMMON.SETUP"
3028       integer IERR
3029       integer status(MPI_STATUS_SIZE)
3030 #endif
3031       include 'COMMON.IOUNITS'
3032       include 'COMMON.GEO'
3033       include 'COMMON.VAR'
3034       include 'COMMON.LOCAL'
3035       include 'COMMON.CHAIN'
3036       include 'COMMON.DERIV'
3037       include 'COMMON.INTERACT'
3038       include 'COMMON.CORRMAT'
3039       include 'COMMON.TORSION'
3040       include 'COMMON.VECTORS'
3041       include 'COMMON.FFIELD'
3042       double precision auxvec(2),auxmat(2,2)
3043 C
3044 C Compute the virtual-bond-torsional-angle dependent quantities needed
3045 C to calculate the el-loc multibody terms of various order.
3046 C
3047 c      write(iout,*) 'nphi=',nphi,nres
3048 c      write(iout,*) "itype2loc",itype2loc
3049 #ifdef PARMAT
3050       do i=ivec_start+2,ivec_end+2
3051 #else
3052       do i=3,nres+1
3053 #endif
3054         ii=ireschain(i-2)
3055 c        write (iout,*) "i",i,i-2," ii",ii
3056         if (ii.eq.0) cycle
3057         innt=chain_border(1,ii)
3058         inct=chain_border(2,ii)
3059 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3060 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3061         if (i.gt. innt+2 .and. i.lt.inct+2) then
3062           iti = itype2loc(itype(i-2))
3063         else
3064           iti=nloctyp
3065         endif
3066 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3067         if (i.gt. innt+1 .and. i.lt.inct+1) then
3068           iti1 = itype2loc(itype(i-1))
3069         else
3070           iti1=nloctyp
3071         endif
3072 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3073 c     &  " iti1",itype(i-1),iti1
3074 #ifdef NEWCORR
3075         cost1=dcos(theta(i-1))
3076         sint1=dsin(theta(i-1))
3077         sint1sq=sint1*sint1
3078         sint1cub=sint1sq*sint1
3079         sint1cost1=2*sint1*cost1
3080 c        write (iout,*) "bnew1",i,iti
3081 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
3082 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3083 c        write (iout,*) "bnew2",i,iti
3084 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3085 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3086         do k=1,2
3087           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3088           b1(k,i-2)=sint1*b1k
3089           gtb1(k,i-2)=cost1*b1k-sint1sq*
3090      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3091           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3092           b2(k,i-2)=sint1*b2k
3093           gtb2(k,i-2)=cost1*b2k-sint1sq*
3094      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3095         enddo
3096         do k=1,2
3097           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3098           cc(1,k,i-2)=sint1sq*aux
3099           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3100      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3101           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3102           dd(1,k,i-2)=sint1sq*aux
3103           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3104      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3105         enddo
3106         cc(2,1,i-2)=cc(1,2,i-2)
3107         cc(2,2,i-2)=-cc(1,1,i-2)
3108         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3109         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3110         dd(2,1,i-2)=dd(1,2,i-2)
3111         dd(2,2,i-2)=-dd(1,1,i-2)
3112         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3113         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3114         do k=1,2
3115           do l=1,2
3116             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3117             EE(l,k,i-2)=sint1sq*aux
3118             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3119           enddo
3120         enddo
3121         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3122         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3123         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3124         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3125         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3126         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3127         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3128 c        b1tilde(1,i-2)=b1(1,i-2)
3129 c        b1tilde(2,i-2)=-b1(2,i-2)
3130 c        b2tilde(1,i-2)=b2(1,i-2)
3131 c        b2tilde(2,i-2)=-b2(2,i-2)
3132 #ifdef DEBUG
3133         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3134         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3135         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3136         write (iout,*) 'theta=', theta(i-1)
3137 #endif
3138 #else
3139         if (i.gt. innt+2 .and. i.lt.inct+2) then
3140 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3141           iti = itype2loc(itype(i-2))
3142         else
3143           iti=nloctyp
3144         endif
3145 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3146 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3147         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3148           iti1 = itype2loc(itype(i-1))
3149         else
3150           iti1=nloctyp
3151         endif
3152         b1(1,i-2)=b(3,iti)
3153         b1(2,i-2)=b(5,iti)
3154         b2(1,i-2)=b(2,iti)
3155         b2(2,i-2)=b(4,iti)
3156         do k=1,2
3157           do l=1,2
3158            CC(k,l,i-2)=ccold(k,l,iti)
3159            DD(k,l,i-2)=ddold(k,l,iti)
3160            EE(k,l,i-2)=eeold(k,l,iti)
3161            gtEE(k,l,i-2)=0.0d0
3162           enddo
3163         enddo
3164 #endif
3165         b1tilde(1,i-2)= b1(1,i-2)
3166         b1tilde(2,i-2)=-b1(2,i-2)
3167         b2tilde(1,i-2)= b2(1,i-2)
3168         b2tilde(2,i-2)=-b2(2,i-2)
3169 c
3170         Ctilde(1,1,i-2)= CC(1,1,i-2)
3171         Ctilde(1,2,i-2)= CC(1,2,i-2)
3172         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3173         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3174 c
3175         Dtilde(1,1,i-2)= DD(1,1,i-2)
3176         Dtilde(1,2,i-2)= DD(1,2,i-2)
3177         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3178         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3179 #ifdef DEBUG
3180         write(iout,*) "i",i," iti",iti
3181         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3182         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3183 #endif
3184       enddo
3185       mu=0.0d0
3186 #ifdef PARMAT
3187       do i=ivec_start+2,ivec_end+2
3188 #else
3189       do i=3,nres+1
3190 #endif
3191 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3192         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3193           sin1=dsin(phi(i))
3194           cos1=dcos(phi(i))
3195           sintab(i-2)=sin1
3196           costab(i-2)=cos1
3197           obrot(1,i-2)=cos1
3198           obrot(2,i-2)=sin1
3199           sin2=dsin(2*phi(i))
3200           cos2=dcos(2*phi(i))
3201           sintab2(i-2)=sin2
3202           costab2(i-2)=cos2
3203           obrot2(1,i-2)=cos2
3204           obrot2(2,i-2)=sin2
3205           Ug(1,1,i-2)=-cos1
3206           Ug(1,2,i-2)=-sin1
3207           Ug(2,1,i-2)=-sin1
3208           Ug(2,2,i-2)= cos1
3209           Ug2(1,1,i-2)=-cos2
3210           Ug2(1,2,i-2)=-sin2
3211           Ug2(2,1,i-2)=-sin2
3212           Ug2(2,2,i-2)= cos2
3213         else
3214           costab(i-2)=1.0d0
3215           sintab(i-2)=0.0d0
3216           obrot(1,i-2)=1.0d0
3217           obrot(2,i-2)=0.0d0
3218           obrot2(1,i-2)=0.0d0
3219           obrot2(2,i-2)=0.0d0
3220           Ug(1,1,i-2)=1.0d0
3221           Ug(1,2,i-2)=0.0d0
3222           Ug(2,1,i-2)=0.0d0
3223           Ug(2,2,i-2)=1.0d0
3224           Ug2(1,1,i-2)=0.0d0
3225           Ug2(1,2,i-2)=0.0d0
3226           Ug2(2,1,i-2)=0.0d0
3227           Ug2(2,2,i-2)=0.0d0
3228         endif
3229         if (i .gt. 3) then
3230           obrot_der(1,i-2)=-sin1
3231           obrot_der(2,i-2)= cos1
3232           Ugder(1,1,i-2)= sin1
3233           Ugder(1,2,i-2)=-cos1
3234           Ugder(2,1,i-2)=-cos1
3235           Ugder(2,2,i-2)=-sin1
3236           dwacos2=cos2+cos2
3237           dwasin2=sin2+sin2
3238           obrot2_der(1,i-2)=-dwasin2
3239           obrot2_der(2,i-2)= dwacos2
3240           Ug2der(1,1,i-2)= dwasin2
3241           Ug2der(1,2,i-2)=-dwacos2
3242           Ug2der(2,1,i-2)=-dwacos2
3243           Ug2der(2,2,i-2)=-dwasin2
3244         else
3245           obrot_der(1,i-2)=0.0d0
3246           obrot_der(2,i-2)=0.0d0
3247           Ugder(1,1,i-2)=0.0d0
3248           Ugder(1,2,i-2)=0.0d0
3249           Ugder(2,1,i-2)=0.0d0
3250           Ugder(2,2,i-2)=0.0d0
3251           obrot2_der(1,i-2)=0.0d0
3252           obrot2_der(2,i-2)=0.0d0
3253           Ug2der(1,1,i-2)=0.0d0
3254           Ug2der(1,2,i-2)=0.0d0
3255           Ug2der(2,1,i-2)=0.0d0
3256           Ug2der(2,2,i-2)=0.0d0
3257         endif
3258 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3259 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3260         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3261           iti = itype2loc(itype(i-2))
3262         else
3263           iti=nloctyp
3264         endif
3265 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3266         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3267           iti1 = itype2loc(itype(i-1))
3268         else
3269           iti1=nloctyp
3270         endif
3271 cd        write (iout,*) '*******i',i,' iti1',iti
3272 cd        write (iout,*) 'b1',b1(:,iti)
3273 cd        write (iout,*) 'b2',b2(:,iti)
3274 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3275 c        if (i .gt. iatel_s+2) then
3276         if (i .gt. nnt+2) then
3277           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3278 #ifdef NEWCORR
3279           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3280 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3281 #endif
3282 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3283 c     &    EE(1,2,iti),EE(2,2,i)
3284           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3285           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3286 c          write(iout,*) "Macierz EUG",
3287 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3288 c     &    eug(2,2,i-2)
3289 #ifdef FOURBODY
3290           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3291      &    then
3292           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3293           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3294           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3295           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3296           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3297           endif
3298 #endif
3299         else
3300           do k=1,2
3301             Ub2(k,i-2)=0.0d0
3302             Ctobr(k,i-2)=0.0d0
3303             Dtobr2(k,i-2)=0.0d0
3304             do l=1,2
3305               EUg(l,k,i-2)=0.0d0
3306               CUg(l,k,i-2)=0.0d0
3307               DUg(l,k,i-2)=0.0d0
3308               DtUg2(l,k,i-2)=0.0d0
3309             enddo
3310           enddo
3311         endif
3312         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3313         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3314         do k=1,2
3315           muder(k,i-2)=Ub2der(k,i-2)
3316         enddo
3317 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3318         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3319           if (itype(i-1).le.ntyp) then
3320             iti1 = itype2loc(itype(i-1))
3321           else
3322             iti1=nloctyp
3323           endif
3324         else
3325           iti1=nloctyp
3326         endif
3327         do k=1,2
3328           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3329 c          mu(k,i-2)=b1(k,i-1)
3330 c          mu(k,i-2)=Ub2(k,i-2)
3331         enddo
3332 #ifdef MUOUT
3333         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3334      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3335      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3336      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3337      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3338      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3339 #endif
3340 cd        write (iout,*) 'mu1',mu1(:,i-2)
3341 cd        write (iout,*) 'mu2',mu2(:,i-2)
3342 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3343 #ifdef FOURBODY
3344         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3345      &  then
3346         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3347         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3348         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3349         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3350         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3351 C Vectors and matrices dependent on a single virtual-bond dihedral.
3352         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3353         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3354         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3355         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3356         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3357         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3358         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3359         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3360         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3361         endif
3362 #endif
3363       enddo
3364 #ifdef FOURBODY
3365 C Matrices dependent on two consecutive virtual-bond dihedrals.
3366 C The order of matrices is from left to right.
3367       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3368      &then
3369 c      do i=max0(ivec_start,2),ivec_end
3370       do i=2,nres-1
3371         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3372         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3373         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3374         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3375         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3376         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3377         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3378         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3379       enddo
3380       endif
3381 #endif
3382 #if defined(MPI) && defined(PARMAT)
3383 #ifdef DEBUG
3384 c      if (fg_rank.eq.0) then
3385         write (iout,*) "Arrays UG and UGDER before GATHER"
3386         do i=1,nres-1
3387           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3388      &     ((ug(l,k,i),l=1,2),k=1,2),
3389      &     ((ugder(l,k,i),l=1,2),k=1,2)
3390         enddo
3391         write (iout,*) "Arrays UG2 and UG2DER"
3392         do i=1,nres-1
3393           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3394      &     ((ug2(l,k,i),l=1,2),k=1,2),
3395      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3396         enddo
3397         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3398         do i=1,nres-1
3399           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3400      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3401      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3402         enddo
3403         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3404         do i=1,nres-1
3405           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3406      &     costab(i),sintab(i),costab2(i),sintab2(i)
3407         enddo
3408         write (iout,*) "Array MUDER"
3409         do i=1,nres-1
3410           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3411         enddo
3412 c      endif
3413 #endif
3414       if (nfgtasks.gt.1) then
3415         time00=MPI_Wtime()
3416 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3417 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3418 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3419 #ifdef MATGATHER
3420         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3421      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3422      &   FG_COMM1,IERR)
3423         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3424      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3425      &   FG_COMM1,IERR)
3426         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3427      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3428      &   FG_COMM1,IERR)
3429         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3430      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3431      &   FG_COMM1,IERR)
3432         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3433      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3434      &   FG_COMM1,IERR)
3435         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3436      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3437      &   FG_COMM1,IERR)
3438         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3439      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3440      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3441         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3442      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3443      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3444         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3445      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3446      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3447         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3448      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3449      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3450 #ifdef FOURBODY
3451         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3452      &  then
3453         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3454      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3455      &   FG_COMM1,IERR)
3456         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3457      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3458      &   FG_COMM1,IERR)
3459         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3460      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3461      &   FG_COMM1,IERR)
3462        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3463      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3464      &   FG_COMM1,IERR)
3465         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3466      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3467      &   FG_COMM1,IERR)
3468         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3469      &   ivec_count(fg_rank1),
3470      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3471      &   FG_COMM1,IERR)
3472         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3473      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3474      &   FG_COMM1,IERR)
3475         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3476      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3477      &   FG_COMM1,IERR)
3478         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3479      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3480      &   FG_COMM1,IERR)
3481         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3482      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3483      &   FG_COMM1,IERR)
3484         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3485      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3486      &   FG_COMM1,IERR)
3487         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3488      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3489      &   FG_COMM1,IERR)
3490         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3491      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3492      &   FG_COMM1,IERR)
3493         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3494      &   ivec_count(fg_rank1),
3495      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3496      &   FG_COMM1,IERR)
3497         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3498      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3499      &   FG_COMM1,IERR)
3500        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3501      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3502      &   FG_COMM1,IERR)
3503         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3504      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3505      &   FG_COMM1,IERR)
3506        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3507      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3508      &   FG_COMM1,IERR)
3509         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3510      &   ivec_count(fg_rank1),
3511      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3512      &   FG_COMM1,IERR)
3513         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3514      &   ivec_count(fg_rank1),
3515      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3516      &   FG_COMM1,IERR)
3517         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3518      &   ivec_count(fg_rank1),
3519      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3520      &   MPI_MAT2,FG_COMM1,IERR)
3521         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3522      &   ivec_count(fg_rank1),
3523      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3524      &   MPI_MAT2,FG_COMM1,IERR)
3525         endif
3526 #endif
3527 #else
3528 c Passes matrix info through the ring
3529       isend=fg_rank1
3530       irecv=fg_rank1-1
3531       if (irecv.lt.0) irecv=nfgtasks1-1
3532       iprev=irecv
3533       inext=fg_rank1+1
3534       if (inext.ge.nfgtasks1) inext=0
3535       do i=1,nfgtasks1-1
3536 c        write (iout,*) "isend",isend," irecv",irecv
3537 c        call flush(iout)
3538         lensend=lentyp(isend)
3539         lenrecv=lentyp(irecv)
3540 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3541 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3542 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3543 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3544 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3545 c        write (iout,*) "Gather ROTAT1"
3546 c        call flush(iout)
3547 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3548 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3549 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3550 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3551 c        write (iout,*) "Gather ROTAT2"
3552 c        call flush(iout)
3553         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3554      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3555      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3556      &   iprev,4400+irecv,FG_COMM,status,IERR)
3557 c        write (iout,*) "Gather ROTAT_OLD"
3558 c        call flush(iout)
3559         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3560      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3561      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3562      &   iprev,5500+irecv,FG_COMM,status,IERR)
3563 c        write (iout,*) "Gather PRECOMP11"
3564 c        call flush(iout)
3565         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3566      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3567      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3568      &   iprev,6600+irecv,FG_COMM,status,IERR)
3569 c        write (iout,*) "Gather PRECOMP12"
3570 c        call flush(iout)
3571 #ifdef FOURBODY
3572         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3573      &  then
3574         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3575      &   MPI_ROTAT2(lensend),inext,7700+isend,
3576      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3577      &   iprev,7700+irecv,FG_COMM,status,IERR)
3578 c        write (iout,*) "Gather PRECOMP21"
3579 c        call flush(iout)
3580         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3581      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3582      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3583      &   iprev,8800+irecv,FG_COMM,status,IERR)
3584 c        write (iout,*) "Gather PRECOMP22"
3585 c        call flush(iout)
3586         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3587      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3588      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3589      &   MPI_PRECOMP23(lenrecv),
3590      &   iprev,9900+irecv,FG_COMM,status,IERR)
3591 #endif
3592 c        write (iout,*) "Gather PRECOMP23"
3593 c        call flush(iout)
3594         endif
3595         isend=irecv
3596         irecv=irecv-1
3597         if (irecv.lt.0) irecv=nfgtasks1-1
3598       enddo
3599 #endif
3600         time_gather=time_gather+MPI_Wtime()-time00
3601       endif
3602 #ifdef DEBUG
3603 c      if (fg_rank.eq.0) then
3604         write (iout,*) "Arrays UG and UGDER"
3605         do i=1,nres-1
3606           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3607      &     ((ug(l,k,i),l=1,2),k=1,2),
3608      &     ((ugder(l,k,i),l=1,2),k=1,2)
3609         enddo
3610         write (iout,*) "Arrays UG2 and UG2DER"
3611         do i=1,nres-1
3612           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3613      &     ((ug2(l,k,i),l=1,2),k=1,2),
3614      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3615         enddo
3616         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3617         do i=1,nres-1
3618           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3619      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3620      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3621         enddo
3622         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3623         do i=1,nres-1
3624           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3625      &     costab(i),sintab(i),costab2(i),sintab2(i)
3626         enddo
3627         write (iout,*) "Array MUDER"
3628         do i=1,nres-1
3629           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3630         enddo
3631 c      endif
3632 #endif
3633 #endif
3634 cd      do i=1,nres
3635 cd        iti = itype2loc(itype(i))
3636 cd        write (iout,*) i
3637 cd        do j=1,2
3638 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3639 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3640 cd        enddo
3641 cd      enddo
3642       return
3643       end
3644 C-----------------------------------------------------------------------------
3645       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3646 C
3647 C This subroutine calculates the average interaction energy and its gradient
3648 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3649 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3650 C The potential depends both on the distance of peptide-group centers and on
3651 C the orientation of the CA-CA virtual bonds.
3652 C
3653       implicit real*8 (a-h,o-z)
3654 #ifdef MPI
3655       include 'mpif.h'
3656 #endif
3657       include 'DIMENSIONS'
3658       include 'COMMON.CONTROL'
3659       include 'COMMON.SETUP'
3660       include 'COMMON.IOUNITS'
3661       include 'COMMON.GEO'
3662       include 'COMMON.VAR'
3663       include 'COMMON.LOCAL'
3664       include 'COMMON.CHAIN'
3665       include 'COMMON.DERIV'
3666       include 'COMMON.INTERACT'
3667 #ifdef FOURBODY
3668       include 'COMMON.CONTACTS'
3669       include 'COMMON.CONTMAT'
3670 #endif
3671       include 'COMMON.CORRMAT'
3672       include 'COMMON.TORSION'
3673       include 'COMMON.VECTORS'
3674       include 'COMMON.FFIELD'
3675       include 'COMMON.TIME1'
3676       include 'COMMON.SPLITELE'
3677       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3678      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3679       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3680      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3681       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3682      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3683      &    num_conti,j1,j2
3684 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3685 #ifdef MOMENT
3686       double precision scal_el /1.0d0/
3687 #else
3688       double precision scal_el /0.5d0/
3689 #endif
3690 C 12/13/98
3691 C 13-go grudnia roku pamietnego...
3692       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3693      &                   0.0d0,1.0d0,0.0d0,
3694      &                   0.0d0,0.0d0,1.0d0/
3695 cd      write(iout,*) 'In EELEC'
3696 cd      do i=1,nloctyp
3697 cd        write(iout,*) 'Type',i
3698 cd        write(iout,*) 'B1',B1(:,i)
3699 cd        write(iout,*) 'B2',B2(:,i)
3700 cd        write(iout,*) 'CC',CC(:,:,i)
3701 cd        write(iout,*) 'DD',DD(:,:,i)
3702 cd        write(iout,*) 'EE',EE(:,:,i)
3703 cd      enddo
3704 cd      call check_vecgrad
3705 cd      stop
3706       if (icheckgrad.eq.1) then
3707         do i=1,nres-1
3708           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3709           do k=1,3
3710             dc_norm(k,i)=dc(k,i)*fac
3711           enddo
3712 c          write (iout,*) 'i',i,' fac',fac
3713         enddo
3714       endif
3715       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3716      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3717      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3718 c        call vec_and_deriv
3719 #ifdef TIMING
3720         time01=MPI_Wtime()
3721 #endif
3722         call set_matrices
3723 #ifdef TIMING
3724         time_mat=time_mat+MPI_Wtime()-time01
3725 #endif
3726       endif
3727 cd      do i=1,nres-1
3728 cd        write (iout,*) 'i=',i
3729 cd        do k=1,3
3730 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3731 cd        enddo
3732 cd        do k=1,3
3733 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3734 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3735 cd        enddo
3736 cd      enddo
3737       t_eelecij=0.0d0
3738       ees=0.0D0
3739       evdw1=0.0D0
3740       eel_loc=0.0d0
3741       eello_turn3=0.0d0
3742       eello_turn4=0.0d0
3743       ind=0
3744 #ifdef FOURBODY
3745       do i=1,nres
3746         num_cont_hb(i)=0
3747       enddo
3748 #endif
3749 cd      print '(a)','Enter EELEC'
3750 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3751       do i=1,nres
3752         gel_loc_loc(i)=0.0d0
3753         gcorr_loc(i)=0.0d0
3754       enddo
3755 c
3756 c
3757 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3758 C
3759 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3760 C
3761 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3762       do i=iturn3_start,iturn3_end
3763 c        if (i.le.1) cycle
3764 C        write(iout,*) "tu jest i",i
3765         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3766 C changes suggested by Ana to avoid out of bounds
3767 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3768 c     & .or.((i+4).gt.nres)
3769 c     & .or.((i-1).le.0)
3770 C end of changes by Ana
3771      &  .or. itype(i+2).eq.ntyp1
3772      &  .or. itype(i+3).eq.ntyp1) cycle
3773 C Adam: Instructions below will switch off existing interactions
3774 c        if(i.gt.1)then
3775 c          if(itype(i-1).eq.ntyp1)cycle
3776 c        end if
3777 c        if(i.LT.nres-3)then
3778 c          if (itype(i+4).eq.ntyp1) cycle
3779 c        end if
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           xmedi=mod(xmedi,boxxsize)
3790           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3791           ymedi=mod(ymedi,boxysize)
3792           if (ymedi.lt.0) ymedi=ymedi+boxysize
3793           zmedi=mod(zmedi,boxzsize)
3794           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3795         num_conti=0
3796         call eelecij(i,i+2,ees,evdw1,eel_loc)
3797         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3798 #ifdef FOURBODY
3799         num_cont_hb(i)=num_conti
3800 #endif
3801       enddo
3802       do i=iturn4_start,iturn4_end
3803         if (i.lt.1) cycle
3804         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3805 C changes suggested by Ana to avoid out of bounds
3806 c     & .or.((i+5).gt.nres)
3807 c     & .or.((i-1).le.0)
3808 C end of changes suggested by Ana
3809      &    .or. itype(i+3).eq.ntyp1
3810      &    .or. itype(i+4).eq.ntyp1
3811 c     &    .or. itype(i+5).eq.ntyp1
3812 c     &    .or. itype(i).eq.ntyp1
3813 c     &    .or. itype(i-1).eq.ntyp1
3814      &                             ) cycle
3815         dxi=dc(1,i)
3816         dyi=dc(2,i)
3817         dzi=dc(3,i)
3818         dx_normi=dc_norm(1,i)
3819         dy_normi=dc_norm(2,i)
3820         dz_normi=dc_norm(3,i)
3821         xmedi=c(1,i)+0.5d0*dxi
3822         ymedi=c(2,i)+0.5d0*dyi
3823         zmedi=c(3,i)+0.5d0*dzi
3824 C Return atom into box, boxxsize is size of box in x dimension
3825 c  194   continue
3826 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3827 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3828 C Condition for being inside the proper box
3829 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3830 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3831 c        go to 194
3832 c        endif
3833 c  195   continue
3834 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3835 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3836 C Condition for being inside the proper box
3837 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3838 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3839 c        go to 195
3840 c        endif
3841 c  196   continue
3842 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3843 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3844 C Condition for being inside the proper box
3845 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3846 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3847 c        go to 196
3848 c        endif
3849           xmedi=mod(xmedi,boxxsize)
3850           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3851           ymedi=mod(ymedi,boxysize)
3852           if (ymedi.lt.0) ymedi=ymedi+boxysize
3853           zmedi=mod(zmedi,boxzsize)
3854           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3855
3856 #ifdef FOURBODY
3857         num_conti=num_cont_hb(i)
3858 #endif
3859 c        write(iout,*) "JESTEM W PETLI"
3860         call eelecij(i,i+3,ees,evdw1,eel_loc)
3861         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3862      &   call eturn4(i,eello_turn4)
3863 #ifdef FOURBODY
3864         num_cont_hb(i)=num_conti
3865 #endif
3866       enddo   ! i
3867 C Loop over all neighbouring boxes
3868 C      do xshift=-1,1
3869 C      do yshift=-1,1
3870 C      do zshift=-1,1
3871 c
3872 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3873 c
3874 CTU KURWA
3875 c      do i=iatel_s,iatel_e
3876       do ikont=g_listpp_start,g_listpp_end
3877         i=newcontlistppi(ikont)
3878         j=newcontlistppj(ikont)
3879 C        do i=75,75
3880 c        if (i.le.1) cycle
3881         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3882 C changes suggested by Ana to avoid out of bounds
3883 c     & .or.((i+2).gt.nres)
3884 c     & .or.((i-1).le.0)
3885 C end of changes by Ana
3886 c     &  .or. itype(i+2).eq.ntyp1
3887 c     &  .or. itype(i-1).eq.ntyp1
3888      &                ) cycle
3889         dxi=dc(1,i)
3890         dyi=dc(2,i)
3891         dzi=dc(3,i)
3892         dx_normi=dc_norm(1,i)
3893         dy_normi=dc_norm(2,i)
3894         dz_normi=dc_norm(3,i)
3895         xmedi=c(1,i)+0.5d0*dxi
3896         ymedi=c(2,i)+0.5d0*dyi
3897         zmedi=c(3,i)+0.5d0*dzi
3898           xmedi=mod(xmedi,boxxsize)
3899           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3900           ymedi=mod(ymedi,boxysize)
3901           if (ymedi.lt.0) ymedi=ymedi+boxysize
3902           zmedi=mod(zmedi,boxzsize)
3903           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3904 C          xmedi=xmedi+xshift*boxxsize
3905 C          ymedi=ymedi+yshift*boxysize
3906 C          zmedi=zmedi+zshift*boxzsize
3907
3908 C Return tom into box, boxxsize is size of box in x dimension
3909 c  164   continue
3910 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3911 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3912 C Condition for being inside the proper box
3913 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3914 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3915 c        go to 164
3916 c        endif
3917 c  165   continue
3918 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3919 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3920 C Condition for being inside the proper box
3921 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3922 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3923 c        go to 165
3924 c        endif
3925 c  166   continue
3926 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3927 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3928 cC Condition for being inside the proper box
3929 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3930 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3931 c        go to 166
3932 c        endif
3933
3934 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3935 #ifdef FOURBODY
3936         num_conti=num_cont_hb(i)
3937 #endif
3938 C I TU KURWA
3939 c        do j=ielstart(i),ielend(i)
3940 C          do j=16,17
3941 C          write (iout,*) i,j
3942 C         if (j.le.1) cycle
3943           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3944 C changes suggested by Ana to avoid out of bounds
3945 c     & .or.((j+2).gt.nres)
3946 c     & .or.((j-1).le.0)
3947 C end of changes by Ana
3948 c     & .or.itype(j+2).eq.ntyp1
3949 c     & .or.itype(j-1).eq.ntyp1
3950      &) cycle
3951           call eelecij(i,j,ees,evdw1,eel_loc)
3952 c        enddo ! j
3953 #ifdef FOURBODY
3954         num_cont_hb(i)=num_conti
3955 #endif
3956       enddo   ! i
3957 C     enddo   ! zshift
3958 C      enddo   ! yshift
3959 C      enddo   ! xshift
3960
3961 c      write (iout,*) "Number of loop steps in EELEC:",ind
3962 cd      do i=1,nres
3963 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3964 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3965 cd      enddo
3966 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3967 ccc      eel_loc=eel_loc+eello_turn3
3968 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3969       return
3970       end
3971 C-------------------------------------------------------------------------------
3972       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3973       implicit none
3974       include 'DIMENSIONS'
3975 #ifdef MPI
3976       include "mpif.h"
3977 #endif
3978       include 'COMMON.CONTROL'
3979       include 'COMMON.IOUNITS'
3980       include 'COMMON.GEO'
3981       include 'COMMON.VAR'
3982       include 'COMMON.LOCAL'
3983       include 'COMMON.CHAIN'
3984       include 'COMMON.DERIV'
3985       include 'COMMON.INTERACT'
3986 #ifdef FOURBODY
3987       include 'COMMON.CONTACTS'
3988       include 'COMMON.CONTMAT'
3989 #endif
3990       include 'COMMON.CORRMAT'
3991       include 'COMMON.TORSION'
3992       include 'COMMON.VECTORS'
3993       include 'COMMON.FFIELD'
3994       include 'COMMON.TIME1'
3995       include 'COMMON.SPLITELE'
3996       include 'COMMON.SHIELD'
3997       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3998      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3999       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
4000      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
4001      &    gmuij2(4),gmuji2(4)
4002       double precision dxi,dyi,dzi
4003       double precision dx_normi,dy_normi,dz_normi,aux
4004       integer j1,j2,lll,num_conti
4005       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4006      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4007      &    num_conti,j1,j2
4008       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
4009       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
4010       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
4011       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
4012      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
4013      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
4014      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
4015      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
4016      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
4017      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
4018      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
4019       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
4020       double precision dist_init,xj_safe,yj_safe,zj_safe,
4021      &  xj_temp,yj_temp,zj_temp,dist_temp,xmedi,ymedi,zmedi
4022       double precision sscale,sscagrad,scalar
4023
4024 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
4025 #ifdef MOMENT
4026       double precision scal_el /1.0d0/
4027 #else
4028       double precision scal_el /0.5d0/
4029 #endif
4030 C 12/13/98
4031 C 13-go grudnia roku pamietnego...
4032       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4033      &                   0.0d0,1.0d0,0.0d0,
4034      &                   0.0d0,0.0d0,1.0d0/
4035        integer xshift,yshift,zshift
4036 c          time00=MPI_Wtime()
4037 cd      write (iout,*) "eelecij",i,j
4038 c          ind=ind+1
4039           iteli=itel(i)
4040           itelj=itel(j)
4041           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4042           aaa=app(iteli,itelj)
4043           bbb=bpp(iteli,itelj)
4044           ael6i=ael6(iteli,itelj)
4045           ael3i=ael3(iteli,itelj)
4046           dxj=dc(1,j)
4047           dyj=dc(2,j)
4048           dzj=dc(3,j)
4049           dx_normj=dc_norm(1,j)
4050           dy_normj=dc_norm(2,j)
4051           dz_normj=dc_norm(3,j)
4052 C          xj=c(1,j)+0.5D0*dxj-xmedi
4053 C          yj=c(2,j)+0.5D0*dyj-ymedi
4054 C          zj=c(3,j)+0.5D0*dzj-zmedi
4055           xj=c(1,j)+0.5D0*dxj
4056           yj=c(2,j)+0.5D0*dyj
4057           zj=c(3,j)+0.5D0*dzj
4058           xj=mod(xj,boxxsize)
4059           if (xj.lt.0) xj=xj+boxxsize
4060           yj=mod(yj,boxysize)
4061           if (yj.lt.0) yj=yj+boxysize
4062           zj=mod(zj,boxzsize)
4063           if (zj.lt.0) zj=zj+boxzsize
4064           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4065       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4066       xj_safe=xj
4067       yj_safe=yj
4068       zj_safe=zj
4069       isubchap=0
4070       do xshift=-1,1
4071       do yshift=-1,1
4072       do zshift=-1,1
4073           xj=xj_safe+xshift*boxxsize
4074           yj=yj_safe+yshift*boxysize
4075           zj=zj_safe+zshift*boxzsize
4076           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4077           if(dist_temp.lt.dist_init) then
4078             dist_init=dist_temp
4079             xj_temp=xj
4080             yj_temp=yj
4081             zj_temp=zj
4082             isubchap=1
4083           endif
4084        enddo
4085        enddo
4086        enddo
4087        if (isubchap.eq.1) then
4088           xj=xj_temp-xmedi
4089           yj=yj_temp-ymedi
4090           zj=zj_temp-zmedi
4091        else
4092           xj=xj_safe-xmedi
4093           yj=yj_safe-ymedi
4094           zj=zj_safe-zmedi
4095        endif
4096 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4097 c  174   continue
4098 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4099 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4100 C Condition for being inside the proper box
4101 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4102 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4103 c        go to 174
4104 c        endif
4105 c  175   continue
4106 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4107 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4108 C Condition for being inside the proper box
4109 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4110 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4111 c        go to 175
4112 c        endif
4113 c  176   continue
4114 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4115 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4116 C Condition for being inside the proper box
4117 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4118 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4119 c        go to 176
4120 c        endif
4121 C        endif !endPBC condintion
4122 C        xj=xj-xmedi
4123 C        yj=yj-ymedi
4124 C        zj=zj-zmedi
4125           rij=xj*xj+yj*yj+zj*zj
4126
4127           sss=sscale(dsqrt(rij),r_cut_int)
4128           if (sss.eq.0.0d0) return
4129           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
4130 c            if (sss.gt.0.0d0) then
4131           rrmij=1.0D0/rij
4132           rij=dsqrt(rij)
4133           rmij=1.0D0/rij
4134           r3ij=rrmij*rmij
4135           r6ij=r3ij*r3ij
4136           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4137           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4138           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4139           fac=cosa-3.0D0*cosb*cosg
4140           ev1=aaa*r6ij*r6ij
4141 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4142           if (j.eq.i+2) ev1=scal_el*ev1
4143           ev2=bbb*r6ij
4144           fac3=ael6i*r6ij
4145           fac4=ael3i*r3ij
4146           evdwij=(ev1+ev2)
4147           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4148           el2=fac4*fac
4149 C MARYSIA
4150 C          eesij=(el1+el2)
4151 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4152           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4153           if (shield_mode.gt.0) then
4154 C          fac_shield(i)=0.4
4155 C          fac_shield(j)=0.6
4156           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4157           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4158           eesij=(el1+el2)
4159           ees=ees+eesij
4160           else
4161           fac_shield(i)=1.0
4162           fac_shield(j)=1.0
4163           eesij=(el1+el2)
4164           ees=ees+eesij*sss
4165           endif
4166           evdw1=evdw1+evdwij*sss
4167 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4168 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4169 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4170 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4171
4172           if (energy_dec) then
4173             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4174      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4175             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4176      &        fac_shield(i),fac_shield(j)
4177           endif
4178
4179 C
4180 C Calculate contributions to the Cartesian gradient.
4181 C
4182 #ifdef SPLITELE
4183           facvdw=-6*rrmij*(ev1+evdwij)*sss
4184           facel=-3*rrmij*(el1+eesij)
4185           fac1=fac
4186           erij(1)=xj*rmij
4187           erij(2)=yj*rmij
4188           erij(3)=zj*rmij
4189
4190 *
4191 * Radial derivatives. First process both termini of the fragment (i,j)
4192 *
4193           aux=facel*sss+rmij*sssgrad*eesij
4194           ggg(1)=aux*xj
4195           ggg(2)=aux*yj
4196           ggg(3)=aux*zj
4197           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4198      &  (shield_mode.gt.0)) then
4199 C          print *,i,j
4200           do ilist=1,ishield_list(i)
4201            iresshield=shield_list(ilist,i)
4202            do k=1,3
4203            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4204      &      *2.0
4205            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4206      &              rlocshield
4207      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4208             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4209 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4210 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4211 C             if (iresshield.gt.i) then
4212 C               do ishi=i+1,iresshield-1
4213 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4214 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4215 C
4216 C              enddo
4217 C             else
4218 C               do ishi=iresshield,i
4219 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4220 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4221 C
4222 C               enddo
4223 C              endif
4224            enddo
4225           enddo
4226           do ilist=1,ishield_list(j)
4227            iresshield=shield_list(ilist,j)
4228            do k=1,3
4229            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4230      &     *2.0*sss
4231            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4232      &              rlocshield
4233      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4234            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4235
4236 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4237 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4238 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4239 C             if (iresshield.gt.j) then
4240 C               do ishi=j+1,iresshield-1
4241 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4242 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4243 C
4244 C               enddo
4245 C            else
4246 C               do ishi=iresshield,j
4247 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4248 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4249 C               enddo
4250 C              endif
4251            enddo
4252           enddo
4253
4254           do k=1,3
4255             gshieldc(k,i)=gshieldc(k,i)+
4256      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4257             gshieldc(k,j)=gshieldc(k,j)+
4258      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4259             gshieldc(k,i-1)=gshieldc(k,i-1)+
4260      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4261             gshieldc(k,j-1)=gshieldc(k,j-1)+
4262      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4263
4264            enddo
4265            endif
4266 c          do k=1,3
4267 c            ghalf=0.5D0*ggg(k)
4268 c            gelc(k,i)=gelc(k,i)+ghalf
4269 c            gelc(k,j)=gelc(k,j)+ghalf
4270 c          enddo
4271 c 9/28/08 AL Gradient compotents will be summed only at the end
4272 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4273           do k=1,3
4274             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4275 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4276             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4277 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4278 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4279 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4280 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4281 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4282           enddo
4283 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4284
4285 *
4286 * Loop over residues i+1 thru j-1.
4287 *
4288 cgrad          do k=i+1,j-1
4289 cgrad            do l=1,3
4290 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4291 cgrad            enddo
4292 cgrad          enddo
4293           facvdw=facvdw+sssgrad*rmij*evdwij
4294           ggg(1)=facvdw*xj
4295           ggg(2)=facvdw*yj
4296           ggg(3)=facvdw*zj
4297 c          do k=1,3
4298 c            ghalf=0.5D0*ggg(k)
4299 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4300 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4301 c          enddo
4302 c 9/28/08 AL Gradient compotents will be summed only at the end
4303           do k=1,3
4304             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4305             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4306           enddo
4307 *
4308 * Loop over residues i+1 thru j-1.
4309 *
4310 cgrad          do k=i+1,j-1
4311 cgrad            do l=1,3
4312 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4313 cgrad            enddo
4314 cgrad          enddo
4315 #else
4316 C MARYSIA
4317           facvdw=(ev1+evdwij)
4318           facel=(el1+eesij)
4319           fac1=fac
4320           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4321      &       +(evdwij+eesij)*sssgrad*rrmij
4322           erij(1)=xj*rmij
4323           erij(2)=yj*rmij
4324           erij(3)=zj*rmij
4325 *
4326 * Radial derivatives. First process both termini of the fragment (i,j)
4327 *
4328           ggg(1)=fac*xj
4329 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4330           ggg(2)=fac*yj
4331 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4332           ggg(3)=fac*zj
4333 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4334 c          do k=1,3
4335 c            ghalf=0.5D0*ggg(k)
4336 c            gelc(k,i)=gelc(k,i)+ghalf
4337 c            gelc(k,j)=gelc(k,j)+ghalf
4338 c          enddo
4339 c 9/28/08 AL Gradient compotents will be summed only at the end
4340           do k=1,3
4341             gelc_long(k,j)=gelc(k,j)+ggg(k)
4342             gelc_long(k,i)=gelc(k,i)-ggg(k)
4343           enddo
4344 *
4345 * Loop over residues i+1 thru j-1.
4346 *
4347 cgrad          do k=i+1,j-1
4348 cgrad            do l=1,3
4349 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4350 cgrad            enddo
4351 cgrad          enddo
4352 c 9/28/08 AL Gradient compotents will be summed only at the end
4353           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4354           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4355           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4356           do k=1,3
4357             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4358             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4359           enddo
4360 #endif
4361 *
4362 * Angular part
4363 *
4364           ecosa=2.0D0*fac3*fac1+fac4
4365           fac4=-3.0D0*fac4
4366           fac3=-6.0D0*fac3
4367           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4368           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4369           do k=1,3
4370             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4371             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4372           enddo
4373 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4374 cd   &          (dcosg(k),k=1,3)
4375           do k=1,3
4376             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4377      &      fac_shield(i)**2*fac_shield(j)**2*sss
4378           enddo
4379 c          do k=1,3
4380 c            ghalf=0.5D0*ggg(k)
4381 c            gelc(k,i)=gelc(k,i)+ghalf
4382 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4383 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4384 c            gelc(k,j)=gelc(k,j)+ghalf
4385 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4386 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4387 c          enddo
4388 cgrad          do k=i+1,j-1
4389 cgrad            do l=1,3
4390 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4391 cgrad            enddo
4392 cgrad          enddo
4393 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4394           do k=1,3
4395             gelc(k,i)=gelc(k,i)
4396      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4397      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4398      &           *fac_shield(i)**2*fac_shield(j)**2
4399             gelc(k,j)=gelc(k,j)
4400      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4401      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4402      &           *fac_shield(i)**2*fac_shield(j)**2
4403             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4404             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4405           enddo
4406 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4407
4408 C MARYSIA
4409 c          endif !sscale
4410           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4411      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4412      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4413 C
4414 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4415 C   energy of a peptide unit is assumed in the form of a second-order
4416 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4417 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4418 C   are computed for EVERY pair of non-contiguous peptide groups.
4419 C
4420
4421           if (j.lt.nres-1) then
4422             j1=j+1
4423             j2=j-1
4424           else
4425             j1=j-1
4426             j2=j-2
4427           endif
4428           kkk=0
4429           lll=0
4430           do k=1,2
4431             do l=1,2
4432               kkk=kkk+1
4433               muij(kkk)=mu(k,i)*mu(l,j)
4434 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4435 #ifdef NEWCORR
4436              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4437 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4438              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4439              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4440 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4441              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4442 #endif
4443             enddo
4444           enddo
4445 #ifdef DEBUG
4446           write (iout,*) 'EELEC: i',i,' j',j
4447           write (iout,*) 'j',j,' j1',j1,' j2',j2
4448           write(iout,*) 'muij',muij
4449 #endif
4450           ury=scalar(uy(1,i),erij)
4451           urz=scalar(uz(1,i),erij)
4452           vry=scalar(uy(1,j),erij)
4453           vrz=scalar(uz(1,j),erij)
4454           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4455           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4456           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4457           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4458           fac=dsqrt(-ael6i)*r3ij
4459 #ifdef DEBUG
4460           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4461           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4462      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4463      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4464      &      "uzvz",scalar(uz(1,i),uz(1,j))
4465           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4466           write (iout,*) "fac",fac
4467 #endif
4468           a22=a22*fac
4469           a23=a23*fac
4470           a32=a32*fac
4471           a33=a33*fac
4472 #ifdef DEBUG
4473           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4474 #endif
4475 #undef DEBUG
4476 cd          write (iout,'(4i5,4f10.5)')
4477 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4478 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4479 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4480 cd     &      uy(:,j),uz(:,j)
4481 cd          write (iout,'(4f10.5)')
4482 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4483 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4484 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4485 cd           write (iout,'(9f10.5/)')
4486 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4487 C Derivatives of the elements of A in virtual-bond vectors
4488           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4489           do k=1,3
4490             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4491             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4492             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4493             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4494             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4495             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4496             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4497             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4498             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4499             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4500             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4501             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4502           enddo
4503 C Compute radial contributions to the gradient
4504           facr=-3.0d0*rrmij
4505           a22der=a22*facr
4506           a23der=a23*facr
4507           a32der=a32*facr
4508           a33der=a33*facr
4509           agg(1,1)=a22der*xj
4510           agg(2,1)=a22der*yj
4511           agg(3,1)=a22der*zj
4512           agg(1,2)=a23der*xj
4513           agg(2,2)=a23der*yj
4514           agg(3,2)=a23der*zj
4515           agg(1,3)=a32der*xj
4516           agg(2,3)=a32der*yj
4517           agg(3,3)=a32der*zj
4518           agg(1,4)=a33der*xj
4519           agg(2,4)=a33der*yj
4520           agg(3,4)=a33der*zj
4521 C Add the contributions coming from er
4522           fac3=-3.0d0*fac
4523           do k=1,3
4524             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4525             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4526             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4527             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4528           enddo
4529           do k=1,3
4530 C Derivatives in DC(i)
4531 cgrad            ghalf1=0.5d0*agg(k,1)
4532 cgrad            ghalf2=0.5d0*agg(k,2)
4533 cgrad            ghalf3=0.5d0*agg(k,3)
4534 cgrad            ghalf4=0.5d0*agg(k,4)
4535             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4536      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4537             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4538      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4539             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4540      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4541             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4542      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4543 C Derivatives in DC(i+1)
4544             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4545      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4546             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4547      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4548             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4549      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4550             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4551      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4552 C Derivatives in DC(j)
4553             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4554      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4555             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4556      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4557             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4558      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4559             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4560      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4561 C Derivatives in DC(j+1) or DC(nres-1)
4562             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4563      &      -3.0d0*vryg(k,3)*ury)
4564             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4565      &      -3.0d0*vrzg(k,3)*ury)
4566             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4567      &      -3.0d0*vryg(k,3)*urz)
4568             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4569      &      -3.0d0*vrzg(k,3)*urz)
4570 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4571 cgrad              do l=1,4
4572 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4573 cgrad              enddo
4574 cgrad            endif
4575           enddo
4576           acipa(1,1)=a22
4577           acipa(1,2)=a23
4578           acipa(2,1)=a32
4579           acipa(2,2)=a33
4580           a22=-a22
4581           a23=-a23
4582           do l=1,2
4583             do k=1,3
4584               agg(k,l)=-agg(k,l)
4585               aggi(k,l)=-aggi(k,l)
4586               aggi1(k,l)=-aggi1(k,l)
4587               aggj(k,l)=-aggj(k,l)
4588               aggj1(k,l)=-aggj1(k,l)
4589             enddo
4590           enddo
4591           if (j.lt.nres-1) then
4592             a22=-a22
4593             a32=-a32
4594             do l=1,3,2
4595               do k=1,3
4596                 agg(k,l)=-agg(k,l)
4597                 aggi(k,l)=-aggi(k,l)
4598                 aggi1(k,l)=-aggi1(k,l)
4599                 aggj(k,l)=-aggj(k,l)
4600                 aggj1(k,l)=-aggj1(k,l)
4601               enddo
4602             enddo
4603           else
4604             a22=-a22
4605             a23=-a23
4606             a32=-a32
4607             a33=-a33
4608             do l=1,4
4609               do k=1,3
4610                 agg(k,l)=-agg(k,l)
4611                 aggi(k,l)=-aggi(k,l)
4612                 aggi1(k,l)=-aggi1(k,l)
4613                 aggj(k,l)=-aggj(k,l)
4614                 aggj1(k,l)=-aggj1(k,l)
4615               enddo
4616             enddo
4617           endif
4618           ENDIF ! WCORR
4619           IF (wel_loc.gt.0.0d0) THEN
4620 C Contribution to the local-electrostatic energy coming from the i-j pair
4621           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4622      &     +a33*muij(4)
4623 #ifdef DEBUG
4624           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4625      &     " a33",a33
4626           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4627      &     " wel_loc",wel_loc
4628 #endif
4629           if (shield_mode.eq.0) then
4630            fac_shield(i)=1.0
4631            fac_shield(j)=1.0
4632 C          else
4633 C           fac_shield(i)=0.4
4634 C           fac_shield(j)=0.6
4635           endif
4636           eel_loc_ij=eel_loc_ij
4637      &    *fac_shield(i)*fac_shield(j)*sss
4638 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4639 c     &            'eelloc',i,j,eel_loc_ij
4640 C Now derivative over eel_loc
4641           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4642      &  (shield_mode.gt.0)) then
4643 C          print *,i,j
4644
4645           do ilist=1,ishield_list(i)
4646            iresshield=shield_list(ilist,i)
4647            do k=1,3
4648            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4649      &                                          /fac_shield(i)
4650 C     &      *2.0
4651            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4652      &              rlocshield
4653      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4654             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4655      &      +rlocshield
4656            enddo
4657           enddo
4658           do ilist=1,ishield_list(j)
4659            iresshield=shield_list(ilist,j)
4660            do k=1,3
4661            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4662      &                                       /fac_shield(j)
4663 C     &     *2.0
4664            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4665      &              rlocshield
4666      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4667            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4668      &             +rlocshield
4669
4670            enddo
4671           enddo
4672
4673           do k=1,3
4674             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4675      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4676             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4677      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4678             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4679      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4680             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4681      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4682            enddo
4683            endif
4684
4685
4686 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4687 c     &                     ' eel_loc_ij',eel_loc_ij
4688 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4689 C Calculate patrial derivative for theta angle
4690 #ifdef NEWCORR
4691          geel_loc_ij=(a22*gmuij1(1)
4692      &     +a23*gmuij1(2)
4693      &     +a32*gmuij1(3)
4694      &     +a33*gmuij1(4))
4695      &    *fac_shield(i)*fac_shield(j)*sss
4696 c         write(iout,*) "derivative over thatai"
4697 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4698 c     &   a33*gmuij1(4)
4699          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4700      &      geel_loc_ij*wel_loc
4701 c         write(iout,*) "derivative over thatai-1"
4702 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4703 c     &   a33*gmuij2(4)
4704          geel_loc_ij=
4705      &     a22*gmuij2(1)
4706      &     +a23*gmuij2(2)
4707      &     +a32*gmuij2(3)
4708      &     +a33*gmuij2(4)
4709          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4710      &      geel_loc_ij*wel_loc
4711      &    *fac_shield(i)*fac_shield(j)*sss
4712
4713 c  Derivative over j residue
4714          geel_loc_ji=a22*gmuji1(1)
4715      &     +a23*gmuji1(2)
4716      &     +a32*gmuji1(3)
4717      &     +a33*gmuji1(4)
4718 c         write(iout,*) "derivative over thataj"
4719 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4720 c     &   a33*gmuji1(4)
4721
4722         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4723      &      geel_loc_ji*wel_loc
4724      &    *fac_shield(i)*fac_shield(j)*sss
4725
4726          geel_loc_ji=
4727      &     +a22*gmuji2(1)
4728      &     +a23*gmuji2(2)
4729      &     +a32*gmuji2(3)
4730      &     +a33*gmuji2(4)
4731 c         write(iout,*) "derivative over thataj-1"
4732 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4733 c     &   a33*gmuji2(4)
4734          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4735      &      geel_loc_ji*wel_loc
4736      &    *fac_shield(i)*fac_shield(j)*sss
4737 #endif
4738 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4739
4740           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4741      &            'eelloc',i,j,eel_loc_ij
4742 c           if (eel_loc_ij.ne.0)
4743 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4744 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4745
4746           eel_loc=eel_loc+eel_loc_ij
4747 C Partial derivatives in virtual-bond dihedral angles gamma
4748           if (i.gt.1)
4749      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4750      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4751      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4752      &    *fac_shield(i)*fac_shield(j)*sss
4753
4754           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4755      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4756      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4757      &    *fac_shield(i)*fac_shield(j)*sss
4758 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4759           aux=eel_loc_ij/sss*sssgrad*rmij
4760           ggg(1)=aux*xj
4761           ggg(2)=aux*yj
4762           ggg(3)=aux*zj
4763           do l=1,3
4764             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4765      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4766      &    *fac_shield(i)*fac_shield(j)*sss
4767             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4768             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4769 cgrad            ghalf=0.5d0*ggg(l)
4770 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4771 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4772           enddo
4773 cgrad          do k=i+1,j2
4774 cgrad            do l=1,3
4775 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4776 cgrad            enddo
4777 cgrad          enddo
4778 C Remaining derivatives of eello
4779           do l=1,3
4780             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4781      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4782      &    *fac_shield(i)*fac_shield(j)*sss
4783
4784             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4785      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4786      &    *fac_shield(i)*fac_shield(j)*sss
4787
4788             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4789      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4790      &    *fac_shield(i)*fac_shield(j)*sss
4791
4792             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4793      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4794      &    *fac_shield(i)*fac_shield(j)*sss
4795
4796           enddo
4797           ENDIF
4798 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4799 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4800 #ifdef FOURBODY
4801           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4802      &       .and. num_conti.le.maxconts) then
4803 c            write (iout,*) i,j," entered corr"
4804 C
4805 C Calculate the contact function. The ith column of the array JCONT will
4806 C contain the numbers of atoms that make contacts with the atom I (of numbers
4807 C greater than I). The arrays FACONT and GACONT will contain the values of
4808 C the contact function and its derivative.
4809 c           r0ij=1.02D0*rpp(iteli,itelj)
4810 c           r0ij=1.11D0*rpp(iteli,itelj)
4811             r0ij=2.20D0*rpp(iteli,itelj)
4812 c           r0ij=1.55D0*rpp(iteli,itelj)
4813             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4814             if (fcont.gt.0.0D0) then
4815               num_conti=num_conti+1
4816               if (num_conti.gt.maxconts) then
4817                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4818      &                         ' will skip next contacts for this conf.'
4819               else
4820                 jcont_hb(num_conti,i)=j
4821 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4822 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4823                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4824      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4825 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4826 C  terms.
4827                 d_cont(num_conti,i)=rij
4828 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4829 C     --- Electrostatic-interaction matrix ---
4830                 a_chuj(1,1,num_conti,i)=a22
4831                 a_chuj(1,2,num_conti,i)=a23
4832                 a_chuj(2,1,num_conti,i)=a32
4833                 a_chuj(2,2,num_conti,i)=a33
4834 C     --- Gradient of rij
4835                 do kkk=1,3
4836                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4837                 enddo
4838                 kkll=0
4839                 do k=1,2
4840                   do l=1,2
4841                     kkll=kkll+1
4842                     do m=1,3
4843                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4844                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4845                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4846                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4847                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4848                     enddo
4849                   enddo
4850                 enddo
4851                 ENDIF
4852                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4853 C Calculate contact energies
4854                 cosa4=4.0D0*cosa
4855                 wij=cosa-3.0D0*cosb*cosg
4856                 cosbg1=cosb+cosg
4857                 cosbg2=cosb-cosg
4858 c               fac3=dsqrt(-ael6i)/r0ij**3
4859                 fac3=dsqrt(-ael6i)*r3ij
4860 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4861                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4862                 if (ees0tmp.gt.0) then
4863                   ees0pij=dsqrt(ees0tmp)
4864                 else
4865                   ees0pij=0
4866                 endif
4867 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4868                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4869                 if (ees0tmp.gt.0) then
4870                   ees0mij=dsqrt(ees0tmp)
4871                 else
4872                   ees0mij=0
4873                 endif
4874 c               ees0mij=0.0D0
4875                 if (shield_mode.eq.0) then
4876                 fac_shield(i)=1.0d0
4877                 fac_shield(j)=1.0d0
4878                 else
4879                 ees0plist(num_conti,i)=j
4880 C                fac_shield(i)=0.4d0
4881 C                fac_shield(j)=0.6d0
4882                 endif
4883                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4884      &          *fac_shield(i)*fac_shield(j)*sss
4885                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4886      &          *fac_shield(i)*fac_shield(j)*sss
4887 C Diagnostics. Comment out or remove after debugging!
4888 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4889 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4890 c               ees0m(num_conti,i)=0.0D0
4891 C End diagnostics.
4892 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4893 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4894 C Angular derivatives of the contact function
4895                 ees0pij1=fac3/ees0pij
4896                 ees0mij1=fac3/ees0mij
4897                 fac3p=-3.0D0*fac3*rrmij
4898                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4899                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4900 c               ees0mij1=0.0D0
4901                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4902                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4903                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4904                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4905                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4906                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4907                 ecosap=ecosa1+ecosa2
4908                 ecosbp=ecosb1+ecosb2
4909                 ecosgp=ecosg1+ecosg2
4910                 ecosam=ecosa1-ecosa2
4911                 ecosbm=ecosb1-ecosb2
4912                 ecosgm=ecosg1-ecosg2
4913 C Diagnostics
4914 c               ecosap=ecosa1
4915 c               ecosbp=ecosb1
4916 c               ecosgp=ecosg1
4917 c               ecosam=0.0D0
4918 c               ecosbm=0.0D0
4919 c               ecosgm=0.0D0
4920 C End diagnostics
4921                 facont_hb(num_conti,i)=fcont
4922                 fprimcont=fprimcont/rij
4923 cd              facont_hb(num_conti,i)=1.0D0
4924 C Following line is for diagnostics.
4925 cd              fprimcont=0.0D0
4926                 do k=1,3
4927                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4928                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4929                 enddo
4930                 do k=1,3
4931                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4932                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4933                 enddo
4934                 gggp(1)=gggp(1)+ees0pijp*xj
4935      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4936                 gggp(2)=gggp(2)+ees0pijp*yj
4937      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4938                 gggp(3)=gggp(3)+ees0pijp*zj
4939      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4940                 gggm(1)=gggm(1)+ees0mijp*xj
4941      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4942                 gggm(2)=gggm(2)+ees0mijp*yj
4943      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4944                 gggm(3)=gggm(3)+ees0mijp*zj
4945      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4946 C Derivatives due to the contact function
4947                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4948                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4949                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4950                 do k=1,3
4951 c
4952 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4953 c          following the change of gradient-summation algorithm.
4954 c
4955 cgrad                  ghalfp=0.5D0*gggp(k)
4956 cgrad                  ghalfm=0.5D0*gggm(k)
4957                   gacontp_hb1(k,num_conti,i)=!ghalfp
4958      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4959      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4960      &          *fac_shield(i)*fac_shield(j)*sss
4961
4962                   gacontp_hb2(k,num_conti,i)=!ghalfp
4963      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4964      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4965      &          *fac_shield(i)*fac_shield(j)*sss
4966
4967                   gacontp_hb3(k,num_conti,i)=gggp(k)
4968      &          *fac_shield(i)*fac_shield(j)*sss
4969
4970                   gacontm_hb1(k,num_conti,i)=!ghalfm
4971      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4972      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4973      &          *fac_shield(i)*fac_shield(j)*sss
4974
4975                   gacontm_hb2(k,num_conti,i)=!ghalfm
4976      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4977      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4978      &          *fac_shield(i)*fac_shield(j)*sss
4979
4980                   gacontm_hb3(k,num_conti,i)=gggm(k)
4981      &          *fac_shield(i)*fac_shield(j)*sss
4982
4983                 enddo
4984 C Diagnostics. Comment out or remove after debugging!
4985 cdiag           do k=1,3
4986 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4987 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4988 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4989 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4990 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4991 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4992 cdiag           enddo
4993               ENDIF ! wcorr
4994               endif  ! num_conti.le.maxconts
4995             endif  ! fcont.gt.0
4996           endif    ! j.gt.i+1
4997 #endif
4998           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4999             do k=1,4
5000               do l=1,3
5001                 ghalf=0.5d0*agg(l,k)
5002                 aggi(l,k)=aggi(l,k)+ghalf
5003                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
5004                 aggj(l,k)=aggj(l,k)+ghalf
5005               enddo
5006             enddo
5007             if (j.eq.nres-1 .and. i.lt.j-2) then
5008               do k=1,4
5009                 do l=1,3
5010                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
5011                 enddo
5012               enddo
5013             endif
5014           endif
5015 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
5016       return
5017       end
5018 C-----------------------------------------------------------------------------
5019       subroutine eturn3(i,eello_turn3)
5020 C Third- and fourth-order contributions from turns
5021       implicit real*8 (a-h,o-z)
5022       include 'DIMENSIONS'
5023       include 'COMMON.IOUNITS'
5024       include 'COMMON.GEO'
5025       include 'COMMON.VAR'
5026       include 'COMMON.LOCAL'
5027       include 'COMMON.CHAIN'
5028       include 'COMMON.DERIV'
5029       include 'COMMON.INTERACT'
5030       include 'COMMON.CORRMAT'
5031       include 'COMMON.TORSION'
5032       include 'COMMON.VECTORS'
5033       include 'COMMON.FFIELD'
5034       include 'COMMON.CONTROL'
5035       include 'COMMON.SHIELD'
5036       dimension ggg(3)
5037       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5038      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5039      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
5040      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
5041      &  auxgmat2(2,2),auxgmatt2(2,2)
5042       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5043      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5044       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5045      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5046      &    num_conti,j1,j2
5047       j=i+2
5048 c      write (iout,*) "eturn3",i,j,j1,j2
5049       a_temp(1,1)=a22
5050       a_temp(1,2)=a23
5051       a_temp(2,1)=a32
5052       a_temp(2,2)=a33
5053 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5054 C
5055 C               Third-order contributions
5056 C
5057 C                 (i+2)o----(i+3)
5058 C                      | |
5059 C                      | |
5060 C                 (i+1)o----i
5061 C
5062 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5063 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5064         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5065 c auxalary matices for theta gradient
5066 c auxalary matrix for i+1 and constant i+2
5067         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5068 c auxalary matrix for i+2 and constant i+1
5069         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5070         call transpose2(auxmat(1,1),auxmat1(1,1))
5071         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5072         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5073         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5074         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5075         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5076         if (shield_mode.eq.0) then
5077         fac_shield(i)=1.0
5078         fac_shield(j)=1.0
5079 C        else
5080 C        fac_shield(i)=0.4
5081 C        fac_shield(j)=0.6
5082         endif
5083         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5084      &  *fac_shield(i)*fac_shield(j)
5085         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5086      &  *fac_shield(i)*fac_shield(j)
5087         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5088      &    eello_t3
5089 C#ifdef NEWCORR
5090 C Derivatives in theta
5091         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5092      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5093      &   *fac_shield(i)*fac_shield(j)
5094         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5095      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5096      &   *fac_shield(i)*fac_shield(j)
5097 C#endif
5098
5099 C Derivatives in shield mode
5100           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5101      &  (shield_mode.gt.0)) then
5102 C          print *,i,j
5103
5104           do ilist=1,ishield_list(i)
5105            iresshield=shield_list(ilist,i)
5106            do k=1,3
5107            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5108 C     &      *2.0
5109            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5110      &              rlocshield
5111      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5112             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5113      &      +rlocshield
5114            enddo
5115           enddo
5116           do ilist=1,ishield_list(j)
5117            iresshield=shield_list(ilist,j)
5118            do k=1,3
5119            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5120 C     &     *2.0
5121            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5122      &              rlocshield
5123      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5124            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5125      &             +rlocshield
5126
5127            enddo
5128           enddo
5129
5130           do k=1,3
5131             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5132      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5133             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5134      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5135             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5136      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5137             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5138      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5139            enddo
5140            endif
5141
5142 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5143 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5144 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5145 cd     &    ' eello_turn3_num',4*eello_turn3_num
5146 C Derivatives in gamma(i)
5147         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5148         call transpose2(auxmat2(1,1),auxmat3(1,1))
5149         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5150         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5151      &   *fac_shield(i)*fac_shield(j)
5152 C Derivatives in gamma(i+1)
5153         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5154         call transpose2(auxmat2(1,1),auxmat3(1,1))
5155         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5156         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5157      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5158      &   *fac_shield(i)*fac_shield(j)
5159 C Cartesian derivatives
5160         do l=1,3
5161 c            ghalf1=0.5d0*agg(l,1)
5162 c            ghalf2=0.5d0*agg(l,2)
5163 c            ghalf3=0.5d0*agg(l,3)
5164 c            ghalf4=0.5d0*agg(l,4)
5165           a_temp(1,1)=aggi(l,1)!+ghalf1
5166           a_temp(1,2)=aggi(l,2)!+ghalf2
5167           a_temp(2,1)=aggi(l,3)!+ghalf3
5168           a_temp(2,2)=aggi(l,4)!+ghalf4
5169           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5170           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5171      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5172      &   *fac_shield(i)*fac_shield(j)
5173
5174           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5175           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5176           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5177           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5178           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5179           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5180      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5181      &   *fac_shield(i)*fac_shield(j)
5182           a_temp(1,1)=aggj(l,1)!+ghalf1
5183           a_temp(1,2)=aggj(l,2)!+ghalf2
5184           a_temp(2,1)=aggj(l,3)!+ghalf3
5185           a_temp(2,2)=aggj(l,4)!+ghalf4
5186           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5187           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5188      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5189      &   *fac_shield(i)*fac_shield(j)
5190           a_temp(1,1)=aggj1(l,1)
5191           a_temp(1,2)=aggj1(l,2)
5192           a_temp(2,1)=aggj1(l,3)
5193           a_temp(2,2)=aggj1(l,4)
5194           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5195           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5196      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5197      &   *fac_shield(i)*fac_shield(j)
5198         enddo
5199       return
5200       end
5201 C-------------------------------------------------------------------------------
5202       subroutine eturn4(i,eello_turn4)
5203 C Third- and fourth-order contributions from turns
5204       implicit real*8 (a-h,o-z)
5205       include 'DIMENSIONS'
5206       include 'COMMON.IOUNITS'
5207       include 'COMMON.GEO'
5208       include 'COMMON.VAR'
5209       include 'COMMON.LOCAL'
5210       include 'COMMON.CHAIN'
5211       include 'COMMON.DERIV'
5212       include 'COMMON.INTERACT'
5213       include 'COMMON.CORRMAT'
5214       include 'COMMON.TORSION'
5215       include 'COMMON.VECTORS'
5216       include 'COMMON.FFIELD'
5217       include 'COMMON.CONTROL'
5218       include 'COMMON.SHIELD'
5219       dimension ggg(3)
5220       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5221      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5222      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5223      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5224      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5225      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5226      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5227       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5228      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5229       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5230      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5231      &    num_conti,j1,j2
5232       j=i+3
5233 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5234 C
5235 C               Fourth-order contributions
5236 C
5237 C                 (i+3)o----(i+4)
5238 C                     /  |
5239 C               (i+2)o   |
5240 C                     \  |
5241 C                 (i+1)o----i
5242 C
5243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5244 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5245 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5246 c        write(iout,*)"WCHODZE W PROGRAM"
5247         a_temp(1,1)=a22
5248         a_temp(1,2)=a23
5249         a_temp(2,1)=a32
5250         a_temp(2,2)=a33
5251         iti1=itype2loc(itype(i+1))
5252         iti2=itype2loc(itype(i+2))
5253         iti3=itype2loc(itype(i+3))
5254 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5255         call transpose2(EUg(1,1,i+1),e1t(1,1))
5256         call transpose2(Eug(1,1,i+2),e2t(1,1))
5257         call transpose2(Eug(1,1,i+3),e3t(1,1))
5258 C Ematrix derivative in theta
5259         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5260         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5261         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5262         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5263 c       eta1 in derivative theta
5264         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5265         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5266 c       auxgvec is derivative of Ub2 so i+3 theta
5267         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5268 c       auxalary matrix of E i+1
5269         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5270 c        s1=0.0
5271 c        gs1=0.0
5272         s1=scalar2(b1(1,i+2),auxvec(1))
5273 c derivative of theta i+2 with constant i+3
5274         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5275 c derivative of theta i+2 with constant i+2
5276         gs32=scalar2(b1(1,i+2),auxgvec(1))
5277 c derivative of E matix in theta of i+1
5278         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5279
5280         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5281 c       ea31 in derivative theta
5282         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5283         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5284 c auxilary matrix auxgvec of Ub2 with constant E matirx
5285         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5286 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5287         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5288
5289 c        s2=0.0
5290 c        gs2=0.0
5291         s2=scalar2(b1(1,i+1),auxvec(1))
5292 c derivative of theta i+1 with constant i+3
5293         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5294 c derivative of theta i+2 with constant i+1
5295         gs21=scalar2(b1(1,i+1),auxgvec(1))
5296 c derivative of theta i+3 with constant i+1
5297         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5298 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5299 c     &  gtb1(1,i+1)
5300         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5301 c two derivatives over diffetent matrices
5302 c gtae3e2 is derivative over i+3
5303         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5304 c ae3gte2 is derivative over i+2
5305         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5306         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5307 c three possible derivative over theta E matices
5308 c i+1
5309         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5310 c i+2
5311         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5312 c i+3
5313         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5314         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5315
5316         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5317         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5318         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5319         if (shield_mode.eq.0) then
5320         fac_shield(i)=1.0
5321         fac_shield(j)=1.0
5322 C        else
5323 C        fac_shield(i)=0.6
5324 C        fac_shield(j)=0.4
5325         endif
5326         eello_turn4=eello_turn4-(s1+s2+s3)
5327      &  *fac_shield(i)*fac_shield(j)
5328         eello_t4=-(s1+s2+s3)
5329      &  *fac_shield(i)*fac_shield(j)
5330 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5331         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5332      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5333 C Now derivative over shield:
5334           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5335      &  (shield_mode.gt.0)) then
5336 C          print *,i,j
5337
5338           do ilist=1,ishield_list(i)
5339            iresshield=shield_list(ilist,i)
5340            do k=1,3
5341            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5342 C     &      *2.0
5343            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5344      &              rlocshield
5345      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5346             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5347      &      +rlocshield
5348            enddo
5349           enddo
5350           do ilist=1,ishield_list(j)
5351            iresshield=shield_list(ilist,j)
5352            do k=1,3
5353            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5354 C     &     *2.0
5355            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5356      &              rlocshield
5357      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5358            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5359      &             +rlocshield
5360
5361            enddo
5362           enddo
5363
5364           do k=1,3
5365             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5366      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5367             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5368      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5369             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5370      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5371             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5372      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5373            enddo
5374            endif
5375
5376
5377
5378
5379
5380
5381 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5382 cd     &    ' eello_turn4_num',8*eello_turn4_num
5383 #ifdef NEWCORR
5384         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5385      &                  -(gs13+gsE13+gsEE1)*wturn4
5386      &  *fac_shield(i)*fac_shield(j)
5387         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5388      &                    -(gs23+gs21+gsEE2)*wturn4
5389      &  *fac_shield(i)*fac_shield(j)
5390
5391         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5392      &                    -(gs32+gsE31+gsEE3)*wturn4
5393      &  *fac_shield(i)*fac_shield(j)
5394
5395 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5396 c     &   gs2
5397 #endif
5398         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5399      &      'eturn4',i,j,-(s1+s2+s3)
5400 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5401 c     &    ' eello_turn4_num',8*eello_turn4_num
5402 C Derivatives in gamma(i)
5403         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5404         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5405         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5406         s1=scalar2(b1(1,i+2),auxvec(1))
5407         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5408         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5409         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5410      &  *fac_shield(i)*fac_shield(j)
5411 C Derivatives in gamma(i+1)
5412         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5413         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5414         s2=scalar2(b1(1,i+1),auxvec(1))
5415         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5416         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5417         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5418         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5419      &  *fac_shield(i)*fac_shield(j)
5420 C Derivatives in gamma(i+2)
5421         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5422         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5423         s1=scalar2(b1(1,i+2),auxvec(1))
5424         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5425         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5426         s2=scalar2(b1(1,i+1),auxvec(1))
5427         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5428         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5429         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5430         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5431      &  *fac_shield(i)*fac_shield(j)
5432 C Cartesian derivatives
5433 C Derivatives of this turn contributions in DC(i+2)
5434         if (j.lt.nres-1) then
5435           do l=1,3
5436             a_temp(1,1)=agg(l,1)
5437             a_temp(1,2)=agg(l,2)
5438             a_temp(2,1)=agg(l,3)
5439             a_temp(2,2)=agg(l,4)
5440             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5441             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5442             s1=scalar2(b1(1,i+2),auxvec(1))
5443             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5444             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5445             s2=scalar2(b1(1,i+1),auxvec(1))
5446             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5447             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5448             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5449             ggg(l)=-(s1+s2+s3)
5450             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5451      &  *fac_shield(i)*fac_shield(j)
5452           enddo
5453         endif
5454 C Remaining derivatives of this turn contribution
5455         do l=1,3
5456           a_temp(1,1)=aggi(l,1)
5457           a_temp(1,2)=aggi(l,2)
5458           a_temp(2,1)=aggi(l,3)
5459           a_temp(2,2)=aggi(l,4)
5460           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5461           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5462           s1=scalar2(b1(1,i+2),auxvec(1))
5463           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5464           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5465           s2=scalar2(b1(1,i+1),auxvec(1))
5466           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5467           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5468           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5469           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5470      &  *fac_shield(i)*fac_shield(j)
5471           a_temp(1,1)=aggi1(l,1)
5472           a_temp(1,2)=aggi1(l,2)
5473           a_temp(2,1)=aggi1(l,3)
5474           a_temp(2,2)=aggi1(l,4)
5475           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5476           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5477           s1=scalar2(b1(1,i+2),auxvec(1))
5478           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5479           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5480           s2=scalar2(b1(1,i+1),auxvec(1))
5481           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5482           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5483           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5484           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5485      &  *fac_shield(i)*fac_shield(j)
5486           a_temp(1,1)=aggj(l,1)
5487           a_temp(1,2)=aggj(l,2)
5488           a_temp(2,1)=aggj(l,3)
5489           a_temp(2,2)=aggj(l,4)
5490           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5491           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5492           s1=scalar2(b1(1,i+2),auxvec(1))
5493           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5494           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5495           s2=scalar2(b1(1,i+1),auxvec(1))
5496           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5497           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5498           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5499           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5500      &  *fac_shield(i)*fac_shield(j)
5501           a_temp(1,1)=aggj1(l,1)
5502           a_temp(1,2)=aggj1(l,2)
5503           a_temp(2,1)=aggj1(l,3)
5504           a_temp(2,2)=aggj1(l,4)
5505           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5506           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5507           s1=scalar2(b1(1,i+2),auxvec(1))
5508           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5509           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5510           s2=scalar2(b1(1,i+1),auxvec(1))
5511           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5512           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5513           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5514 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5515           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5516      &  *fac_shield(i)*fac_shield(j)
5517         enddo
5518       return
5519       end
5520 C-----------------------------------------------------------------------------
5521       subroutine vecpr(u,v,w)
5522       implicit real*8(a-h,o-z)
5523       dimension u(3),v(3),w(3)
5524       w(1)=u(2)*v(3)-u(3)*v(2)
5525       w(2)=-u(1)*v(3)+u(3)*v(1)
5526       w(3)=u(1)*v(2)-u(2)*v(1)
5527       return
5528       end
5529 C-----------------------------------------------------------------------------
5530       subroutine unormderiv(u,ugrad,unorm,ungrad)
5531 C This subroutine computes the derivatives of a normalized vector u, given
5532 C the derivatives computed without normalization conditions, ugrad. Returns
5533 C ungrad.
5534       implicit none
5535       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5536       double precision vec(3)
5537       double precision scalar
5538       integer i,j
5539 c      write (2,*) 'ugrad',ugrad
5540 c      write (2,*) 'u',u
5541       do i=1,3
5542         vec(i)=scalar(ugrad(1,i),u(1))
5543       enddo
5544 c      write (2,*) 'vec',vec
5545       do i=1,3
5546         do j=1,3
5547           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5548         enddo
5549       enddo
5550 c      write (2,*) 'ungrad',ungrad
5551       return
5552       end
5553 C-----------------------------------------------------------------------------
5554       subroutine escp_soft_sphere(evdw2,evdw2_14)
5555 C
5556 C This subroutine calculates the excluded-volume interaction energy between
5557 C peptide-group centers and side chains and its gradient in virtual-bond and
5558 C side-chain vectors.
5559 C
5560       implicit real*8 (a-h,o-z)
5561       include 'DIMENSIONS'
5562       include 'COMMON.GEO'
5563       include 'COMMON.VAR'
5564       include 'COMMON.LOCAL'
5565       include 'COMMON.CHAIN'
5566       include 'COMMON.DERIV'
5567       include 'COMMON.INTERACT'
5568       include 'COMMON.FFIELD'
5569       include 'COMMON.IOUNITS'
5570       include 'COMMON.CONTROL'
5571       dimension ggg(3)
5572       integer xshift,yshift,zshift
5573       evdw2=0.0D0
5574       evdw2_14=0.0d0
5575       r0_scp=4.5d0
5576 cd    print '(a)','Enter ESCP'
5577 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5578 C      do xshift=-1,1
5579 C      do yshift=-1,1
5580 C      do zshift=-1,1
5581 c      do i=iatscp_s,iatscp_e
5582       do ikont=g_listscp_start,g_listscp_end
5583         i=newcontlistscpi(ikont)
5584         j=newcontlistscpj(ikont)
5585         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5586         iteli=itel(i)
5587         xi=0.5D0*(c(1,i)+c(1,i+1))
5588         yi=0.5D0*(c(2,i)+c(2,i+1))
5589         zi=0.5D0*(c(3,i)+c(3,i+1))
5590 C Return atom into box, boxxsize is size of box in x dimension
5591 c  134   continue
5592 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5593 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5594 C Condition for being inside the proper box
5595 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5596 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5597 c        go to 134
5598 c        endif
5599 c  135   continue
5600 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5601 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5602 C Condition for being inside the proper box
5603 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5604 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5605 c        go to 135
5606 c c       endif
5607 c  136   continue
5608 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5609 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5610 cC Condition for being inside the proper box
5611 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5612 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5613 c        go to 136
5614 c        endif
5615           xi=mod(xi,boxxsize)
5616           if (xi.lt.0) xi=xi+boxxsize
5617           yi=mod(yi,boxysize)
5618           if (yi.lt.0) yi=yi+boxysize
5619           zi=mod(zi,boxzsize)
5620           if (zi.lt.0) zi=zi+boxzsize
5621 C          xi=xi+xshift*boxxsize
5622 C          yi=yi+yshift*boxysize
5623 C          zi=zi+zshift*boxzsize
5624 c        do iint=1,nscp_gr(i)
5625
5626 c        do j=iscpstart(i,iint),iscpend(i,iint)
5627           if (itype(j).eq.ntyp1) cycle
5628           itypj=iabs(itype(j))
5629 C Uncomment following three lines for SC-p interactions
5630 c         xj=c(1,nres+j)-xi
5631 c         yj=c(2,nres+j)-yi
5632 c         zj=c(3,nres+j)-zi
5633 C Uncomment following three lines for Ca-p interactions
5634           xj=c(1,j)
5635           yj=c(2,j)
5636           zj=c(3,j)
5637 c  174   continue
5638 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5639 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5640 C Condition for being inside the proper box
5641 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5642 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5643 c        go to 174
5644 c        endif
5645 c  175   continue
5646 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5647 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5648 cC Condition for being inside the proper box
5649 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5650 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5651 c        go to 175
5652 c        endif
5653 c  176   continue
5654 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5655 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5656 C Condition for being inside the proper box
5657 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5658 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5659 c        go to 176
5660           xj=mod(xj,boxxsize)
5661           if (xj.lt.0) xj=xj+boxxsize
5662           yj=mod(yj,boxysize)
5663           if (yj.lt.0) yj=yj+boxysize
5664           zj=mod(zj,boxzsize)
5665           if (zj.lt.0) zj=zj+boxzsize
5666       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5667       xj_safe=xj
5668       yj_safe=yj
5669       zj_safe=zj
5670       subchap=0
5671       do xshift=-1,1
5672       do yshift=-1,1
5673       do zshift=-1,1
5674           xj=xj_safe+xshift*boxxsize
5675           yj=yj_safe+yshift*boxysize
5676           zj=zj_safe+zshift*boxzsize
5677           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5678           if(dist_temp.lt.dist_init) then
5679             dist_init=dist_temp
5680             xj_temp=xj
5681             yj_temp=yj
5682             zj_temp=zj
5683             subchap=1
5684           endif
5685        enddo
5686        enddo
5687        enddo
5688        if (subchap.eq.1) then
5689           xj=xj_temp-xi
5690           yj=yj_temp-yi
5691           zj=zj_temp-zi
5692        else
5693           xj=xj_safe-xi
5694           yj=yj_safe-yi
5695           zj=zj_safe-zi
5696        endif
5697 c c       endif
5698 C          xj=xj-xi
5699 C          yj=yj-yi
5700 C          zj=zj-zi
5701           rij=xj*xj+yj*yj+zj*zj
5702
5703           r0ij=r0_scp
5704           r0ijsq=r0ij*r0ij
5705           if (rij.lt.r0ijsq) then
5706             evdwij=0.25d0*(rij-r0ijsq)**2
5707             fac=rij-r0ijsq
5708           else
5709             evdwij=0.0d0
5710             fac=0.0d0
5711           endif
5712           evdw2=evdw2+evdwij
5713 C
5714 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5715 C
5716           ggg(1)=xj*fac
5717           ggg(2)=yj*fac
5718           ggg(3)=zj*fac
5719 cgrad          if (j.lt.i) then
5720 cd          write (iout,*) 'j<i'
5721 C Uncomment following three lines for SC-p interactions
5722 c           do k=1,3
5723 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5724 c           enddo
5725 cgrad          else
5726 cd          write (iout,*) 'j>i'
5727 cgrad            do k=1,3
5728 cgrad              ggg(k)=-ggg(k)
5729 C Uncomment following line for SC-p interactions
5730 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5731 cgrad            enddo
5732 cgrad          endif
5733 cgrad          do k=1,3
5734 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5735 cgrad          enddo
5736 cgrad          kstart=min0(i+1,j)
5737 cgrad          kend=max0(i-1,j-1)
5738 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5739 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5740 cgrad          do k=kstart,kend
5741 cgrad            do l=1,3
5742 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5743 cgrad            enddo
5744 cgrad          enddo
5745           do k=1,3
5746             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5747             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5748           enddo
5749 c        enddo
5750
5751 c        enddo ! iint
5752       enddo ! i
5753 C      enddo !zshift
5754 C      enddo !yshift
5755 C      enddo !xshift
5756       return
5757       end
5758 C-----------------------------------------------------------------------------
5759       subroutine escp(evdw2,evdw2_14)
5760 C
5761 C This subroutine calculates the excluded-volume interaction energy between
5762 C peptide-group centers and side chains and its gradient in virtual-bond and
5763 C side-chain vectors.
5764 C
5765       implicit none
5766       include 'DIMENSIONS'
5767       include 'COMMON.GEO'
5768       include 'COMMON.VAR'
5769       include 'COMMON.LOCAL'
5770       include 'COMMON.CHAIN'
5771       include 'COMMON.DERIV'
5772       include 'COMMON.INTERACT'
5773       include 'COMMON.FFIELD'
5774       include 'COMMON.IOUNITS'
5775       include 'COMMON.CONTROL'
5776       include 'COMMON.SPLITELE'
5777       integer xshift,yshift,zshift
5778       double precision ggg(3)
5779       integer i,iint,j,k,iteli,itypj,subchap,ikont
5780       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5781      & fac,e1,e2,rij
5782       double precision evdw2,evdw2_14,evdwij
5783       double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,
5784      & dist_temp, dist_init
5785       double precision sscale,sscagrad
5786       evdw2=0.0D0
5787       evdw2_14=0.0d0
5788 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5789 cd    print '(a)','Enter ESCP'
5790 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5791 C      do xshift=-1,1
5792 C      do yshift=-1,1
5793 C      do zshift=-1,1
5794       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5795 c      do i=iatscp_s,iatscp_e
5796       do ikont=g_listscp_start,g_listscp_end
5797         i=newcontlistscpi(ikont)
5798         j=newcontlistscpj(ikont)
5799         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5800         iteli=itel(i)
5801         xi=0.5D0*(c(1,i)+c(1,i+1))
5802         yi=0.5D0*(c(2,i)+c(2,i+1))
5803         zi=0.5D0*(c(3,i)+c(3,i+1))
5804           xi=mod(xi,boxxsize)
5805           if (xi.lt.0) xi=xi+boxxsize
5806           yi=mod(yi,boxysize)
5807           if (yi.lt.0) yi=yi+boxysize
5808           zi=mod(zi,boxzsize)
5809           if (zi.lt.0) zi=zi+boxzsize
5810 c          xi=xi+xshift*boxxsize
5811 c          yi=yi+yshift*boxysize
5812 c          zi=zi+zshift*boxzsize
5813 c        print *,xi,yi,zi,'polozenie i'
5814 C Return atom into box, boxxsize is size of box in x dimension
5815 c  134   continue
5816 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5817 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5818 C Condition for being inside the proper box
5819 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5820 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5821 c        go to 134
5822 c        endif
5823 c  135   continue
5824 c          print *,xi,boxxsize,"pierwszy"
5825
5826 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5827 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5828 C Condition for being inside the proper box
5829 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5830 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5831 c        go to 135
5832 c        endif
5833 c  136   continue
5834 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5835 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5836 C Condition for being inside the proper box
5837 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5838 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5839 c        go to 136
5840 c        endif
5841 c        do iint=1,nscp_gr(i)
5842
5843 c        do j=iscpstart(i,iint),iscpend(i,iint)
5844           itypj=iabs(itype(j))
5845           if (itypj.eq.ntyp1) cycle
5846 C Uncomment following three lines for SC-p interactions
5847 c         xj=c(1,nres+j)-xi
5848 c         yj=c(2,nres+j)-yi
5849 c         zj=c(3,nres+j)-zi
5850 C Uncomment following three lines for Ca-p interactions
5851           xj=c(1,j)
5852           yj=c(2,j)
5853           zj=c(3,j)
5854           xj=mod(xj,boxxsize)
5855           if (xj.lt.0) xj=xj+boxxsize
5856           yj=mod(yj,boxysize)
5857           if (yj.lt.0) yj=yj+boxysize
5858           zj=mod(zj,boxzsize)
5859           if (zj.lt.0) zj=zj+boxzsize
5860 c  174   continue
5861 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5862 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5863 C Condition for being inside the proper box
5864 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5865 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5866 c        go to 174
5867 c        endif
5868 c  175   continue
5869 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5870 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5871 cC Condition for being inside the proper box
5872 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5873 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5874 c        go to 175
5875 c        endif
5876 c  176   continue
5877 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5878 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5879 C Condition for being inside the proper box
5880 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5881 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5882 c        go to 176
5883 c        endif
5884 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5885       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5886       xj_safe=xj
5887       yj_safe=yj
5888       zj_safe=zj
5889       subchap=0
5890       do xshift=-1,1
5891       do yshift=-1,1
5892       do zshift=-1,1
5893           xj=xj_safe+xshift*boxxsize
5894           yj=yj_safe+yshift*boxysize
5895           zj=zj_safe+zshift*boxzsize
5896           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5897           if(dist_temp.lt.dist_init) then
5898             dist_init=dist_temp
5899             xj_temp=xj
5900             yj_temp=yj
5901             zj_temp=zj
5902             subchap=1
5903           endif
5904        enddo
5905        enddo
5906        enddo
5907        if (subchap.eq.1) then
5908           xj=xj_temp-xi
5909           yj=yj_temp-yi
5910           zj=zj_temp-zi
5911        else
5912           xj=xj_safe-xi
5913           yj=yj_safe-yi
5914           zj=zj_safe-zi
5915        endif
5916 c          print *,xj,yj,zj,'polozenie j'
5917           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5918 c          print *,rrij
5919           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5920 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5921 c          if (sss.eq.0) print *,'czasem jest OK'
5922           if (sss.le.0.0d0) cycle
5923           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5924           fac=rrij**expon2
5925           e1=fac*fac*aad(itypj,iteli)
5926           e2=fac*bad(itypj,iteli)
5927           if (iabs(j-i) .le. 2) then
5928             e1=scal14*e1
5929             e2=scal14*e2
5930             evdw2_14=evdw2_14+(e1+e2)*sss
5931           endif
5932           evdwij=e1+e2
5933           evdw2=evdw2+evdwij*sss
5934           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5935      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5936      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5937      &       bad(itypj,iteli)
5938 C
5939 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5940 C
5941           fac=-(evdwij+e1)*rrij*sss
5942           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5943           ggg(1)=xj*fac
5944           ggg(2)=yj*fac
5945           ggg(3)=zj*fac
5946 cgrad          if (j.lt.i) then
5947 cd          write (iout,*) 'j<i'
5948 C Uncomment following three lines for SC-p interactions
5949 c           do k=1,3
5950 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5951 c           enddo
5952 cgrad          else
5953 cd          write (iout,*) 'j>i'
5954 cgrad            do k=1,3
5955 cgrad              ggg(k)=-ggg(k)
5956 C Uncomment following line for SC-p interactions
5957 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5958 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5959 cgrad            enddo
5960 cgrad          endif
5961 cgrad          do k=1,3
5962 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5963 cgrad          enddo
5964 cgrad          kstart=min0(i+1,j)
5965 cgrad          kend=max0(i-1,j-1)
5966 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5967 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5968 cgrad          do k=kstart,kend
5969 cgrad            do l=1,3
5970 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5971 cgrad            enddo
5972 cgrad          enddo
5973           do k=1,3
5974             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5975             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5976           enddo
5977 c        endif !endif for sscale cutoff
5978 c        enddo ! j
5979
5980 c        enddo ! iint
5981       enddo ! i
5982 c      enddo !zshift
5983 c      enddo !yshift
5984 c      enddo !xshift
5985       do i=1,nct
5986         do j=1,3
5987           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5988           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5989           gradx_scp(j,i)=expon*gradx_scp(j,i)
5990         enddo
5991       enddo
5992 C******************************************************************************
5993 C
5994 C                              N O T E !!!
5995 C
5996 C To save time the factor EXPON has been extracted from ALL components
5997 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5998 C use!
5999 C
6000 C******************************************************************************
6001       return
6002       end
6003 C--------------------------------------------------------------------------
6004       subroutine edis(ehpb)
6005 C
6006 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6007 C
6008       implicit real*8 (a-h,o-z)
6009       include 'DIMENSIONS'
6010       include 'COMMON.SBRIDGE'
6011       include 'COMMON.CHAIN'
6012       include 'COMMON.DERIV'
6013       include 'COMMON.VAR'
6014       include 'COMMON.INTERACT'
6015       include 'COMMON.IOUNITS'
6016       include 'COMMON.CONTROL'
6017       dimension ggg(3),ggg_peak(3,1000)
6018       ehpb=0.0D0
6019       do i=1,3
6020        ggg(i)=0.0d0
6021       enddo
6022 c 8/21/18 AL: added explicit restraints on reference coords
6023 c      write (iout,*) "restr_on_coord",restr_on_coord
6024       if (restr_on_coord) then
6025
6026       do i=nnt,nct
6027         ecoor=0.0d0
6028         if (itype(i).eq.ntyp1) cycle
6029         do j=1,3
6030           ecoor=ecoor+(c(j,i)-cref(j,i))**2
6031           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
6032         enddo
6033         if (itype(i).ne.10) then
6034           do j=1,3
6035             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
6036             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
6037           enddo
6038         endif
6039         if (energy_dec) write (iout,*)
6040      &     "i",i," bfac",bfac(i)," ecoor",ecoor
6041         ehpb=ehpb+0.5d0*bfac(i)*ecoor
6042       enddo
6043
6044       endif
6045 C      write (iout,*) ,"link_end",link_end,constr_dist
6046 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6047 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
6048 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
6049 c     &  " link_end_peak",link_end_peak
6050       if (link_end.eq.0.and.link_end_peak.eq.0) return
6051       do i=link_start_peak,link_end_peak
6052         ehpb_peak=0.0d0
6053 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
6054 c     &   ipeak(1,i),ipeak(2,i)
6055         do ip=ipeak(1,i),ipeak(2,i)
6056           ii=ihpb_peak(ip)
6057           jj=jhpb_peak(ip)
6058           dd=dist(ii,jj)
6059           iip=ip-ipeak(1,i)+1
6060 C iii and jjj point to the residues for which the distance is assigned.
6061 c          if (ii.gt.nres) then
6062 c            iii=ii-nres
6063 c            jjj=jj-nres
6064 c          else
6065 c            iii=ii
6066 c            jjj=jj
6067 c          endif
6068           if (ii.gt.nres) then
6069             iii=ii-nres
6070           else
6071             iii=ii
6072           endif
6073           if (jj.gt.nres) then
6074             jjj=jj-nres
6075           else
6076             jjj=jj
6077           endif
6078           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
6079           aux=dexp(-scal_peak*aux)
6080           ehpb_peak=ehpb_peak+aux
6081           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
6082      &      forcon_peak(ip))*aux/dd
6083           do j=1,3
6084             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
6085           enddo
6086           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
6087      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
6088      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
6089         enddo
6090 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
6091         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
6092         do ip=ipeak(1,i),ipeak(2,i)
6093           iip=ip-ipeak(1,i)+1
6094           do j=1,3
6095             ggg(j)=ggg_peak(j,iip)/ehpb_peak
6096           enddo
6097           ii=ihpb_peak(ip)
6098           jj=jhpb_peak(ip)
6099 C iii and jjj point to the residues for which the distance is assigned.
6100 c          if (ii.gt.nres) then
6101 c            iii=ii-nres
6102 c            jjj=jj-nres
6103 c          else
6104 c            iii=ii
6105 c            jjj=jj
6106 c          endif
6107           if (ii.gt.nres) then
6108             iii=ii-nres
6109           else
6110             iii=ii
6111           endif
6112           if (jj.gt.nres) then
6113             jjj=jj-nres
6114           else
6115             jjj=jj
6116           endif
6117           if (iii.lt.ii) then
6118             do j=1,3
6119               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6120             enddo
6121           endif
6122           if (jjj.lt.jj) then
6123             do j=1,3
6124               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6125             enddo
6126           endif
6127           do k=1,3
6128             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6129             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6130           enddo
6131         enddo
6132       enddo
6133       do i=link_start,link_end
6134 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6135 C CA-CA distance used in regularization of structure.
6136         ii=ihpb(i)
6137         jj=jhpb(i)
6138 C iii and jjj point to the residues for which the distance is assigned.
6139         if (ii.gt.nres) then
6140           iii=ii-nres
6141         else
6142           iii=ii
6143         endif
6144         if (jj.gt.nres) then
6145           jjj=jj-nres
6146         else
6147           jjj=jj
6148         endif
6149 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6150 c     &    dhpb(i),dhpb1(i),forcon(i)
6151 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6152 C    distance and angle dependent SS bond potential.
6153 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6154 C     & iabs(itype(jjj)).eq.1) then
6155 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6156 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6157         if (.not.dyn_ss .and. i.le.nss) then
6158 C 15/02/13 CC dynamic SSbond - additional check
6159           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6160      &        iabs(itype(jjj)).eq.1) then
6161            call ssbond_ene(iii,jjj,eij)
6162            ehpb=ehpb+2*eij
6163          endif
6164 cd          write (iout,*) "eij",eij
6165 cd   &   ' waga=',waga,' fac=',fac
6166 !        else if (ii.gt.nres .and. jj.gt.nres) then
6167         else
6168 C Calculate the distance between the two points and its difference from the
6169 C target distance.
6170           dd=dist(ii,jj)
6171           if (irestr_type(i).eq.11) then
6172             ehpb=ehpb+fordepth(i)!**4.0d0
6173      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6174             fac=fordepth(i)!**4.0d0
6175      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6176             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6177      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6178      &        ehpb,irestr_type(i)
6179           else if (irestr_type(i).eq.10) then
6180 c AL 6//19/2018 cross-link restraints
6181             xdis = 0.5d0*(dd/forcon(i))**2
6182             expdis = dexp(-xdis)
6183 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6184             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6185 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6186 c     &          " wboltzd",wboltzd
6187             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6188 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6189             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6190      &           *expdis/(aux*forcon(i)**2)
6191             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6192      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6193      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6194           else if (irestr_type(i).eq.2) then
6195 c Quartic restraints
6196             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6197             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6198      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6199      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6200             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6201           else
6202 c Quadratic restraints
6203             rdis=dd-dhpb(i)
6204 C Get the force constant corresponding to this distance.
6205             waga=forcon(i)
6206 C Calculate the contribution to energy.
6207             ehpb=ehpb+0.5d0*waga*rdis*rdis
6208             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6209      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6210      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6211 C
6212 C Evaluate gradient.
6213 C
6214             fac=waga*rdis/dd
6215           endif
6216 c Calculate Cartesian gradient
6217           do j=1,3
6218             ggg(j)=fac*(c(j,jj)-c(j,ii))
6219           enddo
6220 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6221 C If this is a SC-SC distance, we need to calculate the contributions to the
6222 C Cartesian gradient in the SC vectors (ghpbx).
6223           if (iii.lt.ii) then
6224             do j=1,3
6225               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6226             enddo
6227           endif
6228           if (jjj.lt.jj) then
6229             do j=1,3
6230               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6231             enddo
6232           endif
6233           do k=1,3
6234             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6235             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6236           enddo
6237         endif
6238       enddo
6239       return
6240       end
6241 C--------------------------------------------------------------------------
6242       subroutine ssbond_ene(i,j,eij)
6243 C
6244 C Calculate the distance and angle dependent SS-bond potential energy
6245 C using a free-energy function derived based on RHF/6-31G** ab initio
6246 C calculations of diethyl disulfide.
6247 C
6248 C A. Liwo and U. Kozlowska, 11/24/03
6249 C
6250       implicit real*8 (a-h,o-z)
6251       include 'DIMENSIONS'
6252       include 'COMMON.SBRIDGE'
6253       include 'COMMON.CHAIN'
6254       include 'COMMON.DERIV'
6255       include 'COMMON.LOCAL'
6256       include 'COMMON.INTERACT'
6257       include 'COMMON.VAR'
6258       include 'COMMON.IOUNITS'
6259       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6260       itypi=iabs(itype(i))
6261       xi=c(1,nres+i)
6262       yi=c(2,nres+i)
6263       zi=c(3,nres+i)
6264       dxi=dc_norm(1,nres+i)
6265       dyi=dc_norm(2,nres+i)
6266       dzi=dc_norm(3,nres+i)
6267 c      dsci_inv=dsc_inv(itypi)
6268       dsci_inv=vbld_inv(nres+i)
6269       itypj=iabs(itype(j))
6270 c      dscj_inv=dsc_inv(itypj)
6271       dscj_inv=vbld_inv(nres+j)
6272       xj=c(1,nres+j)-xi
6273       yj=c(2,nres+j)-yi
6274       zj=c(3,nres+j)-zi
6275       dxj=dc_norm(1,nres+j)
6276       dyj=dc_norm(2,nres+j)
6277       dzj=dc_norm(3,nres+j)
6278       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6279       rij=dsqrt(rrij)
6280       erij(1)=xj*rij
6281       erij(2)=yj*rij
6282       erij(3)=zj*rij
6283       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6284       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6285       om12=dxi*dxj+dyi*dyj+dzi*dzj
6286       do k=1,3
6287         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6288         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6289       enddo
6290       rij=1.0d0/rij
6291       deltad=rij-d0cm
6292       deltat1=1.0d0-om1
6293       deltat2=1.0d0+om2
6294       deltat12=om2-om1+2.0d0
6295       cosphi=om12-om1*om2
6296       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6297      &  +akct*deltad*deltat12
6298      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6299 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6300 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6301 c     &  " deltat12",deltat12," eij",eij
6302       ed=2*akcm*deltad+akct*deltat12
6303       pom1=akct*deltad
6304       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6305       eom1=-2*akth*deltat1-pom1-om2*pom2
6306       eom2= 2*akth*deltat2+pom1-om1*pom2
6307       eom12=pom2
6308       do k=1,3
6309         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6310         ghpbx(k,i)=ghpbx(k,i)-ggk
6311      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6312      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6313         ghpbx(k,j)=ghpbx(k,j)+ggk
6314      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6315      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6316         ghpbc(k,i)=ghpbc(k,i)-ggk
6317         ghpbc(k,j)=ghpbc(k,j)+ggk
6318       enddo
6319 C
6320 C Calculate the components of the gradient in DC and X
6321 C
6322 cgrad      do k=i,j-1
6323 cgrad        do l=1,3
6324 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6325 cgrad        enddo
6326 cgrad      enddo
6327       return
6328       end
6329 C--------------------------------------------------------------------------
6330       subroutine ebond(estr)
6331 c
6332 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6333 c
6334       implicit real*8 (a-h,o-z)
6335       include 'DIMENSIONS'
6336       include 'COMMON.LOCAL'
6337       include 'COMMON.GEO'
6338       include 'COMMON.INTERACT'
6339       include 'COMMON.DERIV'
6340       include 'COMMON.VAR'
6341       include 'COMMON.CHAIN'
6342       include 'COMMON.IOUNITS'
6343       include 'COMMON.NAMES'
6344       include 'COMMON.FFIELD'
6345       include 'COMMON.CONTROL'
6346       include 'COMMON.SETUP'
6347       double precision u(3),ud(3)
6348       estr=0.0d0
6349       estr1=0.0d0
6350       do i=ibondp_start,ibondp_end
6351 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6352 c      used
6353 #ifdef FIVEDIAG
6354         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6355         diff = vbld(i)-vbldp0
6356 #else
6357         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6358 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6359 c          do j=1,3
6360 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6361 c     &      *dc(j,i-1)/vbld(i)
6362 c          enddo
6363 c          if (energy_dec) write(iout,*)
6364 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6365 c        else
6366 C       Checking if it involves dummy (NH3+ or COO-) group
6367         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6368 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6369           diff = vbld(i)-vbldpDUM
6370           if (energy_dec) write(iout,*) "dum_bond",i,diff
6371         else
6372 C NO    vbldp0 is the equlibrium length of spring for peptide group
6373           diff = vbld(i)-vbldp0
6374         endif
6375 #endif
6376         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6377      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6378         estr=estr+diff*diff
6379         do j=1,3
6380           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6381         enddo
6382 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6383 c        endif
6384       enddo
6385
6386       estr=0.5d0*AKP*estr+estr1
6387 c
6388 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6389 c
6390       do i=ibond_start,ibond_end
6391         iti=iabs(itype(i))
6392         if (iti.ne.10 .and. iti.ne.ntyp1) then
6393           nbi=nbondterm(iti)
6394           if (nbi.eq.1) then
6395             diff=vbld(i+nres)-vbldsc0(1,iti)
6396             if (energy_dec)  write (iout,*)
6397      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6398      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6399             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6400             do j=1,3
6401               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6402             enddo
6403           else
6404             do j=1,nbi
6405               diff=vbld(i+nres)-vbldsc0(j,iti)
6406               ud(j)=aksc(j,iti)*diff
6407               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6408             enddo
6409             uprod=u(1)
6410             do j=2,nbi
6411               uprod=uprod*u(j)
6412             enddo
6413             usum=0.0d0
6414             usumsqder=0.0d0
6415             do j=1,nbi
6416               uprod1=1.0d0
6417               uprod2=1.0d0
6418               do k=1,nbi
6419                 if (k.ne.j) then
6420                   uprod1=uprod1*u(k)
6421                   uprod2=uprod2*u(k)*u(k)
6422                 endif
6423               enddo
6424               usum=usum+uprod1
6425               usumsqder=usumsqder+ud(j)*uprod2
6426             enddo
6427             estr=estr+uprod/usum
6428             do j=1,3
6429              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6430             enddo
6431           endif
6432         endif
6433       enddo
6434       return
6435       end
6436 #ifdef CRYST_THETA
6437 C--------------------------------------------------------------------------
6438       subroutine ebend(etheta)
6439 C
6440 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6441 C angles gamma and its derivatives in consecutive thetas and gammas.
6442 C
6443       implicit real*8 (a-h,o-z)
6444       include 'DIMENSIONS'
6445       include 'COMMON.LOCAL'
6446       include 'COMMON.GEO'
6447       include 'COMMON.INTERACT'
6448       include 'COMMON.DERIV'
6449       include 'COMMON.VAR'
6450       include 'COMMON.CHAIN'
6451       include 'COMMON.IOUNITS'
6452       include 'COMMON.NAMES'
6453       include 'COMMON.FFIELD'
6454       include 'COMMON.CONTROL'
6455       include 'COMMON.TORCNSTR'
6456       common /calcthet/ term1,term2,termm,diffak,ratak,
6457      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6458      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6459       double precision y(2),z(2)
6460       delta=0.02d0*pi
6461 c      time11=dexp(-2*time)
6462 c      time12=1.0d0
6463       etheta=0.0D0
6464 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6465       do i=ithet_start,ithet_end
6466         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6467      &  .or.itype(i).eq.ntyp1) cycle
6468 C Zero the energy function and its derivative at 0 or pi.
6469         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6470         it=itype(i-1)
6471         ichir1=isign(1,itype(i-2))
6472         ichir2=isign(1,itype(i))
6473          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6474          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6475          if (itype(i-1).eq.10) then
6476           itype1=isign(10,itype(i-2))
6477           ichir11=isign(1,itype(i-2))
6478           ichir12=isign(1,itype(i-2))
6479           itype2=isign(10,itype(i))
6480           ichir21=isign(1,itype(i))
6481           ichir22=isign(1,itype(i))
6482          endif
6483
6484         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6485 #ifdef OSF
6486           phii=phi(i)
6487           if (phii.ne.phii) phii=150.0
6488 #else
6489           phii=phi(i)
6490 #endif
6491           y(1)=dcos(phii)
6492           y(2)=dsin(phii)
6493         else
6494           y(1)=0.0D0
6495           y(2)=0.0D0
6496         endif
6497         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6498 #ifdef OSF
6499           phii1=phi(i+1)
6500           if (phii1.ne.phii1) phii1=150.0
6501           phii1=pinorm(phii1)
6502           z(1)=cos(phii1)
6503 #else
6504           phii1=phi(i+1)
6505 #endif
6506           z(1)=dcos(phii1)
6507           z(2)=dsin(phii1)
6508         else
6509           z(1)=0.0D0
6510           z(2)=0.0D0
6511         endif
6512 C Calculate the "mean" value of theta from the part of the distribution
6513 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6514 C In following comments this theta will be referred to as t_c.
6515         thet_pred_mean=0.0d0
6516         do k=1,2
6517             athetk=athet(k,it,ichir1,ichir2)
6518             bthetk=bthet(k,it,ichir1,ichir2)
6519           if (it.eq.10) then
6520              athetk=athet(k,itype1,ichir11,ichir12)
6521              bthetk=bthet(k,itype2,ichir21,ichir22)
6522           endif
6523          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6524 c         write(iout,*) 'chuj tu', y(k),z(k)
6525         enddo
6526         dthett=thet_pred_mean*ssd
6527         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6528 C Derivatives of the "mean" values in gamma1 and gamma2.
6529         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6530      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6531          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6532      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6533          if (it.eq.10) then
6534       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6535      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6536         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6537      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6538          endif
6539         if (theta(i).gt.pi-delta) then
6540           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6541      &         E_tc0)
6542           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6543           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6544           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6545      &        E_theta)
6546           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6547      &        E_tc)
6548         else if (theta(i).lt.delta) then
6549           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6550           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6551           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6552      &        E_theta)
6553           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6554           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6555      &        E_tc)
6556         else
6557           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6558      &        E_theta,E_tc)
6559         endif
6560         etheta=etheta+ethetai
6561         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6562      &      'ebend',i,ethetai,theta(i),itype(i)
6563         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6564         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6565         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6566       enddo
6567
6568 C Ufff.... We've done all this!!!
6569       return
6570       end
6571 C---------------------------------------------------------------------------
6572       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6573      &     E_tc)
6574       implicit real*8 (a-h,o-z)
6575       include 'DIMENSIONS'
6576       include 'COMMON.LOCAL'
6577       include 'COMMON.IOUNITS'
6578       common /calcthet/ term1,term2,termm,diffak,ratak,
6579      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6580      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6581 C Calculate the contributions to both Gaussian lobes.
6582 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6583 C The "polynomial part" of the "standard deviation" of this part of
6584 C the distributioni.
6585 ccc        write (iout,*) thetai,thet_pred_mean
6586         sig=polthet(3,it)
6587         do j=2,0,-1
6588           sig=sig*thet_pred_mean+polthet(j,it)
6589         enddo
6590 C Derivative of the "interior part" of the "standard deviation of the"
6591 C gamma-dependent Gaussian lobe in t_c.
6592         sigtc=3*polthet(3,it)
6593         do j=2,1,-1
6594           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6595         enddo
6596         sigtc=sig*sigtc
6597 C Set the parameters of both Gaussian lobes of the distribution.
6598 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6599         fac=sig*sig+sigc0(it)
6600         sigcsq=fac+fac
6601         sigc=1.0D0/sigcsq
6602 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6603         sigsqtc=-4.0D0*sigcsq*sigtc
6604 c       print *,i,sig,sigtc,sigsqtc
6605 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6606         sigtc=-sigtc/(fac*fac)
6607 C Following variable is sigma(t_c)**(-2)
6608         sigcsq=sigcsq*sigcsq
6609         sig0i=sig0(it)
6610         sig0inv=1.0D0/sig0i**2
6611         delthec=thetai-thet_pred_mean
6612         delthe0=thetai-theta0i
6613         term1=-0.5D0*sigcsq*delthec*delthec
6614         term2=-0.5D0*sig0inv*delthe0*delthe0
6615 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6616 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6617 C NaNs in taking the logarithm. We extract the largest exponent which is added
6618 C to the energy (this being the log of the distribution) at the end of energy
6619 C term evaluation for this virtual-bond angle.
6620         if (term1.gt.term2) then
6621           termm=term1
6622           term2=dexp(term2-termm)
6623           term1=1.0d0
6624         else
6625           termm=term2
6626           term1=dexp(term1-termm)
6627           term2=1.0d0
6628         endif
6629 C The ratio between the gamma-independent and gamma-dependent lobes of
6630 C the distribution is a Gaussian function of thet_pred_mean too.
6631         diffak=gthet(2,it)-thet_pred_mean
6632         ratak=diffak/gthet(3,it)**2
6633         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6634 C Let's differentiate it in thet_pred_mean NOW.
6635         aktc=ak*ratak
6636 C Now put together the distribution terms to make complete distribution.
6637         termexp=term1+ak*term2
6638         termpre=sigc+ak*sig0i
6639 C Contribution of the bending energy from this theta is just the -log of
6640 C the sum of the contributions from the two lobes and the pre-exponential
6641 C factor. Simple enough, isn't it?
6642         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6643 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6644 C NOW the derivatives!!!
6645 C 6/6/97 Take into account the deformation.
6646         E_theta=(delthec*sigcsq*term1
6647      &       +ak*delthe0*sig0inv*term2)/termexp
6648         E_tc=((sigtc+aktc*sig0i)/termpre
6649      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6650      &       aktc*term2)/termexp)
6651       return
6652       end
6653 c-----------------------------------------------------------------------------
6654       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6655       implicit real*8 (a-h,o-z)
6656       include 'DIMENSIONS'
6657       include 'COMMON.LOCAL'
6658       include 'COMMON.IOUNITS'
6659       common /calcthet/ term1,term2,termm,diffak,ratak,
6660      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6661      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6662       delthec=thetai-thet_pred_mean
6663       delthe0=thetai-theta0i
6664 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6665       t3 = thetai-thet_pred_mean
6666       t6 = t3**2
6667       t9 = term1
6668       t12 = t3*sigcsq
6669       t14 = t12+t6*sigsqtc
6670       t16 = 1.0d0
6671       t21 = thetai-theta0i
6672       t23 = t21**2
6673       t26 = term2
6674       t27 = t21*t26
6675       t32 = termexp
6676       t40 = t32**2
6677       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6678      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6679      & *(-t12*t9-ak*sig0inv*t27)
6680       return
6681       end
6682 #else
6683 C--------------------------------------------------------------------------
6684       subroutine ebend(etheta)
6685 C
6686 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6687 C angles gamma and its derivatives in consecutive thetas and gammas.
6688 C ab initio-derived potentials from
6689 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6690 C
6691       implicit real*8 (a-h,o-z)
6692       include 'DIMENSIONS'
6693       include 'COMMON.LOCAL'
6694       include 'COMMON.GEO'
6695       include 'COMMON.INTERACT'
6696       include 'COMMON.DERIV'
6697       include 'COMMON.VAR'
6698       include 'COMMON.CHAIN'
6699       include 'COMMON.IOUNITS'
6700       include 'COMMON.NAMES'
6701       include 'COMMON.FFIELD'
6702       include 'COMMON.CONTROL'
6703       include 'COMMON.TORCNSTR'
6704       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6705      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6706      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6707      & sinph1ph2(maxdouble,maxdouble)
6708       logical lprn /.false./, lprn1 /.false./
6709       etheta=0.0D0
6710       do i=ithet_start,ithet_end
6711 c        print *,i,itype(i-1),itype(i),itype(i-2)
6712         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6713      &  .or.itype(i).eq.ntyp1) cycle
6714 C        print *,i,theta(i)
6715         if (iabs(itype(i+1)).eq.20) iblock=2
6716         if (iabs(itype(i+1)).ne.20) iblock=1
6717         dethetai=0.0d0
6718         dephii=0.0d0
6719         dephii1=0.0d0
6720         theti2=0.5d0*theta(i)
6721         ityp2=ithetyp((itype(i-1)))
6722         do k=1,nntheterm
6723           coskt(k)=dcos(k*theti2)
6724           sinkt(k)=dsin(k*theti2)
6725         enddo
6726 C        print *,ethetai
6727         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6728 #ifdef OSF
6729           phii=phi(i)
6730           if (phii.ne.phii) phii=150.0
6731 #else
6732           phii=phi(i)
6733 #endif
6734           ityp1=ithetyp((itype(i-2)))
6735 C propagation of chirality for glycine type
6736           do k=1,nsingle
6737             cosph1(k)=dcos(k*phii)
6738             sinph1(k)=dsin(k*phii)
6739           enddo
6740         else
6741           phii=0.0d0
6742           do k=1,nsingle
6743           ityp1=ithetyp((itype(i-2)))
6744             cosph1(k)=0.0d0
6745             sinph1(k)=0.0d0
6746           enddo
6747         endif
6748         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6749 #ifdef OSF
6750           phii1=phi(i+1)
6751           if (phii1.ne.phii1) phii1=150.0
6752           phii1=pinorm(phii1)
6753 #else
6754           phii1=phi(i+1)
6755 #endif
6756           ityp3=ithetyp((itype(i)))
6757           do k=1,nsingle
6758             cosph2(k)=dcos(k*phii1)
6759             sinph2(k)=dsin(k*phii1)
6760           enddo
6761         else
6762           phii1=0.0d0
6763           ityp3=ithetyp((itype(i)))
6764           do k=1,nsingle
6765             cosph2(k)=0.0d0
6766             sinph2(k)=0.0d0
6767           enddo
6768         endif
6769         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6770         do k=1,ndouble
6771           do l=1,k-1
6772             ccl=cosph1(l)*cosph2(k-l)
6773             ssl=sinph1(l)*sinph2(k-l)
6774             scl=sinph1(l)*cosph2(k-l)
6775             csl=cosph1(l)*sinph2(k-l)
6776             cosph1ph2(l,k)=ccl-ssl
6777             cosph1ph2(k,l)=ccl+ssl
6778             sinph1ph2(l,k)=scl+csl
6779             sinph1ph2(k,l)=scl-csl
6780           enddo
6781         enddo
6782         if (lprn) then
6783         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6784      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6785         write (iout,*) "coskt and sinkt"
6786         do k=1,nntheterm
6787           write (iout,*) k,coskt(k),sinkt(k)
6788         enddo
6789         endif
6790         do k=1,ntheterm
6791           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6792           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6793      &      *coskt(k)
6794           if (lprn)
6795      &    write (iout,*) "k",k,"
6796      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6797      &     " ethetai",ethetai
6798         enddo
6799         if (lprn) then
6800         write (iout,*) "cosph and sinph"
6801         do k=1,nsingle
6802           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6803         enddo
6804         write (iout,*) "cosph1ph2 and sinph2ph2"
6805         do k=2,ndouble
6806           do l=1,k-1
6807             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6808      &         sinph1ph2(l,k),sinph1ph2(k,l)
6809           enddo
6810         enddo
6811         write(iout,*) "ethetai",ethetai
6812         endif
6813 C       print *,ethetai
6814         do m=1,ntheterm2
6815           do k=1,nsingle
6816             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6817      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6818      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6819      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6820             ethetai=ethetai+sinkt(m)*aux
6821             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6822             dephii=dephii+k*sinkt(m)*(
6823      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6824      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6825             dephii1=dephii1+k*sinkt(m)*(
6826      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6827      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6828             if (lprn)
6829      &      write (iout,*) "m",m," k",k," bbthet",
6830      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6831      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6832      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6833      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6834 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6835           enddo
6836         enddo
6837 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6838 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6839 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6840 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6841         if (lprn)
6842      &  write(iout,*) "ethetai",ethetai
6843 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6844         do m=1,ntheterm3
6845           do k=2,ndouble
6846             do l=1,k-1
6847               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6848      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6849      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6850      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6851               ethetai=ethetai+sinkt(m)*aux
6852               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6853               dephii=dephii+l*sinkt(m)*(
6854      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6855      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6856      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6857      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6858               dephii1=dephii1+(k-l)*sinkt(m)*(
6859      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6860      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6861      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6862      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6863               if (lprn) then
6864               write (iout,*) "m",m," k",k," l",l," ffthet",
6865      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6866      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6867      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6868      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6869      &            " ethetai",ethetai
6870               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6871      &            cosph1ph2(k,l)*sinkt(m),
6872      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6873               endif
6874             enddo
6875           enddo
6876         enddo
6877 10      continue
6878 c        lprn1=.true.
6879 C        print *,ethetai
6880         if (lprn1)
6881      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6882      &   i,theta(i)*rad2deg,phii*rad2deg,
6883      &   phii1*rad2deg,ethetai
6884 c        lprn1=.false.
6885         etheta=etheta+ethetai
6886         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6887         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6888         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6889       enddo
6890
6891       return
6892       end
6893 #endif
6894 #ifdef CRYST_SC
6895 c-----------------------------------------------------------------------------
6896       subroutine esc(escloc)
6897 C Calculate the local energy of a side chain and its derivatives in the
6898 C corresponding virtual-bond valence angles THETA and the spherical angles
6899 C ALPHA and OMEGA.
6900       implicit real*8 (a-h,o-z)
6901       include 'DIMENSIONS'
6902       include 'COMMON.GEO'
6903       include 'COMMON.LOCAL'
6904       include 'COMMON.VAR'
6905       include 'COMMON.INTERACT'
6906       include 'COMMON.DERIV'
6907       include 'COMMON.CHAIN'
6908       include 'COMMON.IOUNITS'
6909       include 'COMMON.NAMES'
6910       include 'COMMON.FFIELD'
6911       include 'COMMON.CONTROL'
6912       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6913      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6914       common /sccalc/ time11,time12,time112,theti,it,nlobit
6915       delta=0.02d0*pi
6916       escloc=0.0D0
6917 c     write (iout,'(a)') 'ESC'
6918       do i=loc_start,loc_end
6919         it=itype(i)
6920         if (it.eq.ntyp1) cycle
6921         if (it.eq.10) goto 1
6922         nlobit=nlob(iabs(it))
6923 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6924 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6925         theti=theta(i+1)-pipol
6926         x(1)=dtan(theti)
6927         x(2)=alph(i)
6928         x(3)=omeg(i)
6929
6930         if (x(2).gt.pi-delta) then
6931           xtemp(1)=x(1)
6932           xtemp(2)=pi-delta
6933           xtemp(3)=x(3)
6934           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6935           xtemp(2)=pi
6936           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6937           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6938      &        escloci,dersc(2))
6939           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6940      &        ddersc0(1),dersc(1))
6941           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6942      &        ddersc0(3),dersc(3))
6943           xtemp(2)=pi-delta
6944           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6945           xtemp(2)=pi
6946           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6947           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6948      &            dersc0(2),esclocbi,dersc02)
6949           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6950      &            dersc12,dersc01)
6951           call splinthet(x(2),0.5d0*delta,ss,ssd)
6952           dersc0(1)=dersc01
6953           dersc0(2)=dersc02
6954           dersc0(3)=0.0d0
6955           do k=1,3
6956             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6957           enddo
6958           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6959 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6960 c    &             esclocbi,ss,ssd
6961           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6962 c         escloci=esclocbi
6963 c         write (iout,*) escloci
6964         else if (x(2).lt.delta) then
6965           xtemp(1)=x(1)
6966           xtemp(2)=delta
6967           xtemp(3)=x(3)
6968           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6969           xtemp(2)=0.0d0
6970           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6971           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6972      &        escloci,dersc(2))
6973           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6974      &        ddersc0(1),dersc(1))
6975           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6976      &        ddersc0(3),dersc(3))
6977           xtemp(2)=delta
6978           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6979           xtemp(2)=0.0d0
6980           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6981           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6982      &            dersc0(2),esclocbi,dersc02)
6983           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6984      &            dersc12,dersc01)
6985           dersc0(1)=dersc01
6986           dersc0(2)=dersc02
6987           dersc0(3)=0.0d0
6988           call splinthet(x(2),0.5d0*delta,ss,ssd)
6989           do k=1,3
6990             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6991           enddo
6992           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6993 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6994 c    &             esclocbi,ss,ssd
6995           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6996 c         write (iout,*) escloci
6997         else
6998           call enesc(x,escloci,dersc,ddummy,.false.)
6999         endif
7000
7001         escloc=escloc+escloci
7002         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7003      &     'escloc',i,escloci
7004 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
7005
7006         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
7007      &   wscloc*dersc(1)
7008         gloc(ialph(i,1),icg)=wscloc*dersc(2)
7009         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
7010     1   continue
7011       enddo
7012       return
7013       end
7014 C---------------------------------------------------------------------------
7015       subroutine enesc(x,escloci,dersc,ddersc,mixed)
7016       implicit real*8 (a-h,o-z)
7017       include 'DIMENSIONS'
7018       include 'COMMON.GEO'
7019       include 'COMMON.LOCAL'
7020       include 'COMMON.IOUNITS'
7021       common /sccalc/ time11,time12,time112,theti,it,nlobit
7022       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7023       double precision contr(maxlob,-1:1)
7024       logical mixed
7025 c       write (iout,*) 'it=',it,' nlobit=',nlobit
7026         escloc_i=0.0D0
7027         do j=1,3
7028           dersc(j)=0.0D0
7029           if (mixed) ddersc(j)=0.0d0
7030         enddo
7031         x3=x(3)
7032
7033 C Because of periodicity of the dependence of the SC energy in omega we have
7034 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7035 C To avoid underflows, first compute & store the exponents.
7036
7037         do iii=-1,1
7038
7039           x(3)=x3+iii*dwapi
7040
7041           do j=1,nlobit
7042             do k=1,3
7043               z(k)=x(k)-censc(k,j,it)
7044             enddo
7045             do k=1,3
7046               Axk=0.0D0
7047               do l=1,3
7048                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7049               enddo
7050               Ax(k,j,iii)=Axk
7051             enddo
7052             expfac=0.0D0
7053             do k=1,3
7054               expfac=expfac+Ax(k,j,iii)*z(k)
7055             enddo
7056             contr(j,iii)=expfac
7057           enddo ! j
7058
7059         enddo ! iii
7060
7061         x(3)=x3
7062 C As in the case of ebend, we want to avoid underflows in exponentiation and
7063 C subsequent NaNs and INFs in energy calculation.
7064 C Find the largest exponent
7065         emin=contr(1,-1)
7066         do iii=-1,1
7067           do j=1,nlobit
7068             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7069           enddo
7070         enddo
7071         emin=0.5D0*emin
7072 cd      print *,'it=',it,' emin=',emin
7073
7074 C Compute the contribution to SC energy and derivatives
7075         do iii=-1,1
7076
7077           do j=1,nlobit
7078 #ifdef OSF
7079             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7080             if(adexp.ne.adexp) adexp=1.0
7081             expfac=dexp(adexp)
7082 #else
7083             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7084 #endif
7085 cd          print *,'j=',j,' expfac=',expfac
7086             escloc_i=escloc_i+expfac
7087             do k=1,3
7088               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7089             enddo
7090             if (mixed) then
7091               do k=1,3,2
7092                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7093      &            +gaussc(k,2,j,it))*expfac
7094               enddo
7095             endif
7096           enddo
7097
7098         enddo ! iii
7099
7100         dersc(1)=dersc(1)/cos(theti)**2
7101         ddersc(1)=ddersc(1)/cos(theti)**2
7102         ddersc(3)=ddersc(3)
7103
7104         escloci=-(dlog(escloc_i)-emin)
7105         do j=1,3
7106           dersc(j)=dersc(j)/escloc_i
7107         enddo
7108         if (mixed) then
7109           do j=1,3,2
7110             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7111           enddo
7112         endif
7113       return
7114       end
7115 C------------------------------------------------------------------------------
7116       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7117       implicit real*8 (a-h,o-z)
7118       include 'DIMENSIONS'
7119       include 'COMMON.GEO'
7120       include 'COMMON.LOCAL'
7121       include 'COMMON.IOUNITS'
7122       common /sccalc/ time11,time12,time112,theti,it,nlobit
7123       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7124       double precision contr(maxlob)
7125       logical mixed
7126
7127       escloc_i=0.0D0
7128
7129       do j=1,3
7130         dersc(j)=0.0D0
7131       enddo
7132
7133       do j=1,nlobit
7134         do k=1,2
7135           z(k)=x(k)-censc(k,j,it)
7136         enddo
7137         z(3)=dwapi
7138         do k=1,3
7139           Axk=0.0D0
7140           do l=1,3
7141             Axk=Axk+gaussc(l,k,j,it)*z(l)
7142           enddo
7143           Ax(k,j)=Axk
7144         enddo
7145         expfac=0.0D0
7146         do k=1,3
7147           expfac=expfac+Ax(k,j)*z(k)
7148         enddo
7149         contr(j)=expfac
7150       enddo ! j
7151
7152 C As in the case of ebend, we want to avoid underflows in exponentiation and
7153 C subsequent NaNs and INFs in energy calculation.
7154 C Find the largest exponent
7155       emin=contr(1)
7156       do j=1,nlobit
7157         if (emin.gt.contr(j)) emin=contr(j)
7158       enddo
7159       emin=0.5D0*emin
7160
7161 C Compute the contribution to SC energy and derivatives
7162
7163       dersc12=0.0d0
7164       do j=1,nlobit
7165         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7166         escloc_i=escloc_i+expfac
7167         do k=1,2
7168           dersc(k)=dersc(k)+Ax(k,j)*expfac
7169         enddo
7170         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7171      &            +gaussc(1,2,j,it))*expfac
7172         dersc(3)=0.0d0
7173       enddo
7174
7175       dersc(1)=dersc(1)/cos(theti)**2
7176       dersc12=dersc12/cos(theti)**2
7177       escloci=-(dlog(escloc_i)-emin)
7178       do j=1,2
7179         dersc(j)=dersc(j)/escloc_i
7180       enddo
7181       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7182       return
7183       end
7184 #else
7185 c----------------------------------------------------------------------------------
7186       subroutine esc(escloc)
7187 C Calculate the local energy of a side chain and its derivatives in the
7188 C corresponding virtual-bond valence angles THETA and the spherical angles
7189 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7190 C added by Urszula Kozlowska. 07/11/2007
7191 C
7192       implicit real*8 (a-h,o-z)
7193       include 'DIMENSIONS'
7194       include 'COMMON.GEO'
7195       include 'COMMON.LOCAL'
7196       include 'COMMON.VAR'
7197       include 'COMMON.SCROT'
7198       include 'COMMON.INTERACT'
7199       include 'COMMON.DERIV'
7200       include 'COMMON.CHAIN'
7201       include 'COMMON.IOUNITS'
7202       include 'COMMON.NAMES'
7203       include 'COMMON.FFIELD'
7204       include 'COMMON.CONTROL'
7205       include 'COMMON.VECTORS'
7206       double precision x_prime(3),y_prime(3),z_prime(3)
7207      &    , sumene,dsc_i,dp2_i,x(65),
7208      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7209      &    de_dxx,de_dyy,de_dzz,de_dt
7210       double precision s1_t,s1_6_t,s2_t,s2_6_t
7211       double precision
7212      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7213      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7214      & dt_dCi(3),dt_dCi1(3)
7215       common /sccalc/ time11,time12,time112,theti,it,nlobit
7216       delta=0.02d0*pi
7217       escloc=0.0D0
7218       do i=loc_start,loc_end
7219         if (itype(i).eq.ntyp1) cycle
7220         costtab(i+1) =dcos(theta(i+1))
7221         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7222         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7223         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7224         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7225         cosfac=dsqrt(cosfac2)
7226         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7227         sinfac=dsqrt(sinfac2)
7228         it=iabs(itype(i))
7229         if (it.eq.10) goto 1
7230 c
7231 C  Compute the axes of tghe local cartesian coordinates system; store in
7232 c   x_prime, y_prime and z_prime
7233 c
7234         do j=1,3
7235           x_prime(j) = 0.00
7236           y_prime(j) = 0.00
7237           z_prime(j) = 0.00
7238         enddo
7239 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7240 C     &   dc_norm(3,i+nres)
7241         do j = 1,3
7242           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7243           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7244         enddo
7245         do j = 1,3
7246           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7247         enddo
7248 c       write (2,*) "i",i
7249 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7250 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7251 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7252 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7253 c      & " xy",scalar(x_prime(1),y_prime(1)),
7254 c      & " xz",scalar(x_prime(1),z_prime(1)),
7255 c      & " yy",scalar(y_prime(1),y_prime(1)),
7256 c      & " yz",scalar(y_prime(1),z_prime(1)),
7257 c      & " zz",scalar(z_prime(1),z_prime(1))
7258 c
7259 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7260 C to local coordinate system. Store in xx, yy, zz.
7261 c
7262         xx=0.0d0
7263         yy=0.0d0
7264         zz=0.0d0
7265         do j = 1,3
7266           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7267           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7268           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7269         enddo
7270
7271         xxtab(i)=xx
7272         yytab(i)=yy
7273         zztab(i)=zz
7274 C
7275 C Compute the energy of the ith side cbain
7276 C
7277 c        write (2,*) "xx",xx," yy",yy," zz",zz
7278         it=iabs(itype(i))
7279         do j = 1,65
7280           x(j) = sc_parmin(j,it)
7281         enddo
7282 #ifdef CHECK_COORD
7283 Cc diagnostics - remove later
7284         xx1 = dcos(alph(2))
7285         yy1 = dsin(alph(2))*dcos(omeg(2))
7286         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7287         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7288      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7289      &    xx1,yy1,zz1
7290 C,"  --- ", xx_w,yy_w,zz_w
7291 c end diagnostics
7292 #endif
7293         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7294      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7295      &   + x(10)*yy*zz
7296         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7297      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7298      & + x(20)*yy*zz
7299         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7300      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7301      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7302      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7303      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7304      &  +x(40)*xx*yy*zz
7305         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7306      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7307      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7308      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7309      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7310      &  +x(60)*xx*yy*zz
7311         dsc_i   = 0.743d0+x(61)
7312         dp2_i   = 1.9d0+x(62)
7313         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7314      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7315         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7316      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7317         s1=(1+x(63))/(0.1d0 + dscp1)
7318         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7319         s2=(1+x(65))/(0.1d0 + dscp2)
7320         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7321         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7322      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7323 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7324 c     &   sumene4,
7325 c     &   dscp1,dscp2,sumene
7326 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7327         escloc = escloc + sumene
7328         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7329      &   " escloc",sumene,escloc,it,itype(i)
7330 c     & ,zz,xx,yy
7331 c#define DEBUG
7332 #ifdef DEBUG
7333 C
7334 C This section to check the numerical derivatives of the energy of ith side
7335 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7336 C #define DEBUG in the code to turn it on.
7337 C
7338         write (2,*) "sumene               =",sumene
7339         aincr=1.0d-7
7340         xxsave=xx
7341         xx=xx+aincr
7342         write (2,*) xx,yy,zz
7343         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7344         de_dxx_num=(sumenep-sumene)/aincr
7345         xx=xxsave
7346         write (2,*) "xx+ sumene from enesc=",sumenep
7347         yysave=yy
7348         yy=yy+aincr
7349         write (2,*) xx,yy,zz
7350         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7351         de_dyy_num=(sumenep-sumene)/aincr
7352         yy=yysave
7353         write (2,*) "yy+ sumene from enesc=",sumenep
7354         zzsave=zz
7355         zz=zz+aincr
7356         write (2,*) xx,yy,zz
7357         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7358         de_dzz_num=(sumenep-sumene)/aincr
7359         zz=zzsave
7360         write (2,*) "zz+ sumene from enesc=",sumenep
7361         costsave=cost2tab(i+1)
7362         sintsave=sint2tab(i+1)
7363         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7364         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7365         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7366         de_dt_num=(sumenep-sumene)/aincr
7367         write (2,*) " t+ sumene from enesc=",sumenep
7368         cost2tab(i+1)=costsave
7369         sint2tab(i+1)=sintsave
7370 C End of diagnostics section.
7371 #endif
7372 C
7373 C Compute the gradient of esc
7374 C
7375 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7376         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7377         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7378         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7379         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7380         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7381         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7382         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7383         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7384         pom1=(sumene3*sint2tab(i+1)+sumene1)
7385      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7386         pom2=(sumene4*cost2tab(i+1)+sumene2)
7387      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7388         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7389         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7390      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7391      &  +x(40)*yy*zz
7392         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7393         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7394      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7395      &  +x(60)*yy*zz
7396         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7397      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7398      &        +(pom1+pom2)*pom_dx
7399 #ifdef DEBUG
7400         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7401 #endif
7402 C
7403         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7404         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7405      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7406      &  +x(40)*xx*zz
7407         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7408         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7409      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7410      &  +x(59)*zz**2 +x(60)*xx*zz
7411         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7412      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7413      &        +(pom1-pom2)*pom_dy
7414 #ifdef DEBUG
7415         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7416 #endif
7417 C
7418         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7419      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7420      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7421      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7422      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7423      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7424      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7425      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7426 #ifdef DEBUG
7427         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7428 #endif
7429 C
7430         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7431      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7432      &  +pom1*pom_dt1+pom2*pom_dt2
7433 #ifdef DEBUG
7434         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7435 #endif
7436 c#undef DEBUG
7437 c
7438 C
7439        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7440        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7441        cosfac2xx=cosfac2*xx
7442        sinfac2yy=sinfac2*yy
7443        do k = 1,3
7444          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7445      &      vbld_inv(i+1)
7446          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7447      &      vbld_inv(i)
7448          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7449          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7450 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7451 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7452 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7453 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7454          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7455          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7456          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7457          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7458          dZZ_Ci1(k)=0.0d0
7459          dZZ_Ci(k)=0.0d0
7460          do j=1,3
7461            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7462      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7463            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7464      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7465          enddo
7466
7467          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7468          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7469          dZZ_XYZ(k)=vbld_inv(i+nres)*
7470      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7471 c
7472          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7473          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7474        enddo
7475
7476        do k=1,3
7477          dXX_Ctab(k,i)=dXX_Ci(k)
7478          dXX_C1tab(k,i)=dXX_Ci1(k)
7479          dYY_Ctab(k,i)=dYY_Ci(k)
7480          dYY_C1tab(k,i)=dYY_Ci1(k)
7481          dZZ_Ctab(k,i)=dZZ_Ci(k)
7482          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7483          dXX_XYZtab(k,i)=dXX_XYZ(k)
7484          dYY_XYZtab(k,i)=dYY_XYZ(k)
7485          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7486        enddo
7487
7488        do k = 1,3
7489 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7490 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7491 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7492 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7493 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7494 c     &    dt_dci(k)
7495 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7496 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7497          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7498      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7499          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7500      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7501          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7502      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7503        enddo
7504 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7505 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7506
7507 C to check gradient call subroutine check_grad
7508
7509     1 continue
7510       enddo
7511       return
7512       end
7513 c------------------------------------------------------------------------------
7514       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7515       implicit none
7516       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7517      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7518       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7519      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7520      &   + x(10)*yy*zz
7521       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7522      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7523      & + x(20)*yy*zz
7524       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7525      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7526      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7527      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7528      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7529      &  +x(40)*xx*yy*zz
7530       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7531      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7532      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7533      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7534      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7535      &  +x(60)*xx*yy*zz
7536       dsc_i   = 0.743d0+x(61)
7537       dp2_i   = 1.9d0+x(62)
7538       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7539      &          *(xx*cost2+yy*sint2))
7540       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7541      &          *(xx*cost2-yy*sint2))
7542       s1=(1+x(63))/(0.1d0 + dscp1)
7543       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7544       s2=(1+x(65))/(0.1d0 + dscp2)
7545       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7546       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7547      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7548       enesc=sumene
7549       return
7550       end
7551 #endif
7552 c------------------------------------------------------------------------------
7553       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7554 C
7555 C This procedure calculates two-body contact function g(rij) and its derivative:
7556 C
7557 C           eps0ij                                     !       x < -1
7558 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7559 C            0                                         !       x > 1
7560 C
7561 C where x=(rij-r0ij)/delta
7562 C
7563 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7564 C
7565       implicit none
7566       double precision rij,r0ij,eps0ij,fcont,fprimcont
7567       double precision x,x2,x4,delta
7568 c     delta=0.02D0*r0ij
7569 c      delta=0.2D0*r0ij
7570       x=(rij-r0ij)/delta
7571       if (x.lt.-1.0D0) then
7572         fcont=eps0ij
7573         fprimcont=0.0D0
7574       else if (x.le.1.0D0) then
7575         x2=x*x
7576         x4=x2*x2
7577         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7578         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7579       else
7580         fcont=0.0D0
7581         fprimcont=0.0D0
7582       endif
7583       return
7584       end
7585 c------------------------------------------------------------------------------
7586       subroutine splinthet(theti,delta,ss,ssder)
7587       implicit real*8 (a-h,o-z)
7588       include 'DIMENSIONS'
7589       include 'COMMON.VAR'
7590       include 'COMMON.GEO'
7591       thetup=pi-delta
7592       thetlow=delta
7593       if (theti.gt.pipol) then
7594         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7595       else
7596         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7597         ssder=-ssder
7598       endif
7599       return
7600       end
7601 c------------------------------------------------------------------------------
7602       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7603       implicit none
7604       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7605       double precision ksi,ksi2,ksi3,a1,a2,a3
7606       a1=fprim0*delta/(f1-f0)
7607       a2=3.0d0-2.0d0*a1
7608       a3=a1-2.0d0
7609       ksi=(x-x0)/delta
7610       ksi2=ksi*ksi
7611       ksi3=ksi2*ksi
7612       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7613       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7614       return
7615       end
7616 c------------------------------------------------------------------------------
7617       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7618       implicit none
7619       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7620       double precision ksi,ksi2,ksi3,a1,a2,a3
7621       ksi=(x-x0)/delta
7622       ksi2=ksi*ksi
7623       ksi3=ksi2*ksi
7624       a1=fprim0x*delta
7625       a2=3*(f1x-f0x)-2*fprim0x*delta
7626       a3=fprim0x*delta-2*(f1x-f0x)
7627       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7628       return
7629       end
7630 C-----------------------------------------------------------------------------
7631 #ifdef CRYST_TOR
7632 C-----------------------------------------------------------------------------
7633       subroutine etor(etors)
7634       implicit real*8 (a-h,o-z)
7635       include 'DIMENSIONS'
7636       include 'COMMON.VAR'
7637       include 'COMMON.GEO'
7638       include 'COMMON.LOCAL'
7639       include 'COMMON.TORSION'
7640       include 'COMMON.INTERACT'
7641       include 'COMMON.DERIV'
7642       include 'COMMON.CHAIN'
7643       include 'COMMON.NAMES'
7644       include 'COMMON.IOUNITS'
7645       include 'COMMON.FFIELD'
7646       include 'COMMON.TORCNSTR'
7647       include 'COMMON.CONTROL'
7648       logical lprn
7649 C Set lprn=.true. for debugging
7650       lprn=.false.
7651 c      lprn=.true.
7652       etors=0.0D0
7653       do i=iphi_start,iphi_end
7654       etors_ii=0.0D0
7655         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7656      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7657         itori=itortyp(itype(i-2))
7658         itori1=itortyp(itype(i-1))
7659         phii=phi(i)
7660         gloci=0.0D0
7661 C Proline-Proline pair is a special case...
7662         if (itori.eq.3 .and. itori1.eq.3) then
7663           if (phii.gt.-dwapi3) then
7664             cosphi=dcos(3*phii)
7665             fac=1.0D0/(1.0D0-cosphi)
7666             etorsi=v1(1,3,3)*fac
7667             etorsi=etorsi+etorsi
7668             etors=etors+etorsi-v1(1,3,3)
7669             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7670             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7671           endif
7672           do j=1,3
7673             v1ij=v1(j+1,itori,itori1)
7674             v2ij=v2(j+1,itori,itori1)
7675             cosphi=dcos(j*phii)
7676             sinphi=dsin(j*phii)
7677             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7678             if (energy_dec) etors_ii=etors_ii+
7679      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7680             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7681           enddo
7682         else
7683           do j=1,nterm_old
7684             v1ij=v1(j,itori,itori1)
7685             v2ij=v2(j,itori,itori1)
7686             cosphi=dcos(j*phii)
7687             sinphi=dsin(j*phii)
7688             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7689             if (energy_dec) etors_ii=etors_ii+
7690      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7691             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7692           enddo
7693         endif
7694         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7695              'etor',i,etors_ii
7696         if (lprn)
7697      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7698      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7699      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7700         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7701 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7702       enddo
7703       return
7704       end
7705 c------------------------------------------------------------------------------
7706       subroutine etor_d(etors_d)
7707       etors_d=0.0d0
7708       return
7709       end
7710 c----------------------------------------------------------------------------
7711 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7712       subroutine e_modeller(ehomology_constr)
7713       ehomology_constr=0.0d0
7714       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7715       return
7716       end
7717 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7718
7719 c------------------------------------------------------------------------------
7720       subroutine etor_d(etors_d)
7721       etors_d=0.0d0
7722       return
7723       end
7724 c----------------------------------------------------------------------------
7725 #else
7726       subroutine etor(etors)
7727       implicit real*8 (a-h,o-z)
7728       include 'DIMENSIONS'
7729       include 'COMMON.VAR'
7730       include 'COMMON.GEO'
7731       include 'COMMON.LOCAL'
7732       include 'COMMON.TORSION'
7733       include 'COMMON.INTERACT'
7734       include 'COMMON.DERIV'
7735       include 'COMMON.CHAIN'
7736       include 'COMMON.NAMES'
7737       include 'COMMON.IOUNITS'
7738       include 'COMMON.FFIELD'
7739       include 'COMMON.TORCNSTR'
7740       include 'COMMON.CONTROL'
7741       logical lprn
7742 C Set lprn=.true. for debugging
7743       lprn=.false.
7744 c     lprn=.true.
7745       etors=0.0D0
7746       do i=iphi_start,iphi_end
7747 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7748 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7749 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7750 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7751         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7752      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7753 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7754 C For introducing the NH3+ and COO- group please check the etor_d for reference
7755 C and guidance
7756         etors_ii=0.0D0
7757          if (iabs(itype(i)).eq.20) then
7758          iblock=2
7759          else
7760          iblock=1
7761          endif
7762         itori=itortyp(itype(i-2))
7763         itori1=itortyp(itype(i-1))
7764         phii=phi(i)
7765         gloci=0.0D0
7766 C Regular cosine and sine terms
7767         do j=1,nterm(itori,itori1,iblock)
7768           v1ij=v1(j,itori,itori1,iblock)
7769           v2ij=v2(j,itori,itori1,iblock)
7770           cosphi=dcos(j*phii)
7771           sinphi=dsin(j*phii)
7772           etors=etors+v1ij*cosphi+v2ij*sinphi
7773           if (energy_dec) etors_ii=etors_ii+
7774      &                v1ij*cosphi+v2ij*sinphi
7775           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7776         enddo
7777 C Lorentz terms
7778 C                         v1
7779 C  E = SUM ----------------------------------- - v1
7780 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7781 C
7782         cosphi=dcos(0.5d0*phii)
7783         sinphi=dsin(0.5d0*phii)
7784         do j=1,nlor(itori,itori1,iblock)
7785           vl1ij=vlor1(j,itori,itori1)
7786           vl2ij=vlor2(j,itori,itori1)
7787           vl3ij=vlor3(j,itori,itori1)
7788           pom=vl2ij*cosphi+vl3ij*sinphi
7789           pom1=1.0d0/(pom*pom+1.0d0)
7790           etors=etors+vl1ij*pom1
7791           if (energy_dec) etors_ii=etors_ii+
7792      &                vl1ij*pom1
7793           pom=-pom*pom1*pom1
7794           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7795         enddo
7796 C Subtract the constant term
7797         etors=etors-v0(itori,itori1,iblock)
7798           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7799      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7800         if (lprn)
7801      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7802      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7803      &  (v1(j,itori,itori1,iblock),j=1,6),
7804      &  (v2(j,itori,itori1,iblock),j=1,6)
7805         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7806 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7807       enddo
7808       return
7809       end
7810 c----------------------------------------------------------------------------
7811       subroutine etor_d(etors_d)
7812 C 6/23/01 Compute double torsional energy
7813       implicit real*8 (a-h,o-z)
7814       include 'DIMENSIONS'
7815       include 'COMMON.VAR'
7816       include 'COMMON.GEO'
7817       include 'COMMON.LOCAL'
7818       include 'COMMON.TORSION'
7819       include 'COMMON.INTERACT'
7820       include 'COMMON.DERIV'
7821       include 'COMMON.CHAIN'
7822       include 'COMMON.NAMES'
7823       include 'COMMON.IOUNITS'
7824       include 'COMMON.FFIELD'
7825       include 'COMMON.TORCNSTR'
7826       logical lprn
7827 C Set lprn=.true. for debugging
7828       lprn=.false.
7829 c     lprn=.true.
7830       etors_d=0.0D0
7831 c      write(iout,*) "a tu??"
7832       do i=iphid_start,iphid_end
7833 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7834 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7835 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7836 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7837 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7838          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7839      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7840      &  (itype(i+1).eq.ntyp1)) cycle
7841 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7842         itori=itortyp(itype(i-2))
7843         itori1=itortyp(itype(i-1))
7844         itori2=itortyp(itype(i))
7845         phii=phi(i)
7846         phii1=phi(i+1)
7847         gloci1=0.0D0
7848         gloci2=0.0D0
7849         iblock=1
7850         if (iabs(itype(i+1)).eq.20) iblock=2
7851 C Iblock=2 Proline type
7852 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7853 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7854 C        if (itype(i+1).eq.ntyp1) iblock=3
7855 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7856 C IS or IS NOT need for this
7857 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7858 C        is (itype(i-3).eq.ntyp1) ntblock=2
7859 C        ntblock is N-terminal blocking group
7860
7861 C Regular cosine and sine terms
7862         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7863 C Example of changes for NH3+ blocking group
7864 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7865 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7866           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7867           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7868           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7869           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7870           cosphi1=dcos(j*phii)
7871           sinphi1=dsin(j*phii)
7872           cosphi2=dcos(j*phii1)
7873           sinphi2=dsin(j*phii1)
7874           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7875      &     v2cij*cosphi2+v2sij*sinphi2
7876           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7877           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7878         enddo
7879         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7880           do l=1,k-1
7881             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7882             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7883             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7884             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7885             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7886             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7887             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7888             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7889             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7890      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7891             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7892      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7893             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7894      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7895           enddo
7896         enddo
7897         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7898         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7899       enddo
7900       return
7901       end
7902 #endif
7903 C----------------------------------------------------------------------------------
7904 C The rigorous attempt to derive energy function
7905       subroutine etor_kcc(etors)
7906       implicit real*8 (a-h,o-z)
7907       include 'DIMENSIONS'
7908       include 'COMMON.VAR'
7909       include 'COMMON.GEO'
7910       include 'COMMON.LOCAL'
7911       include 'COMMON.TORSION'
7912       include 'COMMON.INTERACT'
7913       include 'COMMON.DERIV'
7914       include 'COMMON.CHAIN'
7915       include 'COMMON.NAMES'
7916       include 'COMMON.IOUNITS'
7917       include 'COMMON.FFIELD'
7918       include 'COMMON.TORCNSTR'
7919       include 'COMMON.CONTROL'
7920       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7921       logical lprn
7922 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7923 C Set lprn=.true. for debugging
7924       lprn=energy_dec
7925 c     lprn=.true.
7926 C      print *,"wchodze kcc"
7927       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7928       etors=0.0D0
7929       do i=iphi_start,iphi_end
7930 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7931 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7932 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7933 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7934         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7935      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7936         itori=itortyp(itype(i-2))
7937         itori1=itortyp(itype(i-1))
7938         phii=phi(i)
7939         glocig=0.0D0
7940         glocit1=0.0d0
7941         glocit2=0.0d0
7942 C to avoid multiple devision by 2
7943 c        theti22=0.5d0*theta(i)
7944 C theta 12 is the theta_1 /2
7945 C theta 22 is theta_2 /2
7946 c        theti12=0.5d0*theta(i-1)
7947 C and appropriate sinus function
7948         sinthet1=dsin(theta(i-1))
7949         sinthet2=dsin(theta(i))
7950         costhet1=dcos(theta(i-1))
7951         costhet2=dcos(theta(i))
7952 C to speed up lets store its mutliplication
7953         sint1t2=sinthet2*sinthet1
7954         sint1t2n=1.0d0
7955 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7956 C +d_n*sin(n*gamma)) *
7957 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7958 C we have two sum 1) Non-Chebyshev which is with n and gamma
7959         nval=nterm_kcc_Tb(itori,itori1)
7960         c1(0)=0.0d0
7961         c2(0)=0.0d0
7962         c1(1)=1.0d0
7963         c2(1)=1.0d0
7964         do j=2,nval
7965           c1(j)=c1(j-1)*costhet1
7966           c2(j)=c2(j-1)*costhet2
7967         enddo
7968         etori=0.0d0
7969         do j=1,nterm_kcc(itori,itori1)
7970           cosphi=dcos(j*phii)
7971           sinphi=dsin(j*phii)
7972           sint1t2n1=sint1t2n
7973           sint1t2n=sint1t2n*sint1t2
7974           sumvalc=0.0d0
7975           gradvalct1=0.0d0
7976           gradvalct2=0.0d0
7977           do k=1,nval
7978             do l=1,nval
7979               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7980               gradvalct1=gradvalct1+
7981      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7982               gradvalct2=gradvalct2+
7983      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7984             enddo
7985           enddo
7986           gradvalct1=-gradvalct1*sinthet1
7987           gradvalct2=-gradvalct2*sinthet2
7988           sumvals=0.0d0
7989           gradvalst1=0.0d0
7990           gradvalst2=0.0d0
7991           do k=1,nval
7992             do l=1,nval
7993               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7994               gradvalst1=gradvalst1+
7995      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7996               gradvalst2=gradvalst2+
7997      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7998             enddo
7999           enddo
8000           gradvalst1=-gradvalst1*sinthet1
8001           gradvalst2=-gradvalst2*sinthet2
8002           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
8003           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
8004 C glocig is the gradient local i site in gamma
8005           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
8006 C now gradient over theta_1
8007           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
8008      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
8009           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
8010      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
8011         enddo ! j
8012         etors=etors+etori
8013 C derivative over gamma
8014         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8015 C derivative over theta1
8016         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8017 C now derivative over theta2
8018         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8019         if (lprn) then
8020           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8021      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8022           write (iout,*) "c1",(c1(k),k=0,nval),
8023      &    " c2",(c2(k),k=0,nval)
8024         endif
8025       enddo
8026       return
8027       end
8028 c---------------------------------------------------------------------------------------------
8029       subroutine etor_constr(edihcnstr)
8030       implicit real*8 (a-h,o-z)
8031       include 'DIMENSIONS'
8032       include 'COMMON.VAR'
8033       include 'COMMON.GEO'
8034       include 'COMMON.LOCAL'
8035       include 'COMMON.TORSION'
8036       include 'COMMON.INTERACT'
8037       include 'COMMON.DERIV'
8038       include 'COMMON.CHAIN'
8039       include 'COMMON.NAMES'
8040       include 'COMMON.IOUNITS'
8041       include 'COMMON.FFIELD'
8042       include 'COMMON.TORCNSTR'
8043       include 'COMMON.BOUNDS'
8044       include 'COMMON.CONTROL'
8045 ! 6/20/98 - dihedral angle constraints
8046       edihcnstr=0.0d0
8047 c      do i=1,ndih_constr
8048       if (raw_psipred) then
8049         do i=idihconstr_start,idihconstr_end
8050           itori=idih_constr(i)
8051           phii=phi(itori)
8052           gaudih_i=vpsipred(1,i)
8053           gauder_i=0.0d0
8054           do j=1,2
8055             s = sdihed(j,i)
8056             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
8057             dexpcos_i=dexp(-cos_i*cos_i)
8058             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
8059             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
8060      &            *cos_i*dexpcos_i/s**2
8061           enddo
8062           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
8063           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
8064           if (energy_dec)
8065      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
8066      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
8067      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
8068      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
8069      &     -wdihc*dlog(gaudih_i)
8070         enddo
8071       else
8072
8073       do i=idihconstr_start,idihconstr_end
8074         itori=idih_constr(i)
8075         phii=phi(itori)
8076         difi=pinorm(phii-phi0(i))
8077         if (difi.gt.drange(i)) then
8078           difi=difi-drange(i)
8079           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8080           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8081         else if (difi.lt.-drange(i)) then
8082           difi=difi+drange(i)
8083           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8084           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8085         else
8086           difi=0.0
8087         endif
8088       enddo
8089
8090       endif
8091
8092       return
8093       end
8094 c----------------------------------------------------------------------------
8095 c MODELLER restraint function
8096       subroutine e_modeller(ehomology_constr)
8097       implicit none
8098       include 'DIMENSIONS'
8099
8100       double precision ehomology_constr
8101       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8102       integer katy, odleglosci, test7
8103       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8104       real*8 Eval,Erot
8105       real*8 distance(max_template),distancek(max_template),
8106      &    min_odl,godl(max_template),dih_diff(max_template)
8107
8108 c
8109 c     FP - 30/10/2014 Temporary specifications for homology restraints
8110 c
8111       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8112      &                 sgtheta
8113       double precision, dimension (maxres) :: guscdiff,usc_diff
8114       double precision, dimension (max_template) ::
8115      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8116      &           theta_diff
8117       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8118      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8119      & betai,sum_sgodl,dij
8120       double precision dist,pinorm
8121 c
8122       include 'COMMON.SBRIDGE'
8123       include 'COMMON.CHAIN'
8124       include 'COMMON.GEO'
8125       include 'COMMON.DERIV'
8126       include 'COMMON.LOCAL'
8127       include 'COMMON.INTERACT'
8128       include 'COMMON.VAR'
8129       include 'COMMON.IOUNITS'
8130 c      include 'COMMON.MD'
8131       include 'COMMON.CONTROL'
8132       include 'COMMON.HOMOLOGY'
8133       include 'COMMON.QRESTR'
8134 c
8135 c     From subroutine Econstr_back
8136 c
8137       include 'COMMON.NAMES'
8138       include 'COMMON.TIME1'
8139 c
8140
8141
8142       do i=1,max_template
8143         distancek(i)=9999999.9
8144       enddo
8145
8146
8147       odleg=0.0d0
8148
8149 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8150 c function)
8151 C AL 5/2/14 - Introduce list of restraints
8152 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8153 #ifdef DEBUG
8154       write(iout,*) "------- dist restrs start -------"
8155 #endif
8156       do ii = link_start_homo,link_end_homo
8157          i = ires_homo(ii)
8158          j = jres_homo(ii)
8159          dij=dist(i,j)
8160 c        write (iout,*) "dij(",i,j,") =",dij
8161          nexl=0
8162          do k=1,constr_homology
8163 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8164            if(.not.l_homo(k,ii)) then
8165              nexl=nexl+1
8166              cycle
8167            endif
8168            distance(k)=odl(k,ii)-dij
8169 c          write (iout,*) "distance(",k,") =",distance(k)
8170 c
8171 c          For Gaussian-type Urestr
8172 c
8173            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8174 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8175 c          write (iout,*) "distancek(",k,") =",distancek(k)
8176 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8177 c
8178 c          For Lorentzian-type Urestr
8179 c
8180            if (waga_dist.lt.0.0d0) then
8181               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8182               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8183      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8184            endif
8185          enddo
8186
8187 c         min_odl=minval(distancek)
8188          do kk=1,constr_homology
8189           if(l_homo(kk,ii)) then
8190             min_odl=distancek(kk)
8191             exit
8192           endif
8193          enddo
8194          do kk=1,constr_homology
8195           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8196      &              min_odl=distancek(kk)
8197          enddo
8198
8199 c        write (iout,* )"min_odl",min_odl
8200 #ifdef DEBUG
8201          write (iout,*) "ij dij",i,j,dij
8202          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8203          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8204          write (iout,* )"min_odl",min_odl
8205 #endif
8206 #ifdef OLDRESTR
8207          odleg2=0.0d0
8208 #else
8209          if (waga_dist.ge.0.0d0) then
8210            odleg2=nexl
8211          else
8212            odleg2=0.0d0
8213          endif
8214 #endif
8215          do k=1,constr_homology
8216 c Nie wiem po co to liczycie jeszcze raz!
8217 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8218 c     &              (2*(sigma_odl(i,j,k))**2))
8219            if(.not.l_homo(k,ii)) cycle
8220            if (waga_dist.ge.0.0d0) then
8221 c
8222 c          For Gaussian-type Urestr
8223 c
8224             godl(k)=dexp(-distancek(k)+min_odl)
8225             odleg2=odleg2+godl(k)
8226 c
8227 c          For Lorentzian-type Urestr
8228 c
8229            else
8230             odleg2=odleg2+distancek(k)
8231            endif
8232
8233 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8234 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8235 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8236 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8237
8238          enddo
8239 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8240 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8241 #ifdef DEBUG
8242          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8243          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8244 #endif
8245            if (waga_dist.ge.0.0d0) then
8246 c
8247 c          For Gaussian-type Urestr
8248 c
8249               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8250 c
8251 c          For Lorentzian-type Urestr
8252 c
8253            else
8254               odleg=odleg+odleg2/constr_homology
8255            endif
8256 c
8257 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8258 c Gradient
8259 c
8260 c          For Gaussian-type Urestr
8261 c
8262          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8263          sum_sgodl=0.0d0
8264          do k=1,constr_homology
8265 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8266 c     &           *waga_dist)+min_odl
8267 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8268 c
8269          if(.not.l_homo(k,ii)) cycle
8270          if (waga_dist.ge.0.0d0) then
8271 c          For Gaussian-type Urestr
8272 c
8273            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8274 c
8275 c          For Lorentzian-type Urestr
8276 c
8277          else
8278            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8279      &           sigma_odlir(k,ii)**2)**2)
8280          endif
8281            sum_sgodl=sum_sgodl+sgodl
8282
8283 c            sgodl2=sgodl2+sgodl
8284 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8285 c      write(iout,*) "constr_homology=",constr_homology
8286 c      write(iout,*) i, j, k, "TEST K"
8287          enddo
8288          if (waga_dist.ge.0.0d0) then
8289 c
8290 c          For Gaussian-type Urestr
8291 c
8292             grad_odl3=waga_homology(iset)*waga_dist
8293      &                *sum_sgodl/(sum_godl*dij)
8294 c
8295 c          For Lorentzian-type Urestr
8296 c
8297          else
8298 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8299 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8300             grad_odl3=-waga_homology(iset)*waga_dist*
8301      &                sum_sgodl/(constr_homology*dij)
8302          endif
8303 c
8304 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8305
8306
8307 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8308 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8309 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8310
8311 ccc      write(iout,*) godl, sgodl, grad_odl3
8312
8313 c          grad_odl=grad_odl+grad_odl3
8314
8315          do jik=1,3
8316             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8317 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8318 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8319 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8320             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8321             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8322 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8323 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8324 c         if (i.eq.25.and.j.eq.27) then
8325 c         write(iout,*) "jik",jik,"i",i,"j",j
8326 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8327 c         write(iout,*) "grad_odl3",grad_odl3
8328 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8329 c         write(iout,*) "ggodl",ggodl
8330 c         write(iout,*) "ghpbc(",jik,i,")",
8331 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8332 c     &                 ghpbc(jik,j)
8333 c         endif
8334          enddo
8335 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8336 ccc     & dLOG(odleg2),"-odleg=", -odleg
8337
8338       enddo ! ii-loop for dist
8339 #ifdef DEBUG
8340       write(iout,*) "------- dist restrs end -------"
8341 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8342 c    &     waga_d.eq.1.0d0) call sum_gradient
8343 #endif
8344 c Pseudo-energy and gradient from dihedral-angle restraints from
8345 c homology templates
8346 c      write (iout,*) "End of distance loop"
8347 c      call flush(iout)
8348       kat=0.0d0
8349 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8350 #ifdef DEBUG
8351       write(iout,*) "------- dih restrs start -------"
8352       do i=idihconstr_start_homo,idihconstr_end_homo
8353         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8354       enddo
8355 #endif
8356       do i=idihconstr_start_homo,idihconstr_end_homo
8357         kat2=0.0d0
8358 c        betai=beta(i,i+1,i+2,i+3)
8359         betai = phi(i)
8360 c       write (iout,*) "betai =",betai
8361         do k=1,constr_homology
8362           dih_diff(k)=pinorm(dih(k,i)-betai)
8363 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8364 cd     &                  ,sigma_dih(k,i)
8365 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8366 c     &                                   -(6.28318-dih_diff(i,k))
8367 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8368 c     &                                   6.28318+dih_diff(i,k)
8369 #ifdef OLD_DIHED
8370           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8371 #else
8372           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8373 #endif
8374 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8375           gdih(k)=dexp(kat3)
8376           kat2=kat2+gdih(k)
8377 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8378 c          write(*,*)""
8379         enddo
8380 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8381 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8382 #ifdef DEBUG
8383         write (iout,*) "i",i," betai",betai," kat2",kat2
8384         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8385 #endif
8386         if (kat2.le.1.0d-14) cycle
8387         kat=kat-dLOG(kat2/constr_homology)
8388 c       write (iout,*) "kat",kat ! sum of -ln-s
8389
8390 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8391 ccc     & dLOG(kat2), "-kat=", -kat
8392
8393 c ----------------------------------------------------------------------
8394 c Gradient
8395 c ----------------------------------------------------------------------
8396
8397         sum_gdih=kat2
8398         sum_sgdih=0.0d0
8399         do k=1,constr_homology
8400 #ifdef OLD_DIHED
8401           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8402 #else
8403           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8404 #endif
8405 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8406           sum_sgdih=sum_sgdih+sgdih
8407         enddo
8408 c       grad_dih3=sum_sgdih/sum_gdih
8409         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8410
8411 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8412 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8413 ccc     & gloc(nphi+i-3,icg)
8414         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8415 c        if (i.eq.25) then
8416 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8417 c        endif
8418 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8419 ccc     & gloc(nphi+i-3,icg)
8420
8421       enddo ! i-loop for dih
8422 #ifdef DEBUG
8423       write(iout,*) "------- dih restrs end -------"
8424 #endif
8425
8426 c Pseudo-energy and gradient for theta angle restraints from
8427 c homology templates
8428 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8429 c adapted
8430
8431 c
8432 c     For constr_homology reference structures (FP)
8433 c
8434 c     Uconst_back_tot=0.0d0
8435       Eval=0.0d0
8436       Erot=0.0d0
8437 c     Econstr_back legacy
8438       do i=1,nres
8439 c     do i=ithet_start,ithet_end
8440        dutheta(i)=0.0d0
8441 c     enddo
8442 c     do i=loc_start,loc_end
8443         do j=1,3
8444           duscdiff(j,i)=0.0d0
8445           duscdiffx(j,i)=0.0d0
8446         enddo
8447       enddo
8448 c
8449 c     do iref=1,nref
8450 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8451 c     write (iout,*) "waga_theta",waga_theta
8452       if (waga_theta.gt.0.0d0) then
8453 #ifdef DEBUG
8454       write (iout,*) "usampl",usampl
8455       write(iout,*) "------- theta restrs start -------"
8456 c     do i=ithet_start,ithet_end
8457 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8458 c     enddo
8459 #endif
8460 c     write (iout,*) "maxres",maxres,"nres",nres
8461
8462       do i=ithet_start,ithet_end
8463 c
8464 c     do i=1,nfrag_back
8465 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8466 c
8467 c Deviation of theta angles wrt constr_homology ref structures
8468 c
8469         utheta_i=0.0d0 ! argument of Gaussian for single k
8470         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8471 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8472 c       over residues in a fragment
8473 c       write (iout,*) "theta(",i,")=",theta(i)
8474         do k=1,constr_homology
8475 c
8476 c         dtheta_i=theta(j)-thetaref(j,iref)
8477 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8478           theta_diff(k)=thetatpl(k,i)-theta(i)
8479 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8480 cd     &                  ,sigma_theta(k,i)
8481
8482 c
8483           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8484 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8485           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8486           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8487 c         Gradient for single Gaussian restraint in subr Econstr_back
8488 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8489 c
8490         enddo
8491 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8492 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8493
8494 c
8495 c         Gradient for multiple Gaussian restraint
8496         sum_gtheta=gutheta_i
8497         sum_sgtheta=0.0d0
8498         do k=1,constr_homology
8499 c        New generalized expr for multiple Gaussian from Econstr_back
8500          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8501 c
8502 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8503           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8504         enddo
8505 c       Final value of gradient using same var as in Econstr_back
8506         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8507      &      +sum_sgtheta/sum_gtheta*waga_theta
8508      &               *waga_homology(iset)
8509 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8510 c     &               *waga_homology(iset)
8511 c       dutheta(i)=sum_sgtheta/sum_gtheta
8512 c
8513 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8514         Eval=Eval-dLOG(gutheta_i/constr_homology)
8515 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8516 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8517 c       Uconst_back=Uconst_back+utheta(i)
8518       enddo ! (i-loop for theta)
8519 #ifdef DEBUG
8520       write(iout,*) "------- theta restrs end -------"
8521 #endif
8522       endif
8523 c
8524 c Deviation of local SC geometry
8525 c
8526 c Separation of two i-loops (instructed by AL - 11/3/2014)
8527 c
8528 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8529 c     write (iout,*) "waga_d",waga_d
8530
8531 #ifdef DEBUG
8532       write(iout,*) "------- SC restrs start -------"
8533       write (iout,*) "Initial duscdiff,duscdiffx"
8534       do i=loc_start,loc_end
8535         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8536      &                 (duscdiffx(jik,i),jik=1,3)
8537       enddo
8538 #endif
8539       do i=loc_start,loc_end
8540         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8541         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8542 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8543 c       write(iout,*) "xxtab, yytab, zztab"
8544 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8545         do k=1,constr_homology
8546 c
8547           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8548 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8549           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8550           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8551 c         write(iout,*) "dxx, dyy, dzz"
8552 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8553 c
8554           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8555 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8556 c         uscdiffk(k)=usc_diff(i)
8557           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8558 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8559 c     &       " guscdiff2",guscdiff2(k)
8560           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8561 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8562 c     &      xxref(j),yyref(j),zzref(j)
8563         enddo
8564 c
8565 c       Gradient
8566 c
8567 c       Generalized expression for multiple Gaussian acc to that for a single
8568 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8569 c
8570 c       Original implementation
8571 c       sum_guscdiff=guscdiff(i)
8572 c
8573 c       sum_sguscdiff=0.0d0
8574 c       do k=1,constr_homology
8575 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8576 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8577 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8578 c       enddo
8579 c
8580 c       Implementation of new expressions for gradient (Jan. 2015)
8581 c
8582 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8583         do k=1,constr_homology
8584 c
8585 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8586 c       before. Now the drivatives should be correct
8587 c
8588           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8589 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8590           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8591           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8592 c
8593 c         New implementation
8594 c
8595           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8596      &                 sigma_d(k,i) ! for the grad wrt r'
8597 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8598 c
8599 c
8600 c        New implementation
8601          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8602          do jik=1,3
8603             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8604      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8605      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8606             duscdiff(jik,i)=duscdiff(jik,i)+
8607      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8608      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8609             duscdiffx(jik,i)=duscdiffx(jik,i)+
8610      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8611      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8612 c
8613 #ifdef DEBUG
8614              write(iout,*) "jik",jik,"i",i
8615              write(iout,*) "dxx, dyy, dzz"
8616              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8617              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8618 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8619 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8620 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8621 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8622 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8623 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8624 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8625 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8626 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8627 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8628 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8629 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8630 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8631 c            endif
8632 #endif
8633          enddo
8634         enddo
8635 c
8636 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8637 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8638 c
8639 c        write (iout,*) i," uscdiff",uscdiff(i)
8640 c
8641 c Put together deviations from local geometry
8642
8643 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8644 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8645         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8646 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8647 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8648 c       Uconst_back=Uconst_back+usc_diff(i)
8649 c
8650 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8651 c
8652 c     New implment: multiplied by sum_sguscdiff
8653 c
8654
8655       enddo ! (i-loop for dscdiff)
8656
8657 c      endif
8658
8659 #ifdef DEBUG
8660       write(iout,*) "------- SC restrs end -------"
8661         write (iout,*) "------ After SC loop in e_modeller ------"
8662         do i=loc_start,loc_end
8663          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8664          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8665         enddo
8666       if (waga_theta.eq.1.0d0) then
8667       write (iout,*) "in e_modeller after SC restr end: dutheta"
8668       do i=ithet_start,ithet_end
8669         write (iout,*) i,dutheta(i)
8670       enddo
8671       endif
8672       if (waga_d.eq.1.0d0) then
8673       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8674       do i=1,nres
8675         write (iout,*) i,(duscdiff(j,i),j=1,3)
8676         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8677       enddo
8678       endif
8679 #endif
8680
8681 c Total energy from homology restraints
8682 #ifdef DEBUG
8683       write (iout,*) "odleg",odleg," kat",kat
8684 #endif
8685 c
8686 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8687 c
8688 c     ehomology_constr=odleg+kat
8689 c
8690 c     For Lorentzian-type Urestr
8691 c
8692
8693       if (waga_dist.ge.0.0d0) then
8694 c
8695 c          For Gaussian-type Urestr
8696 c
8697         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8698      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8699 c     write (iout,*) "ehomology_constr=",ehomology_constr
8700       else
8701 c
8702 c          For Lorentzian-type Urestr
8703 c
8704         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8705      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8706 c     write (iout,*) "ehomology_constr=",ehomology_constr
8707       endif
8708 #ifdef DEBUG
8709       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8710      & "Eval",waga_theta,eval,
8711      &   "Erot",waga_d,Erot
8712       write (iout,*) "ehomology_constr",ehomology_constr
8713 #endif
8714       return
8715 c
8716 c FP 01/15 end
8717 c
8718   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8719   747 format(a12,i4,i4,i4,f8.3,f8.3)
8720   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8721   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8722   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8723      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8724       end
8725 c----------------------------------------------------------------------------
8726 C The rigorous attempt to derive energy function
8727       subroutine ebend_kcc(etheta)
8728
8729       implicit real*8 (a-h,o-z)
8730       include 'DIMENSIONS'
8731       include 'COMMON.VAR'
8732       include 'COMMON.GEO'
8733       include 'COMMON.LOCAL'
8734       include 'COMMON.TORSION'
8735       include 'COMMON.INTERACT'
8736       include 'COMMON.DERIV'
8737       include 'COMMON.CHAIN'
8738       include 'COMMON.NAMES'
8739       include 'COMMON.IOUNITS'
8740       include 'COMMON.FFIELD'
8741       include 'COMMON.TORCNSTR'
8742       include 'COMMON.CONTROL'
8743       logical lprn
8744       double precision thybt1(maxang_kcc)
8745 C Set lprn=.true. for debugging
8746       lprn=energy_dec
8747 c     lprn=.true.
8748 C      print *,"wchodze kcc"
8749       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8750       etheta=0.0D0
8751       do i=ithet_start,ithet_end
8752 c        print *,i,itype(i-1),itype(i),itype(i-2)
8753         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8754      &  .or.itype(i).eq.ntyp1) cycle
8755         iti=iabs(itortyp(itype(i-1)))
8756         sinthet=dsin(theta(i))
8757         costhet=dcos(theta(i))
8758         do j=1,nbend_kcc_Tb(iti)
8759           thybt1(j)=v1bend_chyb(j,iti)
8760         enddo
8761         sumth1thyb=v1bend_chyb(0,iti)+
8762      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8763         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8764      &    sumth1thyb
8765         ihelp=nbend_kcc_Tb(iti)-1
8766         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8767         etheta=etheta+sumth1thyb
8768 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8769         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8770       enddo
8771       return
8772       end
8773 c-------------------------------------------------------------------------------------
8774       subroutine etheta_constr(ethetacnstr)
8775
8776       implicit real*8 (a-h,o-z)
8777       include 'DIMENSIONS'
8778       include 'COMMON.VAR'
8779       include 'COMMON.GEO'
8780       include 'COMMON.LOCAL'
8781       include 'COMMON.TORSION'
8782       include 'COMMON.INTERACT'
8783       include 'COMMON.DERIV'
8784       include 'COMMON.CHAIN'
8785       include 'COMMON.NAMES'
8786       include 'COMMON.IOUNITS'
8787       include 'COMMON.FFIELD'
8788       include 'COMMON.TORCNSTR'
8789       include 'COMMON.CONTROL'
8790       ethetacnstr=0.0d0
8791 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8792       do i=ithetaconstr_start,ithetaconstr_end
8793         itheta=itheta_constr(i)
8794         thetiii=theta(itheta)
8795         difi=pinorm(thetiii-theta_constr0(i))
8796         if (difi.gt.theta_drange(i)) then
8797           difi=difi-theta_drange(i)
8798           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8799           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8800      &    +for_thet_constr(i)*difi**3
8801         else if (difi.lt.-drange(i)) then
8802           difi=difi+drange(i)
8803           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8804           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8805      &    +for_thet_constr(i)*difi**3
8806         else
8807           difi=0.0
8808         endif
8809        if (energy_dec) then
8810         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8811      &    i,itheta,rad2deg*thetiii,
8812      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8813      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8814      &    gloc(itheta+nphi-2,icg)
8815         endif
8816       enddo
8817       return
8818       end
8819 c------------------------------------------------------------------------------
8820       subroutine eback_sc_corr(esccor)
8821 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8822 c        conformational states; temporarily implemented as differences
8823 c        between UNRES torsional potentials (dependent on three types of
8824 c        residues) and the torsional potentials dependent on all 20 types
8825 c        of residues computed from AM1  energy surfaces of terminally-blocked
8826 c        amino-acid residues.
8827       implicit real*8 (a-h,o-z)
8828       include 'DIMENSIONS'
8829       include 'COMMON.VAR'
8830       include 'COMMON.GEO'
8831       include 'COMMON.LOCAL'
8832       include 'COMMON.TORSION'
8833       include 'COMMON.SCCOR'
8834       include 'COMMON.INTERACT'
8835       include 'COMMON.DERIV'
8836       include 'COMMON.CHAIN'
8837       include 'COMMON.NAMES'
8838       include 'COMMON.IOUNITS'
8839       include 'COMMON.FFIELD'
8840       include 'COMMON.CONTROL'
8841       logical lprn
8842 C Set lprn=.true. for debugging
8843       lprn=.false.
8844 c      lprn=.true.
8845 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8846       esccor=0.0D0
8847       do i=itau_start,itau_end
8848         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8849         esccor_ii=0.0D0
8850         isccori=isccortyp(itype(i-2))
8851         isccori1=isccortyp(itype(i-1))
8852 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8853         phii=phi(i)
8854         do intertyp=1,3 !intertyp
8855 cc Added 09 May 2012 (Adasko)
8856 cc  Intertyp means interaction type of backbone mainchain correlation:
8857 c   1 = SC...Ca...Ca...Ca
8858 c   2 = Ca...Ca...Ca...SC
8859 c   3 = SC...Ca...Ca...SCi
8860         gloci=0.0D0
8861         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8862      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8863      &      (itype(i-1).eq.ntyp1)))
8864      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8865      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8866      &     .or.(itype(i).eq.ntyp1)))
8867      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8868      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8869      &      (itype(i-3).eq.ntyp1)))) cycle
8870         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8871         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8872      & cycle
8873        do j=1,nterm_sccor(isccori,isccori1)
8874           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8875           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8876           cosphi=dcos(j*tauangle(intertyp,i))
8877           sinphi=dsin(j*tauangle(intertyp,i))
8878           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8879           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8880         enddo
8881 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8882         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8883         if (lprn)
8884      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8885      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8886      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8887      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8888         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8889        enddo !intertyp
8890       enddo
8891
8892       return
8893       end
8894 #ifdef FOURBODY
8895 c----------------------------------------------------------------------------
8896       subroutine multibody(ecorr)
8897 C This subroutine calculates multi-body contributions to energy following
8898 C the idea of Skolnick et al. If side chains I and J make a contact and
8899 C at the same time side chains I+1 and J+1 make a contact, an extra
8900 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8901       implicit real*8 (a-h,o-z)
8902       include 'DIMENSIONS'
8903       include 'COMMON.IOUNITS'
8904       include 'COMMON.DERIV'
8905       include 'COMMON.INTERACT'
8906       include 'COMMON.CONTACTS'
8907       include 'COMMON.CONTMAT'
8908       include 'COMMON.CORRMAT'
8909       double precision gx(3),gx1(3)
8910       logical lprn
8911
8912 C Set lprn=.true. for debugging
8913       lprn=.false.
8914
8915       if (lprn) then
8916         write (iout,'(a)') 'Contact function values:'
8917         do i=nnt,nct-2
8918           write (iout,'(i2,20(1x,i2,f10.5))')
8919      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8920         enddo
8921       endif
8922       ecorr=0.0D0
8923       do i=nnt,nct
8924         do j=1,3
8925           gradcorr(j,i)=0.0D0
8926           gradxorr(j,i)=0.0D0
8927         enddo
8928       enddo
8929       do i=nnt,nct-2
8930
8931         DO ISHIFT = 3,4
8932
8933         i1=i+ishift
8934         num_conti=num_cont(i)
8935         num_conti1=num_cont(i1)
8936         do jj=1,num_conti
8937           j=jcont(jj,i)
8938           do kk=1,num_conti1
8939             j1=jcont(kk,i1)
8940             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8941 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8942 cd   &                   ' ishift=',ishift
8943 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8944 C The system gains extra energy.
8945               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8946             endif   ! j1==j+-ishift
8947           enddo     ! kk
8948         enddo       ! jj
8949
8950         ENDDO ! ISHIFT
8951
8952       enddo         ! i
8953       return
8954       end
8955 c------------------------------------------------------------------------------
8956       double precision function esccorr(i,j,k,l,jj,kk)
8957       implicit real*8 (a-h,o-z)
8958       include 'DIMENSIONS'
8959       include 'COMMON.IOUNITS'
8960       include 'COMMON.DERIV'
8961       include 'COMMON.INTERACT'
8962       include 'COMMON.CONTACTS'
8963       include 'COMMON.CONTMAT'
8964       include 'COMMON.CORRMAT'
8965       include 'COMMON.SHIELD'
8966       double precision gx(3),gx1(3)
8967       logical lprn
8968       lprn=.false.
8969       eij=facont(jj,i)
8970       ekl=facont(kk,k)
8971 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8972 C Calculate the multi-body contribution to energy.
8973 C Calculate multi-body contributions to the gradient.
8974 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8975 cd   & k,l,(gacont(m,kk,k),m=1,3)
8976       do m=1,3
8977         gx(m) =ekl*gacont(m,jj,i)
8978         gx1(m)=eij*gacont(m,kk,k)
8979         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8980         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8981         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8982         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8983       enddo
8984       do m=i,j-1
8985         do ll=1,3
8986           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8987         enddo
8988       enddo
8989       do m=k,l-1
8990         do ll=1,3
8991           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8992         enddo
8993       enddo
8994       esccorr=-eij*ekl
8995       return
8996       end
8997 c------------------------------------------------------------------------------
8998       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8999 C This subroutine calculates multi-body contributions to hydrogen-bonding
9000       implicit real*8 (a-h,o-z)
9001       include 'DIMENSIONS'
9002       include 'COMMON.IOUNITS'
9003 #ifdef MPI
9004       include "mpif.h"
9005       parameter (max_cont=maxconts)
9006       parameter (max_dim=26)
9007       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9008       double precision zapas(max_dim,maxconts,max_fg_procs),
9009      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9010       common /przechowalnia/ zapas
9011       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9012      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9013 #endif
9014       include 'COMMON.SETUP'
9015       include 'COMMON.FFIELD'
9016       include 'COMMON.DERIV'
9017       include 'COMMON.INTERACT'
9018       include 'COMMON.CONTACTS'
9019       include 'COMMON.CONTMAT'
9020       include 'COMMON.CORRMAT'
9021       include 'COMMON.CONTROL'
9022       include 'COMMON.LOCAL'
9023       double precision gx(3),gx1(3),time00
9024       logical lprn,ldone
9025
9026 C Set lprn=.true. for debugging
9027       lprn=.false.
9028 #ifdef MPI
9029       n_corr=0
9030       n_corr1=0
9031       if (nfgtasks.le.1) goto 30
9032       if (lprn) then
9033         write (iout,'(a)') 'Contact function values before RECEIVE:'
9034         do i=nnt,nct-2
9035           write (iout,'(2i3,50(1x,i2,f5.2))')
9036      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9037      &    j=1,num_cont_hb(i))
9038         enddo
9039         call flush(iout)
9040       endif
9041       do i=1,ntask_cont_from
9042         ncont_recv(i)=0
9043       enddo
9044       do i=1,ntask_cont_to
9045         ncont_sent(i)=0
9046       enddo
9047 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9048 c     & ntask_cont_to
9049 C Make the list of contacts to send to send to other procesors
9050 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
9051 c      call flush(iout)
9052       do i=iturn3_start,iturn3_end
9053 c        write (iout,*) "make contact list turn3",i," num_cont",
9054 c     &    num_cont_hb(i)
9055         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
9056       enddo
9057       do i=iturn4_start,iturn4_end
9058 c        write (iout,*) "make contact list turn4",i," num_cont",
9059 c     &   num_cont_hb(i)
9060         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
9061       enddo
9062       do ii=1,nat_sent
9063         i=iat_sent(ii)
9064 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9065 c     &    num_cont_hb(i)
9066         do j=1,num_cont_hb(i)
9067         do k=1,4
9068           jjc=jcont_hb(j,i)
9069           iproc=iint_sent_local(k,jjc,ii)
9070 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9071           if (iproc.gt.0) then
9072             ncont_sent(iproc)=ncont_sent(iproc)+1
9073             nn=ncont_sent(iproc)
9074             zapas(1,nn,iproc)=i
9075             zapas(2,nn,iproc)=jjc
9076             zapas(3,nn,iproc)=facont_hb(j,i)
9077             zapas(4,nn,iproc)=ees0p(j,i)
9078             zapas(5,nn,iproc)=ees0m(j,i)
9079             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
9080             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
9081             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
9082             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
9083             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
9084             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
9085             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
9086             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
9087             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
9088             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
9089             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
9090             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
9091             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
9092             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
9093             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
9094             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
9095             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
9096             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
9097             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
9098             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
9099             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
9100           endif
9101         enddo
9102         enddo
9103       enddo
9104       if (lprn) then
9105       write (iout,*)
9106      &  "Numbers of contacts to be sent to other processors",
9107      &  (ncont_sent(i),i=1,ntask_cont_to)
9108       write (iout,*) "Contacts sent"
9109       do ii=1,ntask_cont_to
9110         nn=ncont_sent(ii)
9111         iproc=itask_cont_to(ii)
9112         write (iout,*) nn," contacts to processor",iproc,
9113      &   " of CONT_TO_COMM group"
9114         do i=1,nn
9115           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9116         enddo
9117       enddo
9118       call flush(iout)
9119       endif
9120       CorrelType=477
9121       CorrelID=fg_rank+1
9122       CorrelType1=478
9123       CorrelID1=nfgtasks+fg_rank+1
9124       ireq=0
9125 C Receive the numbers of needed contacts from other processors
9126       do ii=1,ntask_cont_from
9127         iproc=itask_cont_from(ii)
9128         ireq=ireq+1
9129         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9130      &    FG_COMM,req(ireq),IERR)
9131       enddo
9132 c      write (iout,*) "IRECV ended"
9133 c      call flush(iout)
9134 C Send the number of contacts needed by other processors
9135       do ii=1,ntask_cont_to
9136         iproc=itask_cont_to(ii)
9137         ireq=ireq+1
9138         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9139      &    FG_COMM,req(ireq),IERR)
9140       enddo
9141 c      write (iout,*) "ISEND ended"
9142 c      write (iout,*) "number of requests (nn)",ireq
9143 c      call flush(iout)
9144       if (ireq.gt.0)
9145      &  call MPI_Waitall(ireq,req,status_array,ierr)
9146 c      write (iout,*)
9147 c     &  "Numbers of contacts to be received from other processors",
9148 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9149 c      call flush(iout)
9150 C Receive contacts
9151       ireq=0
9152       do ii=1,ntask_cont_from
9153         iproc=itask_cont_from(ii)
9154         nn=ncont_recv(ii)
9155 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9156 c     &   " of CONT_TO_COMM group"
9157 c        call flush(iout)
9158         if (nn.gt.0) then
9159           ireq=ireq+1
9160           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9161      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9162 c          write (iout,*) "ireq,req",ireq,req(ireq)
9163         endif
9164       enddo
9165 C Send the contacts to processors that need them
9166       do ii=1,ntask_cont_to
9167         iproc=itask_cont_to(ii)
9168         nn=ncont_sent(ii)
9169 c        write (iout,*) nn," contacts to processor",iproc,
9170 c     &   " of CONT_TO_COMM group"
9171         if (nn.gt.0) then
9172           ireq=ireq+1
9173           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9174      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9175 c          write (iout,*) "ireq,req",ireq,req(ireq)
9176 c          do i=1,nn
9177 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9178 c          enddo
9179         endif
9180       enddo
9181 c      write (iout,*) "number of requests (contacts)",ireq
9182 c      write (iout,*) "req",(req(i),i=1,4)
9183 c      call flush(iout)
9184       if (ireq.gt.0)
9185      & call MPI_Waitall(ireq,req,status_array,ierr)
9186       do iii=1,ntask_cont_from
9187         iproc=itask_cont_from(iii)
9188         nn=ncont_recv(iii)
9189         if (lprn) then
9190         write (iout,*) "Received",nn," contacts from processor",iproc,
9191      &   " of CONT_FROM_COMM group"
9192         call flush(iout)
9193         do i=1,nn
9194           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9195         enddo
9196         call flush(iout)
9197         endif
9198         do i=1,nn
9199           ii=zapas_recv(1,i,iii)
9200 c Flag the received contacts to prevent double-counting
9201           jj=-zapas_recv(2,i,iii)
9202 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9203 c          call flush(iout)
9204           nnn=num_cont_hb(ii)+1
9205           num_cont_hb(ii)=nnn
9206           jcont_hb(nnn,ii)=jj
9207           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9208           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9209           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9210           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9211           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9212           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9213           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9214           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9215           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9216           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9217           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9218           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9219           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9220           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9221           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9222           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9223           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9224           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9225           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9226           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9227           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9228           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9229           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9230           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9231         enddo
9232       enddo
9233       if (lprn) then
9234         write (iout,'(a)') 'Contact function values after receive:'
9235         do i=nnt,nct-2
9236           write (iout,'(2i3,50(1x,i3,f5.2))')
9237      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9238      &    j=1,num_cont_hb(i))
9239         enddo
9240         call flush(iout)
9241       endif
9242    30 continue
9243 #endif
9244       if (lprn) then
9245         write (iout,'(a)') 'Contact function values:'
9246         do i=nnt,nct-2
9247           write (iout,'(2i3,50(1x,i3,f5.2))')
9248      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9249      &    j=1,num_cont_hb(i))
9250         enddo
9251         call flush(iout)
9252       endif
9253       ecorr=0.0D0
9254 C Remove the loop below after debugging !!!
9255       do i=nnt,nct
9256         do j=1,3
9257           gradcorr(j,i)=0.0D0
9258           gradxorr(j,i)=0.0D0
9259         enddo
9260       enddo
9261 C Calculate the local-electrostatic correlation terms
9262       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9263         i1=i+1
9264         num_conti=num_cont_hb(i)
9265         num_conti1=num_cont_hb(i+1)
9266         do jj=1,num_conti
9267           j=jcont_hb(jj,i)
9268           jp=iabs(j)
9269           do kk=1,num_conti1
9270             j1=jcont_hb(kk,i1)
9271             jp1=iabs(j1)
9272 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9273 c     &         ' jj=',jj,' kk=',kk
9274 c            call flush(iout)
9275             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9276      &          .or. j.lt.0 .and. j1.gt.0) .and.
9277      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9278 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9279 C The system gains extra energy.
9280               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9281               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9282      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9283               n_corr=n_corr+1
9284             else if (j1.eq.j) then
9285 C Contacts I-J and I-(J+1) occur simultaneously.
9286 C The system loses extra energy.
9287 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9288             endif
9289           enddo ! kk
9290           do kk=1,num_conti
9291             j1=jcont_hb(kk,i)
9292 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9293 c    &         ' jj=',jj,' kk=',kk
9294             if (j1.eq.j+1) then
9295 C Contacts I-J and (I+1)-J occur simultaneously.
9296 C The system loses extra energy.
9297 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9298             endif ! j1==j+1
9299           enddo ! kk
9300         enddo ! jj
9301       enddo ! i
9302       return
9303       end
9304 c------------------------------------------------------------------------------
9305       subroutine add_hb_contact(ii,jj,itask)
9306       implicit real*8 (a-h,o-z)
9307       include "DIMENSIONS"
9308       include "COMMON.IOUNITS"
9309       integer max_cont
9310       integer max_dim
9311       parameter (max_cont=maxconts)
9312       parameter (max_dim=26)
9313       include "COMMON.CONTACTS"
9314       include 'COMMON.CONTMAT'
9315       include 'COMMON.CORRMAT'
9316       double precision zapas(max_dim,maxconts,max_fg_procs),
9317      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9318       common /przechowalnia/ zapas
9319       integer i,j,ii,jj,iproc,itask(4),nn
9320 c      write (iout,*) "itask",itask
9321       do i=1,2
9322         iproc=itask(i)
9323         if (iproc.gt.0) then
9324           do j=1,num_cont_hb(ii)
9325             jjc=jcont_hb(j,ii)
9326 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9327             if (jjc.eq.jj) then
9328               ncont_sent(iproc)=ncont_sent(iproc)+1
9329               nn=ncont_sent(iproc)
9330               zapas(1,nn,iproc)=ii
9331               zapas(2,nn,iproc)=jjc
9332               zapas(3,nn,iproc)=facont_hb(j,ii)
9333               zapas(4,nn,iproc)=ees0p(j,ii)
9334               zapas(5,nn,iproc)=ees0m(j,ii)
9335               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9336               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9337               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9338               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9339               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9340               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9341               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9342               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9343               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9344               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9345               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9346               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9347               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9348               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9349               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9350               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9351               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9352               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9353               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9354               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9355               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9356               exit
9357             endif
9358           enddo
9359         endif
9360       enddo
9361       return
9362       end
9363 c------------------------------------------------------------------------------
9364       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9365      &  n_corr1)
9366 C This subroutine calculates multi-body contributions to hydrogen-bonding
9367       implicit real*8 (a-h,o-z)
9368       include 'DIMENSIONS'
9369       include 'COMMON.IOUNITS'
9370 #ifdef MPI
9371       include "mpif.h"
9372       parameter (max_cont=maxconts)
9373       parameter (max_dim=70)
9374       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9375       double precision zapas(max_dim,maxconts,max_fg_procs),
9376      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9377       common /przechowalnia/ zapas
9378       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9379      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9380 #endif
9381       include 'COMMON.SETUP'
9382       include 'COMMON.FFIELD'
9383       include 'COMMON.DERIV'
9384       include 'COMMON.LOCAL'
9385       include 'COMMON.INTERACT'
9386       include 'COMMON.CONTACTS'
9387       include 'COMMON.CONTMAT'
9388       include 'COMMON.CORRMAT'
9389       include 'COMMON.CHAIN'
9390       include 'COMMON.CONTROL'
9391       include 'COMMON.SHIELD'
9392       double precision gx(3),gx1(3)
9393       integer num_cont_hb_old(maxres)
9394       logical lprn,ldone
9395       double precision eello4,eello5,eelo6,eello_turn6
9396       external eello4,eello5,eello6,eello_turn6
9397 C Set lprn=.true. for debugging
9398       lprn=.false.
9399       eturn6=0.0d0
9400 #ifdef MPI
9401       do i=1,nres
9402         num_cont_hb_old(i)=num_cont_hb(i)
9403       enddo
9404       n_corr=0
9405       n_corr1=0
9406       if (nfgtasks.le.1) goto 30
9407       if (lprn) then
9408         write (iout,'(a)') 'Contact function values before RECEIVE:'
9409         do i=nnt,nct-2
9410           write (iout,'(2i3,50(1x,i2,f5.2))')
9411      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9412      &    j=1,num_cont_hb(i))
9413         enddo
9414       endif
9415       do i=1,ntask_cont_from
9416         ncont_recv(i)=0
9417       enddo
9418       do i=1,ntask_cont_to
9419         ncont_sent(i)=0
9420       enddo
9421 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9422 c     & ntask_cont_to
9423 C Make the list of contacts to send to send to other procesors
9424       do i=iturn3_start,iturn3_end
9425 c        write (iout,*) "make contact list turn3",i," num_cont",
9426 c     &    num_cont_hb(i)
9427         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9428       enddo
9429       do i=iturn4_start,iturn4_end
9430 c        write (iout,*) "make contact list turn4",i," num_cont",
9431 c     &   num_cont_hb(i)
9432         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9433       enddo
9434       do ii=1,nat_sent
9435         i=iat_sent(ii)
9436 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9437 c     &    num_cont_hb(i)
9438         do j=1,num_cont_hb(i)
9439         do k=1,4
9440           jjc=jcont_hb(j,i)
9441           iproc=iint_sent_local(k,jjc,ii)
9442 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9443           if (iproc.ne.0) then
9444             ncont_sent(iproc)=ncont_sent(iproc)+1
9445             nn=ncont_sent(iproc)
9446             zapas(1,nn,iproc)=i
9447             zapas(2,nn,iproc)=jjc
9448             zapas(3,nn,iproc)=d_cont(j,i)
9449             ind=3
9450             do kk=1,3
9451               ind=ind+1
9452               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9453             enddo
9454             do kk=1,2
9455               do ll=1,2
9456                 ind=ind+1
9457                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9458               enddo
9459             enddo
9460             do jj=1,5
9461               do kk=1,3
9462                 do ll=1,2
9463                   do mm=1,2
9464                     ind=ind+1
9465                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9466                   enddo
9467                 enddo
9468               enddo
9469             enddo
9470           endif
9471         enddo
9472         enddo
9473       enddo
9474       if (lprn) then
9475       write (iout,*)
9476      &  "Numbers of contacts to be sent to other processors",
9477      &  (ncont_sent(i),i=1,ntask_cont_to)
9478       write (iout,*) "Contacts sent"
9479       do ii=1,ntask_cont_to
9480         nn=ncont_sent(ii)
9481         iproc=itask_cont_to(ii)
9482         write (iout,*) nn," contacts to processor",iproc,
9483      &   " of CONT_TO_COMM group"
9484         do i=1,nn
9485           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9486         enddo
9487       enddo
9488       call flush(iout)
9489       endif
9490       CorrelType=477
9491       CorrelID=fg_rank+1
9492       CorrelType1=478
9493       CorrelID1=nfgtasks+fg_rank+1
9494       ireq=0
9495 C Receive the numbers of needed contacts from other processors
9496       do ii=1,ntask_cont_from
9497         iproc=itask_cont_from(ii)
9498         ireq=ireq+1
9499         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9500      &    FG_COMM,req(ireq),IERR)
9501       enddo
9502 c      write (iout,*) "IRECV ended"
9503 c      call flush(iout)
9504 C Send the number of contacts needed by other processors
9505       do ii=1,ntask_cont_to
9506         iproc=itask_cont_to(ii)
9507         ireq=ireq+1
9508         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9509      &    FG_COMM,req(ireq),IERR)
9510       enddo
9511 c      write (iout,*) "ISEND ended"
9512 c      write (iout,*) "number of requests (nn)",ireq
9513 c      call flush(iout)
9514       if (ireq.gt.0)
9515      &  call MPI_Waitall(ireq,req,status_array,ierr)
9516 c      write (iout,*)
9517 c     &  "Numbers of contacts to be received from other processors",
9518 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9519 c      call flush(iout)
9520 C Receive contacts
9521       ireq=0
9522       do ii=1,ntask_cont_from
9523         iproc=itask_cont_from(ii)
9524         nn=ncont_recv(ii)
9525 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9526 c     &   " of CONT_TO_COMM group"
9527 c        call flush(iout)
9528         if (nn.gt.0) then
9529           ireq=ireq+1
9530           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9531      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9532 c          write (iout,*) "ireq,req",ireq,req(ireq)
9533         endif
9534       enddo
9535 C Send the contacts to processors that need them
9536       do ii=1,ntask_cont_to
9537         iproc=itask_cont_to(ii)
9538         nn=ncont_sent(ii)
9539 c        write (iout,*) nn," contacts to processor",iproc,
9540 c     &   " of CONT_TO_COMM group"
9541         if (nn.gt.0) then
9542           ireq=ireq+1
9543           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9544      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9545 c          write (iout,*) "ireq,req",ireq,req(ireq)
9546 c          do i=1,nn
9547 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9548 c          enddo
9549         endif
9550       enddo
9551 c      write (iout,*) "number of requests (contacts)",ireq
9552 c      write (iout,*) "req",(req(i),i=1,4)
9553 c      call flush(iout)
9554       if (ireq.gt.0)
9555      & call MPI_Waitall(ireq,req,status_array,ierr)
9556       do iii=1,ntask_cont_from
9557         iproc=itask_cont_from(iii)
9558         nn=ncont_recv(iii)
9559         if (lprn) then
9560         write (iout,*) "Received",nn," contacts from processor",iproc,
9561      &   " of CONT_FROM_COMM group"
9562         call flush(iout)
9563         do i=1,nn
9564           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9565         enddo
9566         call flush(iout)
9567         endif
9568         do i=1,nn
9569           ii=zapas_recv(1,i,iii)
9570 c Flag the received contacts to prevent double-counting
9571           jj=-zapas_recv(2,i,iii)
9572 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9573 c          call flush(iout)
9574           nnn=num_cont_hb(ii)+1
9575           num_cont_hb(ii)=nnn
9576           jcont_hb(nnn,ii)=jj
9577           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9578           ind=3
9579           do kk=1,3
9580             ind=ind+1
9581             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9582           enddo
9583           do kk=1,2
9584             do ll=1,2
9585               ind=ind+1
9586               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9587             enddo
9588           enddo
9589           do jj=1,5
9590             do kk=1,3
9591               do ll=1,2
9592                 do mm=1,2
9593                   ind=ind+1
9594                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9595                 enddo
9596               enddo
9597             enddo
9598           enddo
9599         enddo
9600       enddo
9601       if (lprn) then
9602         write (iout,'(a)') 'Contact function values after receive:'
9603         do i=nnt,nct-2
9604           write (iout,'(2i3,50(1x,i3,5f6.3))')
9605      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9606      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9607         enddo
9608         call flush(iout)
9609       endif
9610    30 continue
9611 #endif
9612       if (lprn) then
9613         write (iout,'(a)') 'Contact function values:'
9614         do i=nnt,nct-2
9615           write (iout,'(2i3,50(1x,i2,5f6.3))')
9616      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9617      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9618         enddo
9619       endif
9620       ecorr=0.0D0
9621       ecorr5=0.0d0
9622       ecorr6=0.0d0
9623 C Remove the loop below after debugging !!!
9624       do i=nnt,nct
9625         do j=1,3
9626           gradcorr(j,i)=0.0D0
9627           gradxorr(j,i)=0.0D0
9628         enddo
9629       enddo
9630 C Calculate the dipole-dipole interaction energies
9631       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9632       do i=iatel_s,iatel_e+1
9633         num_conti=num_cont_hb(i)
9634         do jj=1,num_conti
9635           j=jcont_hb(jj,i)
9636 #ifdef MOMENT
9637           call dipole(i,j,jj)
9638 #endif
9639         enddo
9640       enddo
9641       endif
9642 C Calculate the local-electrostatic correlation terms
9643 c                write (iout,*) "gradcorr5 in eello5 before loop"
9644 c                do iii=1,nres
9645 c                  write (iout,'(i5,3f10.5)')
9646 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9647 c                enddo
9648       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9649 c        write (iout,*) "corr loop i",i
9650         i1=i+1
9651         num_conti=num_cont_hb(i)
9652         num_conti1=num_cont_hb(i+1)
9653         do jj=1,num_conti
9654           j=jcont_hb(jj,i)
9655           jp=iabs(j)
9656           do kk=1,num_conti1
9657             j1=jcont_hb(kk,i1)
9658             jp1=iabs(j1)
9659 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9660 c     &         ' jj=',jj,' kk=',kk
9661 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9662             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9663      &          .or. j.lt.0 .and. j1.gt.0) .and.
9664      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9665 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9666 C The system gains extra energy.
9667               n_corr=n_corr+1
9668               sqd1=dsqrt(d_cont(jj,i))
9669               sqd2=dsqrt(d_cont(kk,i1))
9670               sred_geom = sqd1*sqd2
9671               IF (sred_geom.lt.cutoff_corr) THEN
9672                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9673      &            ekont,fprimcont)
9674 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9675 cd     &         ' jj=',jj,' kk=',kk
9676                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9677                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9678                 do l=1,3
9679                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9680                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9681                 enddo
9682                 n_corr1=n_corr1+1
9683 cd               write (iout,*) 'sred_geom=',sred_geom,
9684 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9685 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9686 cd               write (iout,*) "g_contij",g_contij
9687 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9688 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9689                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9690                 if (wcorr4.gt.0.0d0)
9691      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9692 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9693                   if (energy_dec.and.wcorr4.gt.0.0d0)
9694      1                 write (iout,'(a6,4i5,0pf7.3)')
9695      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9696 c                write (iout,*) "gradcorr5 before eello5"
9697 c                do iii=1,nres
9698 c                  write (iout,'(i5,3f10.5)')
9699 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9700 c                enddo
9701                 if (wcorr5.gt.0.0d0)
9702      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9703 c                write (iout,*) "gradcorr5 after eello5"
9704 c                do iii=1,nres
9705 c                  write (iout,'(i5,3f10.5)')
9706 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9707 c                enddo
9708                   if (energy_dec.and.wcorr5.gt.0.0d0)
9709      1                 write (iout,'(a6,4i5,0pf7.3)')
9710      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9711 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9712 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9713                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9714      &               .or. wturn6.eq.0.0d0))then
9715 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9716                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9717                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9718      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9719 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9720 cd     &            'ecorr6=',ecorr6
9721 cd                write (iout,'(4e15.5)') sred_geom,
9722 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9723 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9724 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9725                 else if (wturn6.gt.0.0d0
9726      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9727 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9728                   eturn6=eturn6+eello_turn6(i,jj,kk)
9729                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9730      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9731 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9732                 endif
9733               ENDIF
9734 1111          continue
9735             endif
9736           enddo ! kk
9737         enddo ! jj
9738       enddo ! i
9739       do i=1,nres
9740         num_cont_hb(i)=num_cont_hb_old(i)
9741       enddo
9742 c                write (iout,*) "gradcorr5 in eello5"
9743 c                do iii=1,nres
9744 c                  write (iout,'(i5,3f10.5)')
9745 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9746 c                enddo
9747       return
9748       end
9749 c------------------------------------------------------------------------------
9750       subroutine add_hb_contact_eello(ii,jj,itask)
9751       implicit real*8 (a-h,o-z)
9752       include "DIMENSIONS"
9753       include "COMMON.IOUNITS"
9754       integer max_cont
9755       integer max_dim
9756       parameter (max_cont=maxconts)
9757       parameter (max_dim=70)
9758       include "COMMON.CONTACTS"
9759       include 'COMMON.CONTMAT'
9760       include 'COMMON.CORRMAT'
9761       double precision zapas(max_dim,maxconts,max_fg_procs),
9762      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9763       common /przechowalnia/ zapas
9764       integer i,j,ii,jj,iproc,itask(4),nn
9765 c      write (iout,*) "itask",itask
9766       do i=1,2
9767         iproc=itask(i)
9768         if (iproc.gt.0) then
9769           do j=1,num_cont_hb(ii)
9770             jjc=jcont_hb(j,ii)
9771 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9772             if (jjc.eq.jj) then
9773               ncont_sent(iproc)=ncont_sent(iproc)+1
9774               nn=ncont_sent(iproc)
9775               zapas(1,nn,iproc)=ii
9776               zapas(2,nn,iproc)=jjc
9777               zapas(3,nn,iproc)=d_cont(j,ii)
9778               ind=3
9779               do kk=1,3
9780                 ind=ind+1
9781                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9782               enddo
9783               do kk=1,2
9784                 do ll=1,2
9785                   ind=ind+1
9786                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9787                 enddo
9788               enddo
9789               do jj=1,5
9790                 do kk=1,3
9791                   do ll=1,2
9792                     do mm=1,2
9793                       ind=ind+1
9794                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9795                     enddo
9796                   enddo
9797                 enddo
9798               enddo
9799               exit
9800             endif
9801           enddo
9802         endif
9803       enddo
9804       return
9805       end
9806 c------------------------------------------------------------------------------
9807       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9808       implicit real*8 (a-h,o-z)
9809       include 'DIMENSIONS'
9810       include 'COMMON.IOUNITS'
9811       include 'COMMON.DERIV'
9812       include 'COMMON.INTERACT'
9813       include 'COMMON.CONTACTS'
9814       include 'COMMON.CONTMAT'
9815       include 'COMMON.CORRMAT'
9816       include 'COMMON.SHIELD'
9817       include 'COMMON.CONTROL'
9818       double precision gx(3),gx1(3)
9819       logical lprn
9820       lprn=.false.
9821 C      print *,"wchodze",fac_shield(i),shield_mode
9822       eij=facont_hb(jj,i)
9823       ekl=facont_hb(kk,k)
9824       ees0pij=ees0p(jj,i)
9825       ees0pkl=ees0p(kk,k)
9826       ees0mij=ees0m(jj,i)
9827       ees0mkl=ees0m(kk,k)
9828       ekont=eij*ekl
9829       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9830 C*
9831 C     & fac_shield(i)**2*fac_shield(j)**2
9832 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9833 C Following 4 lines for diagnostics.
9834 cd    ees0pkl=0.0D0
9835 cd    ees0pij=1.0D0
9836 cd    ees0mkl=0.0D0
9837 cd    ees0mij=1.0D0
9838 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9839 c     & 'Contacts ',i,j,
9840 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9841 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9842 c     & 'gradcorr_long'
9843 C Calculate the multi-body contribution to energy.
9844 C      ecorr=ecorr+ekont*ees
9845 C Calculate multi-body contributions to the gradient.
9846       coeffpees0pij=coeffp*ees0pij
9847       coeffmees0mij=coeffm*ees0mij
9848       coeffpees0pkl=coeffp*ees0pkl
9849       coeffmees0mkl=coeffm*ees0mkl
9850       do ll=1,3
9851 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9852         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9853      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9854      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9855         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9856      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9857      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9858 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9859         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9860      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9861      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9862         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9863      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9864      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9865         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9866      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9867      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9868         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9869         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9870         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9871      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9872      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9873         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9874         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9875 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9876       enddo
9877 c      write (iout,*)
9878 cgrad      do m=i+1,j-1
9879 cgrad        do ll=1,3
9880 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9881 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9882 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9883 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9884 cgrad        enddo
9885 cgrad      enddo
9886 cgrad      do m=k+1,l-1
9887 cgrad        do ll=1,3
9888 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9889 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9890 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9891 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9892 cgrad        enddo
9893 cgrad      enddo
9894 c      write (iout,*) "ehbcorr",ekont*ees
9895 C      print *,ekont,ees,i,k
9896       ehbcorr=ekont*ees
9897 C now gradient over shielding
9898 C      return
9899       if (shield_mode.gt.0) then
9900        j=ees0plist(jj,i)
9901        l=ees0plist(kk,k)
9902 C        print *,i,j,fac_shield(i),fac_shield(j),
9903 C     &fac_shield(k),fac_shield(l)
9904         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9905      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9906           do ilist=1,ishield_list(i)
9907            iresshield=shield_list(ilist,i)
9908            do m=1,3
9909            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9910 C     &      *2.0
9911            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9912      &              rlocshield
9913      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9914             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9915      &+rlocshield
9916            enddo
9917           enddo
9918           do ilist=1,ishield_list(j)
9919            iresshield=shield_list(ilist,j)
9920            do m=1,3
9921            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9922 C     &     *2.0
9923            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9924      &              rlocshield
9925      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9926            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9927      &     +rlocshield
9928            enddo
9929           enddo
9930
9931           do ilist=1,ishield_list(k)
9932            iresshield=shield_list(ilist,k)
9933            do m=1,3
9934            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9935 C     &     *2.0
9936            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9937      &              rlocshield
9938      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9939            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9940      &     +rlocshield
9941            enddo
9942           enddo
9943           do ilist=1,ishield_list(l)
9944            iresshield=shield_list(ilist,l)
9945            do m=1,3
9946            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9947 C     &     *2.0
9948            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9949      &              rlocshield
9950      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9951            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9952      &     +rlocshield
9953            enddo
9954           enddo
9955 C          print *,gshieldx(m,iresshield)
9956           do m=1,3
9957             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9958      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9959             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9960      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9961             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9962      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9963             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9964      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9965
9966             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9967      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9968             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9969      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9970             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9971      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9972             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9973      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9974
9975            enddo
9976       endif
9977       endif
9978       return
9979       end
9980 #ifdef MOMENT
9981 C---------------------------------------------------------------------------
9982       subroutine dipole(i,j,jj)
9983       implicit real*8 (a-h,o-z)
9984       include 'DIMENSIONS'
9985       include 'COMMON.IOUNITS'
9986       include 'COMMON.CHAIN'
9987       include 'COMMON.FFIELD'
9988       include 'COMMON.DERIV'
9989       include 'COMMON.INTERACT'
9990       include 'COMMON.CONTACTS'
9991       include 'COMMON.CONTMAT'
9992       include 'COMMON.CORRMAT'
9993       include 'COMMON.TORSION'
9994       include 'COMMON.VAR'
9995       include 'COMMON.GEO'
9996       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9997      &  auxmat(2,2)
9998       iti1 = itortyp(itype(i+1))
9999       if (j.lt.nres-1) then
10000         itj1 = itype2loc(itype(j+1))
10001       else
10002         itj1=nloctyp
10003       endif
10004       do iii=1,2
10005         dipi(iii,1)=Ub2(iii,i)
10006         dipderi(iii)=Ub2der(iii,i)
10007         dipi(iii,2)=b1(iii,i+1)
10008         dipj(iii,1)=Ub2(iii,j)
10009         dipderj(iii)=Ub2der(iii,j)
10010         dipj(iii,2)=b1(iii,j+1)
10011       enddo
10012       kkk=0
10013       do iii=1,2
10014         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
10015         do jjj=1,2
10016           kkk=kkk+1
10017           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
10018         enddo
10019       enddo
10020       do kkk=1,5
10021         do lll=1,3
10022           mmm=0
10023           do iii=1,2
10024             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
10025      &        auxvec(1))
10026             do jjj=1,2
10027               mmm=mmm+1
10028               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
10029             enddo
10030           enddo
10031         enddo
10032       enddo
10033       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
10034       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
10035       do iii=1,2
10036         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
10037       enddo
10038       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
10039       do iii=1,2
10040         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
10041       enddo
10042       return
10043       end
10044 #endif
10045 C---------------------------------------------------------------------------
10046       subroutine calc_eello(i,j,k,l,jj,kk)
10047 C
10048 C This subroutine computes matrices and vectors needed to calculate
10049 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
10050 C
10051       implicit real*8 (a-h,o-z)
10052       include 'DIMENSIONS'
10053       include 'COMMON.IOUNITS'
10054       include 'COMMON.CHAIN'
10055       include 'COMMON.DERIV'
10056       include 'COMMON.INTERACT'
10057       include 'COMMON.CONTACTS'
10058       include 'COMMON.CONTMAT'
10059       include 'COMMON.CORRMAT'
10060       include 'COMMON.TORSION'
10061       include 'COMMON.VAR'
10062       include 'COMMON.GEO'
10063       include 'COMMON.FFIELD'
10064       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
10065      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
10066       logical lprn
10067       common /kutas/ lprn
10068 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
10069 cd     & ' jj=',jj,' kk=',kk
10070 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
10071 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
10072 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
10073       do iii=1,2
10074         do jjj=1,2
10075           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
10076           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
10077         enddo
10078       enddo
10079       call transpose2(aa1(1,1),aa1t(1,1))
10080       call transpose2(aa2(1,1),aa2t(1,1))
10081       do kkk=1,5
10082         do lll=1,3
10083           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
10084      &      aa1tder(1,1,lll,kkk))
10085           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
10086      &      aa2tder(1,1,lll,kkk))
10087         enddo
10088       enddo
10089       if (l.eq.j+1) then
10090 C parallel orientation of the two CA-CA-CA frames.
10091         if (i.gt.1) then
10092           iti=itype2loc(itype(i))
10093         else
10094           iti=nloctyp
10095         endif
10096         itk1=itype2loc(itype(k+1))
10097         itj=itype2loc(itype(j))
10098         if (l.lt.nres-1) then
10099           itl1=itype2loc(itype(l+1))
10100         else
10101           itl1=nloctyp
10102         endif
10103 C A1 kernel(j+1) A2T
10104 cd        do iii=1,2
10105 cd          write (iout,'(3f10.5,5x,3f10.5)')
10106 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10107 cd        enddo
10108         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10109      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10110      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10111 C Following matrices are needed only for 6-th order cumulants
10112         IF (wcorr6.gt.0.0d0) THEN
10113         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10114      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10115      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10116         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10117      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10118      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10119      &   ADtEAderx(1,1,1,1,1,1))
10120         lprn=.false.
10121         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10122      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10123      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10124      &   ADtEA1derx(1,1,1,1,1,1))
10125         ENDIF
10126 C End 6-th order cumulants
10127 cd        lprn=.false.
10128 cd        if (lprn) then
10129 cd        write (2,*) 'In calc_eello6'
10130 cd        do iii=1,2
10131 cd          write (2,*) 'iii=',iii
10132 cd          do kkk=1,5
10133 cd            write (2,*) 'kkk=',kkk
10134 cd            do jjj=1,2
10135 cd              write (2,'(3(2f10.5),5x)')
10136 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10137 cd            enddo
10138 cd          enddo
10139 cd        enddo
10140 cd        endif
10141         call transpose2(EUgder(1,1,k),auxmat(1,1))
10142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10143         call transpose2(EUg(1,1,k),auxmat(1,1))
10144         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10145         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10146 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10147 c    in theta; to be sriten later.
10148 c#ifdef NEWCORR
10149 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
10150 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10151 c        call transpose2(EUg(1,1,k),auxmat(1,1))
10152 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10153 c#endif
10154         do iii=1,2
10155           do kkk=1,5
10156             do lll=1,3
10157               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10158      &          EAEAderx(1,1,lll,kkk,iii,1))
10159             enddo
10160           enddo
10161         enddo
10162 C A1T kernel(i+1) A2
10163         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10164      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10165      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10166 C Following matrices are needed only for 6-th order cumulants
10167         IF (wcorr6.gt.0.0d0) THEN
10168         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10169      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10170      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10171         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10172      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10173      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10174      &   ADtEAderx(1,1,1,1,1,2))
10175         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10176      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10177      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10178      &   ADtEA1derx(1,1,1,1,1,2))
10179         ENDIF
10180 C End 6-th order cumulants
10181         call transpose2(EUgder(1,1,l),auxmat(1,1))
10182         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10183         call transpose2(EUg(1,1,l),auxmat(1,1))
10184         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10185         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10186         do iii=1,2
10187           do kkk=1,5
10188             do lll=1,3
10189               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10190      &          EAEAderx(1,1,lll,kkk,iii,2))
10191             enddo
10192           enddo
10193         enddo
10194 C AEAb1 and AEAb2
10195 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10196 C They are needed only when the fifth- or the sixth-order cumulants are
10197 C indluded.
10198         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10199         call transpose2(AEA(1,1,1),auxmat(1,1))
10200         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10201         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10202         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10203         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10204         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10205         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10206         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10207         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10208         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10209         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10210         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10211         call transpose2(AEA(1,1,2),auxmat(1,1))
10212         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10213         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10214         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10215         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10216         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10217         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10218         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10219         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10220         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10221         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10222         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10223 C Calculate the Cartesian derivatives of the vectors.
10224         do iii=1,2
10225           do kkk=1,5
10226             do lll=1,3
10227               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10228               call matvec2(auxmat(1,1),b1(1,i),
10229      &          AEAb1derx(1,lll,kkk,iii,1,1))
10230               call matvec2(auxmat(1,1),Ub2(1,i),
10231      &          AEAb2derx(1,lll,kkk,iii,1,1))
10232               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10233      &          AEAb1derx(1,lll,kkk,iii,2,1))
10234               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10235      &          AEAb2derx(1,lll,kkk,iii,2,1))
10236               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10237               call matvec2(auxmat(1,1),b1(1,j),
10238      &          AEAb1derx(1,lll,kkk,iii,1,2))
10239               call matvec2(auxmat(1,1),Ub2(1,j),
10240      &          AEAb2derx(1,lll,kkk,iii,1,2))
10241               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10242      &          AEAb1derx(1,lll,kkk,iii,2,2))
10243               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10244      &          AEAb2derx(1,lll,kkk,iii,2,2))
10245             enddo
10246           enddo
10247         enddo
10248         ENDIF
10249 C End vectors
10250       else
10251 C Antiparallel orientation of the two CA-CA-CA frames.
10252         if (i.gt.1) then
10253           iti=itype2loc(itype(i))
10254         else
10255           iti=nloctyp
10256         endif
10257         itk1=itype2loc(itype(k+1))
10258         itl=itype2loc(itype(l))
10259         itj=itype2loc(itype(j))
10260         if (j.lt.nres-1) then
10261           itj1=itype2loc(itype(j+1))
10262         else
10263           itj1=nloctyp
10264         endif
10265 C A2 kernel(j-1)T A1T
10266         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10267      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10268      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10269 C Following matrices are needed only for 6-th order cumulants
10270         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10271      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10272         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10273      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10274      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10275         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10276      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10277      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10278      &   ADtEAderx(1,1,1,1,1,1))
10279         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10280      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10281      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10282      &   ADtEA1derx(1,1,1,1,1,1))
10283         ENDIF
10284 C End 6-th order cumulants
10285         call transpose2(EUgder(1,1,k),auxmat(1,1))
10286         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10287         call transpose2(EUg(1,1,k),auxmat(1,1))
10288         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10289         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10290         do iii=1,2
10291           do kkk=1,5
10292             do lll=1,3
10293               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10294      &          EAEAderx(1,1,lll,kkk,iii,1))
10295             enddo
10296           enddo
10297         enddo
10298 C A2T kernel(i+1)T A1
10299         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10300      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10301      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10302 C Following matrices are needed only for 6-th order cumulants
10303         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10304      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10305         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10306      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10307      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10308         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10309      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10310      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10311      &   ADtEAderx(1,1,1,1,1,2))
10312         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10313      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10314      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10315      &   ADtEA1derx(1,1,1,1,1,2))
10316         ENDIF
10317 C End 6-th order cumulants
10318         call transpose2(EUgder(1,1,j),auxmat(1,1))
10319         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10320         call transpose2(EUg(1,1,j),auxmat(1,1))
10321         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10322         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10323         do iii=1,2
10324           do kkk=1,5
10325             do lll=1,3
10326               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10327      &          EAEAderx(1,1,lll,kkk,iii,2))
10328             enddo
10329           enddo
10330         enddo
10331 C AEAb1 and AEAb2
10332 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10333 C They are needed only when the fifth- or the sixth-order cumulants are
10334 C indluded.
10335         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10336      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10337         call transpose2(AEA(1,1,1),auxmat(1,1))
10338         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10339         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10340         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10341         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10342         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10343         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10344         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10345         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10346         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10347         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10348         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10349         call transpose2(AEA(1,1,2),auxmat(1,1))
10350         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10351         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10352         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10353         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10354         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10355         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10356         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10357         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10358         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10359         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10360         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10361 C Calculate the Cartesian derivatives of the vectors.
10362         do iii=1,2
10363           do kkk=1,5
10364             do lll=1,3
10365               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10366               call matvec2(auxmat(1,1),b1(1,i),
10367      &          AEAb1derx(1,lll,kkk,iii,1,1))
10368               call matvec2(auxmat(1,1),Ub2(1,i),
10369      &          AEAb2derx(1,lll,kkk,iii,1,1))
10370               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10371      &          AEAb1derx(1,lll,kkk,iii,2,1))
10372               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10373      &          AEAb2derx(1,lll,kkk,iii,2,1))
10374               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10375               call matvec2(auxmat(1,1),b1(1,l),
10376      &          AEAb1derx(1,lll,kkk,iii,1,2))
10377               call matvec2(auxmat(1,1),Ub2(1,l),
10378      &          AEAb2derx(1,lll,kkk,iii,1,2))
10379               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10380      &          AEAb1derx(1,lll,kkk,iii,2,2))
10381               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10382      &          AEAb2derx(1,lll,kkk,iii,2,2))
10383             enddo
10384           enddo
10385         enddo
10386         ENDIF
10387 C End vectors
10388       endif
10389       return
10390       end
10391 C---------------------------------------------------------------------------
10392       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10393      &  KK,KKderg,AKA,AKAderg,AKAderx)
10394       implicit none
10395       integer nderg
10396       logical transp
10397       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10398      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10399      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10400       integer iii,kkk,lll
10401       integer jjj,mmm
10402       logical lprn
10403       common /kutas/ lprn
10404       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10405       do iii=1,nderg
10406         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10407      &    AKAderg(1,1,iii))
10408       enddo
10409 cd      if (lprn) write (2,*) 'In kernel'
10410       do kkk=1,5
10411 cd        if (lprn) write (2,*) 'kkk=',kkk
10412         do lll=1,3
10413           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10414      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10415 cd          if (lprn) then
10416 cd            write (2,*) 'lll=',lll
10417 cd            write (2,*) 'iii=1'
10418 cd            do jjj=1,2
10419 cd              write (2,'(3(2f10.5),5x)')
10420 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10421 cd            enddo
10422 cd          endif
10423           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10424      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10425 cd          if (lprn) then
10426 cd            write (2,*) 'lll=',lll
10427 cd            write (2,*) 'iii=2'
10428 cd            do jjj=1,2
10429 cd              write (2,'(3(2f10.5),5x)')
10430 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10431 cd            enddo
10432 cd          endif
10433         enddo
10434       enddo
10435       return
10436       end
10437 C---------------------------------------------------------------------------
10438       double precision function eello4(i,j,k,l,jj,kk)
10439       implicit real*8 (a-h,o-z)
10440       include 'DIMENSIONS'
10441       include 'COMMON.IOUNITS'
10442       include 'COMMON.CHAIN'
10443       include 'COMMON.DERIV'
10444       include 'COMMON.INTERACT'
10445       include 'COMMON.CONTACTS'
10446       include 'COMMON.CONTMAT'
10447       include 'COMMON.CORRMAT'
10448       include 'COMMON.TORSION'
10449       include 'COMMON.VAR'
10450       include 'COMMON.GEO'
10451       double precision pizda(2,2),ggg1(3),ggg2(3)
10452 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10453 cd        eello4=0.0d0
10454 cd        return
10455 cd      endif
10456 cd      print *,'eello4:',i,j,k,l,jj,kk
10457 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10458 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10459 cold      eij=facont_hb(jj,i)
10460 cold      ekl=facont_hb(kk,k)
10461 cold      ekont=eij*ekl
10462       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10463 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10464       gcorr_loc(k-1)=gcorr_loc(k-1)
10465      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10466       if (l.eq.j+1) then
10467         gcorr_loc(l-1)=gcorr_loc(l-1)
10468      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10469 C Al 4/16/16: Derivatives in theta, to be added later.
10470 c#ifdef NEWCORR
10471 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10472 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10473 c#endif
10474       else
10475         gcorr_loc(j-1)=gcorr_loc(j-1)
10476      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10477 c#ifdef NEWCORR
10478 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10479 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10480 c#endif
10481       endif
10482       do iii=1,2
10483         do kkk=1,5
10484           do lll=1,3
10485             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10486      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10487 cd            derx(lll,kkk,iii)=0.0d0
10488           enddo
10489         enddo
10490       enddo
10491 cd      gcorr_loc(l-1)=0.0d0
10492 cd      gcorr_loc(j-1)=0.0d0
10493 cd      gcorr_loc(k-1)=0.0d0
10494 cd      eel4=1.0d0
10495 cd      write (iout,*)'Contacts have occurred for peptide groups',
10496 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10497 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10498       if (j.lt.nres-1) then
10499         j1=j+1
10500         j2=j-1
10501       else
10502         j1=j-1
10503         j2=j-2
10504       endif
10505       if (l.lt.nres-1) then
10506         l1=l+1
10507         l2=l-1
10508       else
10509         l1=l-1
10510         l2=l-2
10511       endif
10512       do ll=1,3
10513 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10514 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10515         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10516         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10517 cgrad        ghalf=0.5d0*ggg1(ll)
10518         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10519         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10520         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10521         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10522         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10523         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10524 cgrad        ghalf=0.5d0*ggg2(ll)
10525         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10526         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10527         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10528         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10529         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10530         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10531       enddo
10532 cgrad      do m=i+1,j-1
10533 cgrad        do ll=1,3
10534 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10535 cgrad        enddo
10536 cgrad      enddo
10537 cgrad      do m=k+1,l-1
10538 cgrad        do ll=1,3
10539 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10540 cgrad        enddo
10541 cgrad      enddo
10542 cgrad      do m=i+2,j2
10543 cgrad        do ll=1,3
10544 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10545 cgrad        enddo
10546 cgrad      enddo
10547 cgrad      do m=k+2,l2
10548 cgrad        do ll=1,3
10549 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10550 cgrad        enddo
10551 cgrad      enddo
10552 cd      do iii=1,nres-3
10553 cd        write (2,*) iii,gcorr_loc(iii)
10554 cd      enddo
10555       eello4=ekont*eel4
10556 cd      write (2,*) 'ekont',ekont
10557 cd      write (iout,*) 'eello4',ekont*eel4
10558       return
10559       end
10560 C---------------------------------------------------------------------------
10561       double precision function eello5(i,j,k,l,jj,kk)
10562       implicit real*8 (a-h,o-z)
10563       include 'DIMENSIONS'
10564       include 'COMMON.IOUNITS'
10565       include 'COMMON.CHAIN'
10566       include 'COMMON.DERIV'
10567       include 'COMMON.INTERACT'
10568       include 'COMMON.CONTACTS'
10569       include 'COMMON.CONTMAT'
10570       include 'COMMON.CORRMAT'
10571       include 'COMMON.TORSION'
10572       include 'COMMON.VAR'
10573       include 'COMMON.GEO'
10574       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10575       double precision ggg1(3),ggg2(3)
10576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10577 C                                                                              C
10578 C                            Parallel chains                                   C
10579 C                                                                              C
10580 C          o             o                   o             o                   C
10581 C         /l\           / \             \   / \           / \   /              C
10582 C        /   \         /   \             \ /   \         /   \ /               C
10583 C       j| o |l1       | o |              o| o |         | o |o                C
10584 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10585 C      \i/   \         /   \ /             /   \         /   \                 C
10586 C       o    k1             o                                                  C
10587 C         (I)          (II)                (III)          (IV)                 C
10588 C                                                                              C
10589 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10590 C                                                                              C
10591 C                            Antiparallel chains                               C
10592 C                                                                              C
10593 C          o             o                   o             o                   C
10594 C         /j\           / \             \   / \           / \   /              C
10595 C        /   \         /   \             \ /   \         /   \ /               C
10596 C      j1| o |l        | o |              o| o |         | o |o                C
10597 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10598 C      \i/   \         /   \ /             /   \         /   \                 C
10599 C       o     k1            o                                                  C
10600 C         (I)          (II)                (III)          (IV)                 C
10601 C                                                                              C
10602 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10603 C                                                                              C
10604 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10605 C                                                                              C
10606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10607 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10608 cd        eello5=0.0d0
10609 cd        return
10610 cd      endif
10611 cd      write (iout,*)
10612 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10613 cd     &   ' and',k,l
10614       itk=itype2loc(itype(k))
10615       itl=itype2loc(itype(l))
10616       itj=itype2loc(itype(j))
10617       eello5_1=0.0d0
10618       eello5_2=0.0d0
10619       eello5_3=0.0d0
10620       eello5_4=0.0d0
10621 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10622 cd     &   eel5_3_num,eel5_4_num)
10623       do iii=1,2
10624         do kkk=1,5
10625           do lll=1,3
10626             derx(lll,kkk,iii)=0.0d0
10627           enddo
10628         enddo
10629       enddo
10630 cd      eij=facont_hb(jj,i)
10631 cd      ekl=facont_hb(kk,k)
10632 cd      ekont=eij*ekl
10633 cd      write (iout,*)'Contacts have occurred for peptide groups',
10634 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10635 cd      goto 1111
10636 C Contribution from the graph I.
10637 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10638 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10639       call transpose2(EUg(1,1,k),auxmat(1,1))
10640       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10641       vv(1)=pizda(1,1)-pizda(2,2)
10642       vv(2)=pizda(1,2)+pizda(2,1)
10643       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10644      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10645 C Explicit gradient in virtual-dihedral angles.
10646       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10647      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10648      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10649       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10650       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10651       vv(1)=pizda(1,1)-pizda(2,2)
10652       vv(2)=pizda(1,2)+pizda(2,1)
10653       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10654      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10655      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10656       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10657       vv(1)=pizda(1,1)-pizda(2,2)
10658       vv(2)=pizda(1,2)+pizda(2,1)
10659       if (l.eq.j+1) then
10660         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10661      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10662      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10663       else
10664         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10665      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10666      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10667       endif
10668 C Cartesian gradient
10669       do iii=1,2
10670         do kkk=1,5
10671           do lll=1,3
10672             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10673      &        pizda(1,1))
10674             vv(1)=pizda(1,1)-pizda(2,2)
10675             vv(2)=pizda(1,2)+pizda(2,1)
10676             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10677      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10678      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10679           enddo
10680         enddo
10681       enddo
10682 c      goto 1112
10683 c1111  continue
10684 C Contribution from graph II
10685       call transpose2(EE(1,1,k),auxmat(1,1))
10686       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10687       vv(1)=pizda(1,1)+pizda(2,2)
10688       vv(2)=pizda(2,1)-pizda(1,2)
10689       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10690      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10691 C Explicit gradient in virtual-dihedral angles.
10692       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10693      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10694       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10695       vv(1)=pizda(1,1)+pizda(2,2)
10696       vv(2)=pizda(2,1)-pizda(1,2)
10697       if (l.eq.j+1) then
10698         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10699      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10700      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10701       else
10702         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10703      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10704      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10705       endif
10706 C Cartesian gradient
10707       do iii=1,2
10708         do kkk=1,5
10709           do lll=1,3
10710             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10711      &        pizda(1,1))
10712             vv(1)=pizda(1,1)+pizda(2,2)
10713             vv(2)=pizda(2,1)-pizda(1,2)
10714             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10715      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10716      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10717           enddo
10718         enddo
10719       enddo
10720 cd      goto 1112
10721 cd1111  continue
10722       if (l.eq.j+1) then
10723 cd        goto 1110
10724 C Parallel orientation
10725 C Contribution from graph III
10726         call transpose2(EUg(1,1,l),auxmat(1,1))
10727         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10728         vv(1)=pizda(1,1)-pizda(2,2)
10729         vv(2)=pizda(1,2)+pizda(2,1)
10730         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10731      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10732 C Explicit gradient in virtual-dihedral angles.
10733         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10734      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10735      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10736         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10737         vv(1)=pizda(1,1)-pizda(2,2)
10738         vv(2)=pizda(1,2)+pizda(2,1)
10739         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10740      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10741      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10742         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10743         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10744         vv(1)=pizda(1,1)-pizda(2,2)
10745         vv(2)=pizda(1,2)+pizda(2,1)
10746         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10747      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10748      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10749 C Cartesian gradient
10750         do iii=1,2
10751           do kkk=1,5
10752             do lll=1,3
10753               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10754      &          pizda(1,1))
10755               vv(1)=pizda(1,1)-pizda(2,2)
10756               vv(2)=pizda(1,2)+pizda(2,1)
10757               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10758      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10759      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10760             enddo
10761           enddo
10762         enddo
10763 cd        goto 1112
10764 C Contribution from graph IV
10765 cd1110    continue
10766         call transpose2(EE(1,1,l),auxmat(1,1))
10767         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10768         vv(1)=pizda(1,1)+pizda(2,2)
10769         vv(2)=pizda(2,1)-pizda(1,2)
10770         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10771      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10772 C Explicit gradient in virtual-dihedral angles.
10773         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10774      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10775         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10776         vv(1)=pizda(1,1)+pizda(2,2)
10777         vv(2)=pizda(2,1)-pizda(1,2)
10778         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10779      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10780      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10781 C Cartesian gradient
10782         do iii=1,2
10783           do kkk=1,5
10784             do lll=1,3
10785               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10786      &          pizda(1,1))
10787               vv(1)=pizda(1,1)+pizda(2,2)
10788               vv(2)=pizda(2,1)-pizda(1,2)
10789               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10790      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10791      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10792             enddo
10793           enddo
10794         enddo
10795       else
10796 C Antiparallel orientation
10797 C Contribution from graph III
10798 c        goto 1110
10799         call transpose2(EUg(1,1,j),auxmat(1,1))
10800         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10801         vv(1)=pizda(1,1)-pizda(2,2)
10802         vv(2)=pizda(1,2)+pizda(2,1)
10803         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10804      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10805 C Explicit gradient in virtual-dihedral angles.
10806         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10807      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10808      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10809         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10810         vv(1)=pizda(1,1)-pizda(2,2)
10811         vv(2)=pizda(1,2)+pizda(2,1)
10812         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10813      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10814      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10815         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10816         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10817         vv(1)=pizda(1,1)-pizda(2,2)
10818         vv(2)=pizda(1,2)+pizda(2,1)
10819         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10820      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10821      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10822 C Cartesian gradient
10823         do iii=1,2
10824           do kkk=1,5
10825             do lll=1,3
10826               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10827      &          pizda(1,1))
10828               vv(1)=pizda(1,1)-pizda(2,2)
10829               vv(2)=pizda(1,2)+pizda(2,1)
10830               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10831      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10832      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10833             enddo
10834           enddo
10835         enddo
10836 cd        goto 1112
10837 C Contribution from graph IV
10838 1110    continue
10839         call transpose2(EE(1,1,j),auxmat(1,1))
10840         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10841         vv(1)=pizda(1,1)+pizda(2,2)
10842         vv(2)=pizda(2,1)-pizda(1,2)
10843         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10844      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10845 C Explicit gradient in virtual-dihedral angles.
10846         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10847      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10848         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10849         vv(1)=pizda(1,1)+pizda(2,2)
10850         vv(2)=pizda(2,1)-pizda(1,2)
10851         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10852      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10853      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10854 C Cartesian gradient
10855         do iii=1,2
10856           do kkk=1,5
10857             do lll=1,3
10858               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10859      &          pizda(1,1))
10860               vv(1)=pizda(1,1)+pizda(2,2)
10861               vv(2)=pizda(2,1)-pizda(1,2)
10862               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10863      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10864      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10865             enddo
10866           enddo
10867         enddo
10868       endif
10869 1112  continue
10870       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10871 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10872 cd        write (2,*) 'ijkl',i,j,k,l
10873 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10874 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10875 cd      endif
10876 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10877 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10878 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10879 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10880       if (j.lt.nres-1) then
10881         j1=j+1
10882         j2=j-1
10883       else
10884         j1=j-1
10885         j2=j-2
10886       endif
10887       if (l.lt.nres-1) then
10888         l1=l+1
10889         l2=l-1
10890       else
10891         l1=l-1
10892         l2=l-2
10893       endif
10894 cd      eij=1.0d0
10895 cd      ekl=1.0d0
10896 cd      ekont=1.0d0
10897 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10898 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10899 C        summed up outside the subrouine as for the other subroutines
10900 C        handling long-range interactions. The old code is commented out
10901 C        with "cgrad" to keep track of changes.
10902       do ll=1,3
10903 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10904 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10905         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10906         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10907 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10908 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10909 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10910 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10911 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10912 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10913 c     &   gradcorr5ij,
10914 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10915 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10916 cgrad        ghalf=0.5d0*ggg1(ll)
10917 cd        ghalf=0.0d0
10918         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10919         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10920         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10921         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10922         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10923         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10924 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10925 cgrad        ghalf=0.5d0*ggg2(ll)
10926 cd        ghalf=0.0d0
10927         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10928         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10929         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10930         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10931         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10932         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10933       enddo
10934 cd      goto 1112
10935 cgrad      do m=i+1,j-1
10936 cgrad        do ll=1,3
10937 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10938 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10939 cgrad        enddo
10940 cgrad      enddo
10941 cgrad      do m=k+1,l-1
10942 cgrad        do ll=1,3
10943 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10944 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10945 cgrad        enddo
10946 cgrad      enddo
10947 c1112  continue
10948 cgrad      do m=i+2,j2
10949 cgrad        do ll=1,3
10950 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10951 cgrad        enddo
10952 cgrad      enddo
10953 cgrad      do m=k+2,l2
10954 cgrad        do ll=1,3
10955 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10956 cgrad        enddo
10957 cgrad      enddo
10958 cd      do iii=1,nres-3
10959 cd        write (2,*) iii,g_corr5_loc(iii)
10960 cd      enddo
10961       eello5=ekont*eel5
10962 cd      write (2,*) 'ekont',ekont
10963 cd      write (iout,*) 'eello5',ekont*eel5
10964       return
10965       end
10966 c--------------------------------------------------------------------------
10967       double precision function eello6(i,j,k,l,jj,kk)
10968       implicit real*8 (a-h,o-z)
10969       include 'DIMENSIONS'
10970       include 'COMMON.IOUNITS'
10971       include 'COMMON.CHAIN'
10972       include 'COMMON.DERIV'
10973       include 'COMMON.INTERACT'
10974       include 'COMMON.CONTACTS'
10975       include 'COMMON.CONTMAT'
10976       include 'COMMON.CORRMAT'
10977       include 'COMMON.TORSION'
10978       include 'COMMON.VAR'
10979       include 'COMMON.GEO'
10980       include 'COMMON.FFIELD'
10981       double precision ggg1(3),ggg2(3)
10982 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10983 cd        eello6=0.0d0
10984 cd        return
10985 cd      endif
10986 cd      write (iout,*)
10987 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10988 cd     &   ' and',k,l
10989       eello6_1=0.0d0
10990       eello6_2=0.0d0
10991       eello6_3=0.0d0
10992       eello6_4=0.0d0
10993       eello6_5=0.0d0
10994       eello6_6=0.0d0
10995 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10996 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10997       do iii=1,2
10998         do kkk=1,5
10999           do lll=1,3
11000             derx(lll,kkk,iii)=0.0d0
11001           enddo
11002         enddo
11003       enddo
11004 cd      eij=facont_hb(jj,i)
11005 cd      ekl=facont_hb(kk,k)
11006 cd      ekont=eij*ekl
11007 cd      eij=1.0d0
11008 cd      ekl=1.0d0
11009 cd      ekont=1.0d0
11010       if (l.eq.j+1) then
11011         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
11012         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
11013         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
11014         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
11015         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
11016         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
11017       else
11018         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
11019         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
11020         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
11021         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
11022         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
11023           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11024         else
11025           eello6_5=0.0d0
11026         endif
11027         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
11028       endif
11029 C If turn contributions are considered, they will be handled separately.
11030       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
11031 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
11032 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
11033 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
11034 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
11035 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
11036 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
11037 cd      goto 1112
11038       if (j.lt.nres-1) then
11039         j1=j+1
11040         j2=j-1
11041       else
11042         j1=j-1
11043         j2=j-2
11044       endif
11045       if (l.lt.nres-1) then
11046         l1=l+1
11047         l2=l-1
11048       else
11049         l1=l-1
11050         l2=l-2
11051       endif
11052       do ll=1,3
11053 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
11054 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
11055 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
11056 cgrad        ghalf=0.5d0*ggg1(ll)
11057 cd        ghalf=0.0d0
11058         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
11059         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
11060         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
11061         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
11062         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
11063         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
11064         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
11065         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
11066 cgrad        ghalf=0.5d0*ggg2(ll)
11067 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
11068 cd        ghalf=0.0d0
11069         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
11070         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
11071         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
11072         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
11073         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
11074         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
11075       enddo
11076 cd      goto 1112
11077 cgrad      do m=i+1,j-1
11078 cgrad        do ll=1,3
11079 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
11080 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
11081 cgrad        enddo
11082 cgrad      enddo
11083 cgrad      do m=k+1,l-1
11084 cgrad        do ll=1,3
11085 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
11086 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
11087 cgrad        enddo
11088 cgrad      enddo
11089 cgrad1112  continue
11090 cgrad      do m=i+2,j2
11091 cgrad        do ll=1,3
11092 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
11093 cgrad        enddo
11094 cgrad      enddo
11095 cgrad      do m=k+2,l2
11096 cgrad        do ll=1,3
11097 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
11098 cgrad        enddo
11099 cgrad      enddo
11100 cd      do iii=1,nres-3
11101 cd        write (2,*) iii,g_corr6_loc(iii)
11102 cd      enddo
11103       eello6=ekont*eel6
11104 cd      write (2,*) 'ekont',ekont
11105 cd      write (iout,*) 'eello6',ekont*eel6
11106       return
11107       end
11108 c--------------------------------------------------------------------------
11109       double precision function eello6_graph1(i,j,k,l,imat,swap)
11110       implicit real*8 (a-h,o-z)
11111       include 'DIMENSIONS'
11112       include 'COMMON.IOUNITS'
11113       include 'COMMON.CHAIN'
11114       include 'COMMON.DERIV'
11115       include 'COMMON.INTERACT'
11116       include 'COMMON.CONTACTS'
11117       include 'COMMON.CONTMAT'
11118       include 'COMMON.CORRMAT'
11119       include 'COMMON.TORSION'
11120       include 'COMMON.VAR'
11121       include 'COMMON.GEO'
11122       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11123       logical swap
11124       logical lprn
11125       common /kutas/ lprn
11126 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11127 C                                                                              C
11128 C      Parallel       Antiparallel                                             C
11129 C                                                                              C
11130 C          o             o                                                     C
11131 C         /l\           /j\                                                    C
11132 C        /   \         /   \                                                   C
11133 C       /| o |         | o |\                                                  C
11134 C     \ j|/k\|  /   \  |/k\|l /                                                C
11135 C      \ /   \ /     \ /   \ /                                                 C
11136 C       o     o       o     o                                                  C
11137 C       i             i                                                        C
11138 C                                                                              C
11139 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11140       itk=itype2loc(itype(k))
11141       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11142       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11143       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11144       call transpose2(EUgC(1,1,k),auxmat(1,1))
11145       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11146       vv1(1)=pizda1(1,1)-pizda1(2,2)
11147       vv1(2)=pizda1(1,2)+pizda1(2,1)
11148       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11149       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11150       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11151       s5=scalar2(vv(1),Dtobr2(1,i))
11152 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11153       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11154       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11155      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11156      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11157      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11158      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11159      & +scalar2(vv(1),Dtobr2der(1,i)))
11160       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11161       vv1(1)=pizda1(1,1)-pizda1(2,2)
11162       vv1(2)=pizda1(1,2)+pizda1(2,1)
11163       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11164       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11165       if (l.eq.j+1) then
11166         g_corr6_loc(l-1)=g_corr6_loc(l-1)
11167      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11168      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11169      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11170      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11171       else
11172         g_corr6_loc(j-1)=g_corr6_loc(j-1)
11173      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11174      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11175      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11176      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11177       endif
11178       call transpose2(EUgCder(1,1,k),auxmat(1,1))
11179       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11180       vv1(1)=pizda1(1,1)-pizda1(2,2)
11181       vv1(2)=pizda1(1,2)+pizda1(2,1)
11182       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11183      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11184      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11185      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11186       do iii=1,2
11187         if (swap) then
11188           ind=3-iii
11189         else
11190           ind=iii
11191         endif
11192         do kkk=1,5
11193           do lll=1,3
11194             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11195             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11196             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11197             call transpose2(EUgC(1,1,k),auxmat(1,1))
11198             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11199      &        pizda1(1,1))
11200             vv1(1)=pizda1(1,1)-pizda1(2,2)
11201             vv1(2)=pizda1(1,2)+pizda1(2,1)
11202             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11203             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11204      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11205             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11206      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11207             s5=scalar2(vv(1),Dtobr2(1,i))
11208             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11209           enddo
11210         enddo
11211       enddo
11212       return
11213       end
11214 c----------------------------------------------------------------------------
11215       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11216       implicit real*8 (a-h,o-z)
11217       include 'DIMENSIONS'
11218       include 'COMMON.IOUNITS'
11219       include 'COMMON.CHAIN'
11220       include 'COMMON.DERIV'
11221       include 'COMMON.INTERACT'
11222       include 'COMMON.CONTACTS'
11223       include 'COMMON.CONTMAT'
11224       include 'COMMON.CORRMAT'
11225       include 'COMMON.TORSION'
11226       include 'COMMON.VAR'
11227       include 'COMMON.GEO'
11228       logical swap
11229       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11230      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11231       logical lprn
11232       common /kutas/ lprn
11233 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11234 C                                                                              C
11235 C      Parallel       Antiparallel                                             C
11236 C                                                                              C
11237 C          o             o                                                     C
11238 C     \   /l\           /j\   /                                                C
11239 C      \ /   \         /   \ /                                                 C
11240 C       o| o |         | o |o                                                  C
11241 C     \ j|/k\|      \  |/k\|l                                                  C
11242 C      \ /   \       \ /   \                                                   C
11243 C       o             o                                                        C
11244 C       i             i                                                        C
11245 C                                                                              C
11246 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11247 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11248 C AL 7/4/01 s1 would occur in the sixth-order moment,
11249 C           but not in a cluster cumulant
11250 #ifdef MOMENT
11251       s1=dip(1,jj,i)*dip(1,kk,k)
11252 #endif
11253       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11254       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11255       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11256       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11257       call transpose2(EUg(1,1,k),auxmat(1,1))
11258       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11259       vv(1)=pizda(1,1)-pizda(2,2)
11260       vv(2)=pizda(1,2)+pizda(2,1)
11261       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11262 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11263 #ifdef MOMENT
11264       eello6_graph2=-(s1+s2+s3+s4)
11265 #else
11266       eello6_graph2=-(s2+s3+s4)
11267 #endif
11268 c      eello6_graph2=-s3
11269 C Derivatives in gamma(i-1)
11270       if (i.gt.1) then
11271 #ifdef MOMENT
11272         s1=dipderg(1,jj,i)*dip(1,kk,k)
11273 #endif
11274         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11275         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11276         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11277         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11278 #ifdef MOMENT
11279         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11280 #else
11281         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11282 #endif
11283 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11284       endif
11285 C Derivatives in gamma(k-1)
11286 #ifdef MOMENT
11287       s1=dip(1,jj,i)*dipderg(1,kk,k)
11288 #endif
11289       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11290       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11291       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11292       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11293       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11294       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11295       vv(1)=pizda(1,1)-pizda(2,2)
11296       vv(2)=pizda(1,2)+pizda(2,1)
11297       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11298 #ifdef MOMENT
11299       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11300 #else
11301       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11302 #endif
11303 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11304 C Derivatives in gamma(j-1) or gamma(l-1)
11305       if (j.gt.1) then
11306 #ifdef MOMENT
11307         s1=dipderg(3,jj,i)*dip(1,kk,k)
11308 #endif
11309         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11310         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11311         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11312         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11313         vv(1)=pizda(1,1)-pizda(2,2)
11314         vv(2)=pizda(1,2)+pizda(2,1)
11315         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11316 #ifdef MOMENT
11317         if (swap) then
11318           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11319         else
11320           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11321         endif
11322 #endif
11323         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11324 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11325       endif
11326 C Derivatives in gamma(l-1) or gamma(j-1)
11327       if (l.gt.1) then
11328 #ifdef MOMENT
11329         s1=dip(1,jj,i)*dipderg(3,kk,k)
11330 #endif
11331         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11332         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11333         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11334         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11335         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11336         vv(1)=pizda(1,1)-pizda(2,2)
11337         vv(2)=pizda(1,2)+pizda(2,1)
11338         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11339 #ifdef MOMENT
11340         if (swap) then
11341           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11342         else
11343           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11344         endif
11345 #endif
11346         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11347 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11348       endif
11349 C Cartesian derivatives.
11350       if (lprn) then
11351         write (2,*) 'In eello6_graph2'
11352         do iii=1,2
11353           write (2,*) 'iii=',iii
11354           do kkk=1,5
11355             write (2,*) 'kkk=',kkk
11356             do jjj=1,2
11357               write (2,'(3(2f10.5),5x)')
11358      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11359             enddo
11360           enddo
11361         enddo
11362       endif
11363       do iii=1,2
11364         do kkk=1,5
11365           do lll=1,3
11366 #ifdef MOMENT
11367             if (iii.eq.1) then
11368               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11369             else
11370               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11371             endif
11372 #endif
11373             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11374      &        auxvec(1))
11375             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11376             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11377      &        auxvec(1))
11378             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11379             call transpose2(EUg(1,1,k),auxmat(1,1))
11380             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11381      &        pizda(1,1))
11382             vv(1)=pizda(1,1)-pizda(2,2)
11383             vv(2)=pizda(1,2)+pizda(2,1)
11384             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11385 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11386 #ifdef MOMENT
11387             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11388 #else
11389             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11390 #endif
11391             if (swap) then
11392               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11393             else
11394               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11395             endif
11396           enddo
11397         enddo
11398       enddo
11399       return
11400       end
11401 c----------------------------------------------------------------------------
11402       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11403       implicit real*8 (a-h,o-z)
11404       include 'DIMENSIONS'
11405       include 'COMMON.IOUNITS'
11406       include 'COMMON.CHAIN'
11407       include 'COMMON.DERIV'
11408       include 'COMMON.INTERACT'
11409       include 'COMMON.CONTACTS'
11410       include 'COMMON.CONTMAT'
11411       include 'COMMON.CORRMAT'
11412       include 'COMMON.TORSION'
11413       include 'COMMON.VAR'
11414       include 'COMMON.GEO'
11415       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11416       logical swap
11417 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11418 C                                                                              C
11419 C      Parallel       Antiparallel                                             C
11420 C                                                                              C
11421 C          o             o                                                     C
11422 C         /l\   /   \   /j\                                                    C
11423 C        /   \ /     \ /   \                                                   C
11424 C       /| o |o       o| o |\                                                  C
11425 C       j|/k\|  /      |/k\|l /                                                C
11426 C        /   \ /       /   \ /                                                 C
11427 C       /     o       /     o                                                  C
11428 C       i             i                                                        C
11429 C                                                                              C
11430 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11431 C
11432 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11433 C           energy moment and not to the cluster cumulant.
11434       iti=itortyp(itype(i))
11435       if (j.lt.nres-1) then
11436         itj1=itype2loc(itype(j+1))
11437       else
11438         itj1=nloctyp
11439       endif
11440       itk=itype2loc(itype(k))
11441       itk1=itype2loc(itype(k+1))
11442       if (l.lt.nres-1) then
11443         itl1=itype2loc(itype(l+1))
11444       else
11445         itl1=nloctyp
11446       endif
11447 #ifdef MOMENT
11448       s1=dip(4,jj,i)*dip(4,kk,k)
11449 #endif
11450       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11451       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11452       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11453       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11454       call transpose2(EE(1,1,k),auxmat(1,1))
11455       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11456       vv(1)=pizda(1,1)+pizda(2,2)
11457       vv(2)=pizda(2,1)-pizda(1,2)
11458       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11459 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11460 cd     & "sum",-(s2+s3+s4)
11461 #ifdef MOMENT
11462       eello6_graph3=-(s1+s2+s3+s4)
11463 #else
11464       eello6_graph3=-(s2+s3+s4)
11465 #endif
11466 c      eello6_graph3=-s4
11467 C Derivatives in gamma(k-1)
11468       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11469       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11470       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11471       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11472 C Derivatives in gamma(l-1)
11473       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11474       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11475       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11476       vv(1)=pizda(1,1)+pizda(2,2)
11477       vv(2)=pizda(2,1)-pizda(1,2)
11478       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11479       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11480 C Cartesian derivatives.
11481       do iii=1,2
11482         do kkk=1,5
11483           do lll=1,3
11484 #ifdef MOMENT
11485             if (iii.eq.1) then
11486               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11487             else
11488               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11489             endif
11490 #endif
11491             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11492      &        auxvec(1))
11493             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11494             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11495      &        auxvec(1))
11496             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11497             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11498      &        pizda(1,1))
11499             vv(1)=pizda(1,1)+pizda(2,2)
11500             vv(2)=pizda(2,1)-pizda(1,2)
11501             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11502 #ifdef MOMENT
11503             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11504 #else
11505             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11506 #endif
11507             if (swap) then
11508               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11509             else
11510               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11511             endif
11512 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11513           enddo
11514         enddo
11515       enddo
11516       return
11517       end
11518 c----------------------------------------------------------------------------
11519       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11520       implicit real*8 (a-h,o-z)
11521       include 'DIMENSIONS'
11522       include 'COMMON.IOUNITS'
11523       include 'COMMON.CHAIN'
11524       include 'COMMON.DERIV'
11525       include 'COMMON.INTERACT'
11526       include 'COMMON.CONTACTS'
11527       include 'COMMON.CONTMAT'
11528       include 'COMMON.CORRMAT'
11529       include 'COMMON.TORSION'
11530       include 'COMMON.VAR'
11531       include 'COMMON.GEO'
11532       include 'COMMON.FFIELD'
11533       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11534      & auxvec1(2),auxmat1(2,2)
11535       logical swap
11536 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11537 C                                                                              C
11538 C      Parallel       Antiparallel                                             C
11539 C                                                                              C
11540 C          o             o                                                     C
11541 C         /l\   /   \   /j\                                                    C
11542 C        /   \ /     \ /   \                                                   C
11543 C       /| o |o       o| o |\                                                  C
11544 C     \ j|/k\|      \  |/k\|l                                                  C
11545 C      \ /   \       \ /   \                                                   C
11546 C       o     \       o     \                                                  C
11547 C       i             i                                                        C
11548 C                                                                              C
11549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11550 C
11551 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11552 C           energy moment and not to the cluster cumulant.
11553 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11554       iti=itype2loc(itype(i))
11555       itj=itype2loc(itype(j))
11556       if (j.lt.nres-1) then
11557         itj1=itype2loc(itype(j+1))
11558       else
11559         itj1=nloctyp
11560       endif
11561       itk=itype2loc(itype(k))
11562       if (k.lt.nres-1) then
11563         itk1=itype2loc(itype(k+1))
11564       else
11565         itk1=nloctyp
11566       endif
11567       itl=itype2loc(itype(l))
11568       if (l.lt.nres-1) then
11569         itl1=itype2loc(itype(l+1))
11570       else
11571         itl1=nloctyp
11572       endif
11573 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11574 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11575 cd     & ' itl',itl,' itl1',itl1
11576 #ifdef MOMENT
11577       if (imat.eq.1) then
11578         s1=dip(3,jj,i)*dip(3,kk,k)
11579       else
11580         s1=dip(2,jj,j)*dip(2,kk,l)
11581       endif
11582 #endif
11583       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11584       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11585       if (j.eq.l+1) then
11586         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11587         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11588       else
11589         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11590         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11591       endif
11592       call transpose2(EUg(1,1,k),auxmat(1,1))
11593       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11594       vv(1)=pizda(1,1)-pizda(2,2)
11595       vv(2)=pizda(2,1)+pizda(1,2)
11596       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11597 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11598 #ifdef MOMENT
11599       eello6_graph4=-(s1+s2+s3+s4)
11600 #else
11601       eello6_graph4=-(s2+s3+s4)
11602 #endif
11603 C Derivatives in gamma(i-1)
11604       if (i.gt.1) then
11605 #ifdef MOMENT
11606         if (imat.eq.1) then
11607           s1=dipderg(2,jj,i)*dip(3,kk,k)
11608         else
11609           s1=dipderg(4,jj,j)*dip(2,kk,l)
11610         endif
11611 #endif
11612         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11613         if (j.eq.l+1) then
11614           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11615           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11616         else
11617           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11618           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11619         endif
11620         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11621         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11622 cd          write (2,*) 'turn6 derivatives'
11623 #ifdef MOMENT
11624           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11625 #else
11626           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11627 #endif
11628         else
11629 #ifdef MOMENT
11630           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11631 #else
11632           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11633 #endif
11634         endif
11635       endif
11636 C Derivatives in gamma(k-1)
11637 #ifdef MOMENT
11638       if (imat.eq.1) then
11639         s1=dip(3,jj,i)*dipderg(2,kk,k)
11640       else
11641         s1=dip(2,jj,j)*dipderg(4,kk,l)
11642       endif
11643 #endif
11644       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11645       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11646       if (j.eq.l+1) then
11647         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11648         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11649       else
11650         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11651         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11652       endif
11653       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11654       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11655       vv(1)=pizda(1,1)-pizda(2,2)
11656       vv(2)=pizda(2,1)+pizda(1,2)
11657       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11658       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11659 #ifdef MOMENT
11660         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11661 #else
11662         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11663 #endif
11664       else
11665 #ifdef MOMENT
11666         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11667 #else
11668         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11669 #endif
11670       endif
11671 C Derivatives in gamma(j-1) or gamma(l-1)
11672       if (l.eq.j+1 .and. l.gt.1) then
11673         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11674         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11675         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11676         vv(1)=pizda(1,1)-pizda(2,2)
11677         vv(2)=pizda(2,1)+pizda(1,2)
11678         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11679         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11680       else if (j.gt.1) then
11681         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11682         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11683         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11684         vv(1)=pizda(1,1)-pizda(2,2)
11685         vv(2)=pizda(2,1)+pizda(1,2)
11686         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11687         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11688           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11689         else
11690           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11691         endif
11692       endif
11693 C Cartesian derivatives.
11694       do iii=1,2
11695         do kkk=1,5
11696           do lll=1,3
11697 #ifdef MOMENT
11698             if (iii.eq.1) then
11699               if (imat.eq.1) then
11700                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11701               else
11702                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11703               endif
11704             else
11705               if (imat.eq.1) then
11706                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11707               else
11708                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11709               endif
11710             endif
11711 #endif
11712             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11713      &        auxvec(1))
11714             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11715             if (j.eq.l+1) then
11716               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11717      &          b1(1,j+1),auxvec(1))
11718               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11719             else
11720               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11721      &          b1(1,l+1),auxvec(1))
11722               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11723             endif
11724             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11725      &        pizda(1,1))
11726             vv(1)=pizda(1,1)-pizda(2,2)
11727             vv(2)=pizda(2,1)+pizda(1,2)
11728             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11729             if (swap) then
11730               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11731 #ifdef MOMENT
11732                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11733      &             -(s1+s2+s4)
11734 #else
11735                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11736      &             -(s2+s4)
11737 #endif
11738                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11739               else
11740 #ifdef MOMENT
11741                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11742 #else
11743                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11744 #endif
11745                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11746               endif
11747             else
11748 #ifdef MOMENT
11749               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11750 #else
11751               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11752 #endif
11753               if (l.eq.j+1) then
11754                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11755               else
11756                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11757               endif
11758             endif
11759           enddo
11760         enddo
11761       enddo
11762       return
11763       end
11764 c----------------------------------------------------------------------------
11765       double precision function eello_turn6(i,jj,kk)
11766       implicit real*8 (a-h,o-z)
11767       include 'DIMENSIONS'
11768       include 'COMMON.IOUNITS'
11769       include 'COMMON.CHAIN'
11770       include 'COMMON.DERIV'
11771       include 'COMMON.INTERACT'
11772       include 'COMMON.CONTACTS'
11773       include 'COMMON.CONTMAT'
11774       include 'COMMON.CORRMAT'
11775       include 'COMMON.TORSION'
11776       include 'COMMON.VAR'
11777       include 'COMMON.GEO'
11778       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11779      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11780      &  ggg1(3),ggg2(3)
11781       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11782      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11783 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11784 C           the respective energy moment and not to the cluster cumulant.
11785       s1=0.0d0
11786       s8=0.0d0
11787       s13=0.0d0
11788 c
11789       eello_turn6=0.0d0
11790       j=i+4
11791       k=i+1
11792       l=i+3
11793       iti=itype2loc(itype(i))
11794       itk=itype2loc(itype(k))
11795       itk1=itype2loc(itype(k+1))
11796       itl=itype2loc(itype(l))
11797       itj=itype2loc(itype(j))
11798 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11799 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11800 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11801 cd        eello6=0.0d0
11802 cd        return
11803 cd      endif
11804 cd      write (iout,*)
11805 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11806 cd     &   ' and',k,l
11807 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11808       do iii=1,2
11809         do kkk=1,5
11810           do lll=1,3
11811             derx_turn(lll,kkk,iii)=0.0d0
11812           enddo
11813         enddo
11814       enddo
11815 cd      eij=1.0d0
11816 cd      ekl=1.0d0
11817 cd      ekont=1.0d0
11818       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11819 cd      eello6_5=0.0d0
11820 cd      write (2,*) 'eello6_5',eello6_5
11821 #ifdef MOMENT
11822       call transpose2(AEA(1,1,1),auxmat(1,1))
11823       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11824       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11825       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11826 #endif
11827       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11828       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11829       s2 = scalar2(b1(1,k),vtemp1(1))
11830 #ifdef MOMENT
11831       call transpose2(AEA(1,1,2),atemp(1,1))
11832       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11833       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11834       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11835 #endif
11836       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11837       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11838       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11839 #ifdef MOMENT
11840       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11841       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11842       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11843       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11844       ss13 = scalar2(b1(1,k),vtemp4(1))
11845       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11846 #endif
11847 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11848 c      s1=0.0d0
11849 c      s2=0.0d0
11850 c      s8=0.0d0
11851 c      s12=0.0d0
11852 c      s13=0.0d0
11853       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11854 C Derivatives in gamma(i+2)
11855       s1d =0.0d0
11856       s8d =0.0d0
11857 #ifdef MOMENT
11858       call transpose2(AEA(1,1,1),auxmatd(1,1))
11859       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11860       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11861       call transpose2(AEAderg(1,1,2),atempd(1,1))
11862       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11863       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11864 #endif
11865       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11866       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11867       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11868 c      s1d=0.0d0
11869 c      s2d=0.0d0
11870 c      s8d=0.0d0
11871 c      s12d=0.0d0
11872 c      s13d=0.0d0
11873       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11874 C Derivatives in gamma(i+3)
11875 #ifdef MOMENT
11876       call transpose2(AEA(1,1,1),auxmatd(1,1))
11877       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11878       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11879       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11880 #endif
11881       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11882       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11883       s2d = scalar2(b1(1,k),vtemp1d(1))
11884 #ifdef MOMENT
11885       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11886       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11887 #endif
11888       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11889 #ifdef MOMENT
11890       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11891       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11892       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11893 #endif
11894 c      s1d=0.0d0
11895 c      s2d=0.0d0
11896 c      s8d=0.0d0
11897 c      s12d=0.0d0
11898 c      s13d=0.0d0
11899 #ifdef MOMENT
11900       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11901      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11902 #else
11903       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11904      &               -0.5d0*ekont*(s2d+s12d)
11905 #endif
11906 C Derivatives in gamma(i+4)
11907       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11908       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11909       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11910 #ifdef MOMENT
11911       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11912       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11913       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11914 #endif
11915 c      s1d=0.0d0
11916 c      s2d=0.0d0
11917 c      s8d=0.0d0
11918 C      s12d=0.0d0
11919 c      s13d=0.0d0
11920 #ifdef MOMENT
11921       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11922 #else
11923       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11924 #endif
11925 C Derivatives in gamma(i+5)
11926 #ifdef MOMENT
11927       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11928       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11929       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11930 #endif
11931       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11932       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11933       s2d = scalar2(b1(1,k),vtemp1d(1))
11934 #ifdef MOMENT
11935       call transpose2(AEA(1,1,2),atempd(1,1))
11936       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11937       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11938 #endif
11939       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11940       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11941 #ifdef MOMENT
11942       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11943       ss13d = scalar2(b1(1,k),vtemp4d(1))
11944       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11945 #endif
11946 c      s1d=0.0d0
11947 c      s2d=0.0d0
11948 c      s8d=0.0d0
11949 c      s12d=0.0d0
11950 c      s13d=0.0d0
11951 #ifdef MOMENT
11952       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11953      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11954 #else
11955       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11956      &               -0.5d0*ekont*(s2d+s12d)
11957 #endif
11958 C Cartesian derivatives
11959       do iii=1,2
11960         do kkk=1,5
11961           do lll=1,3
11962 #ifdef MOMENT
11963             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11964             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11965             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11966 #endif
11967             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11968             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11969      &          vtemp1d(1))
11970             s2d = scalar2(b1(1,k),vtemp1d(1))
11971 #ifdef MOMENT
11972             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11973             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11974             s8d = -(atempd(1,1)+atempd(2,2))*
11975      &           scalar2(cc(1,1,l),vtemp2(1))
11976 #endif
11977             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11978      &           auxmatd(1,1))
11979             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11980             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11981 c      s1d=0.0d0
11982 c      s2d=0.0d0
11983 c      s8d=0.0d0
11984 c      s12d=0.0d0
11985 c      s13d=0.0d0
11986 #ifdef MOMENT
11987             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11988      &        - 0.5d0*(s1d+s2d)
11989 #else
11990             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11991      &        - 0.5d0*s2d
11992 #endif
11993 #ifdef MOMENT
11994             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11995      &        - 0.5d0*(s8d+s12d)
11996 #else
11997             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11998      &        - 0.5d0*s12d
11999 #endif
12000           enddo
12001         enddo
12002       enddo
12003 #ifdef MOMENT
12004       do kkk=1,5
12005         do lll=1,3
12006           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
12007      &      achuj_tempd(1,1))
12008           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
12009           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
12010           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
12011           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
12012           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
12013      &      vtemp4d(1))
12014           ss13d = scalar2(b1(1,k),vtemp4d(1))
12015           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
12016           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
12017         enddo
12018       enddo
12019 #endif
12020 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
12021 cd     &  16*eel_turn6_num
12022 cd      goto 1112
12023       if (j.lt.nres-1) then
12024         j1=j+1
12025         j2=j-1
12026       else
12027         j1=j-1
12028         j2=j-2
12029       endif
12030       if (l.lt.nres-1) then
12031         l1=l+1
12032         l2=l-1
12033       else
12034         l1=l-1
12035         l2=l-2
12036       endif
12037       do ll=1,3
12038 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
12039 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
12040 cgrad        ghalf=0.5d0*ggg1(ll)
12041 cd        ghalf=0.0d0
12042         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
12043         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
12044         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
12045      &    +ekont*derx_turn(ll,2,1)
12046         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
12047         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
12048      &    +ekont*derx_turn(ll,4,1)
12049         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
12050         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
12051         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
12052 cgrad        ghalf=0.5d0*ggg2(ll)
12053 cd        ghalf=0.0d0
12054         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
12055      &    +ekont*derx_turn(ll,2,2)
12056         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
12057         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
12058      &    +ekont*derx_turn(ll,4,2)
12059         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
12060         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
12061         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
12062       enddo
12063 cd      goto 1112
12064 cgrad      do m=i+1,j-1
12065 cgrad        do ll=1,3
12066 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
12067 cgrad        enddo
12068 cgrad      enddo
12069 cgrad      do m=k+1,l-1
12070 cgrad        do ll=1,3
12071 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
12072 cgrad        enddo
12073 cgrad      enddo
12074 cgrad1112  continue
12075 cgrad      do m=i+2,j2
12076 cgrad        do ll=1,3
12077 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
12078 cgrad        enddo
12079 cgrad      enddo
12080 cgrad      do m=k+2,l2
12081 cgrad        do ll=1,3
12082 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
12083 cgrad        enddo
12084 cgrad      enddo
12085 cd      do iii=1,nres-3
12086 cd        write (2,*) iii,g_corr6_loc(iii)
12087 cd      enddo
12088       eello_turn6=ekont*eel_turn6
12089 cd      write (2,*) 'ekont',ekont
12090 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
12091       return
12092       end
12093 C-----------------------------------------------------------------------------
12094 #endif
12095       double precision function scalar(u,v)
12096 !DIR$ INLINEALWAYS scalar
12097 #ifndef OSF
12098 cDEC$ ATTRIBUTES FORCEINLINE::scalar
12099 #endif
12100       implicit none
12101       double precision u(3),v(3)
12102 cd      double precision sc
12103 cd      integer i
12104 cd      sc=0.0d0
12105 cd      do i=1,3
12106 cd        sc=sc+u(i)*v(i)
12107 cd      enddo
12108 cd      scalar=sc
12109
12110       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12111       return
12112       end
12113 crc-------------------------------------------------
12114       SUBROUTINE MATVEC2(A1,V1,V2)
12115 !DIR$ INLINEALWAYS MATVEC2
12116 #ifndef OSF
12117 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12118 #endif
12119       implicit real*8 (a-h,o-z)
12120       include 'DIMENSIONS'
12121       DIMENSION A1(2,2),V1(2),V2(2)
12122 c      DO 1 I=1,2
12123 c        VI=0.0
12124 c        DO 3 K=1,2
12125 c    3     VI=VI+A1(I,K)*V1(K)
12126 c        Vaux(I)=VI
12127 c    1 CONTINUE
12128
12129       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12130       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12131
12132       v2(1)=vaux1
12133       v2(2)=vaux2
12134       END
12135 C---------------------------------------
12136       SUBROUTINE MATMAT2(A1,A2,A3)
12137 #ifndef OSF
12138 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12139 #endif
12140       implicit real*8 (a-h,o-z)
12141       include 'DIMENSIONS'
12142       DIMENSION A1(2,2),A2(2,2),A3(2,2)
12143 c      DIMENSION AI3(2,2)
12144 c        DO  J=1,2
12145 c          A3IJ=0.0
12146 c          DO K=1,2
12147 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
12148 c          enddo
12149 c          A3(I,J)=A3IJ
12150 c       enddo
12151 c      enddo
12152
12153       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12154       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12155       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12156       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12157
12158       A3(1,1)=AI3_11
12159       A3(2,1)=AI3_21
12160       A3(1,2)=AI3_12
12161       A3(2,2)=AI3_22
12162       END
12163
12164 c-------------------------------------------------------------------------
12165       double precision function scalar2(u,v)
12166 !DIR$ INLINEALWAYS scalar2
12167       implicit none
12168       double precision u(2),v(2)
12169       double precision sc
12170       integer i
12171       scalar2=u(1)*v(1)+u(2)*v(2)
12172       return
12173       end
12174
12175 C-----------------------------------------------------------------------------
12176
12177       subroutine transpose2(a,at)
12178 !DIR$ INLINEALWAYS transpose2
12179 #ifndef OSF
12180 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12181 #endif
12182       implicit none
12183       double precision a(2,2),at(2,2)
12184       at(1,1)=a(1,1)
12185       at(1,2)=a(2,1)
12186       at(2,1)=a(1,2)
12187       at(2,2)=a(2,2)
12188       return
12189       end
12190 c--------------------------------------------------------------------------
12191       subroutine transpose(n,a,at)
12192       implicit none
12193       integer n,i,j
12194       double precision a(n,n),at(n,n)
12195       do i=1,n
12196         do j=1,n
12197           at(j,i)=a(i,j)
12198         enddo
12199       enddo
12200       return
12201       end
12202 C---------------------------------------------------------------------------
12203       subroutine prodmat3(a1,a2,kk,transp,prod)
12204 !DIR$ INLINEALWAYS prodmat3
12205 #ifndef OSF
12206 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12207 #endif
12208       implicit none
12209       integer i,j
12210       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12211       logical transp
12212 crc      double precision auxmat(2,2),prod_(2,2)
12213
12214       if (transp) then
12215 crc        call transpose2(kk(1,1),auxmat(1,1))
12216 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12217 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12218
12219            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12220      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12221            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12222      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12223            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12224      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12225            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12226      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12227
12228       else
12229 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12230 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12231
12232            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12233      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12234            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12235      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12236            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12237      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12238            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12239      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12240
12241       endif
12242 c      call transpose2(a2(1,1),a2t(1,1))
12243
12244 crc      print *,transp
12245 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12246 crc      print *,((prod(i,j),i=1,2),j=1,2)
12247
12248       return
12249       end
12250 CCC----------------------------------------------
12251       subroutine Eliptransfer(eliptran)
12252       implicit real*8 (a-h,o-z)
12253       include 'DIMENSIONS'
12254       include 'COMMON.GEO'
12255       include 'COMMON.VAR'
12256       include 'COMMON.LOCAL'
12257       include 'COMMON.CHAIN'
12258       include 'COMMON.DERIV'
12259       include 'COMMON.NAMES'
12260       include 'COMMON.INTERACT'
12261       include 'COMMON.IOUNITS'
12262       include 'COMMON.CALC'
12263       include 'COMMON.CONTROL'
12264       include 'COMMON.SPLITELE'
12265       include 'COMMON.SBRIDGE'
12266 C this is done by Adasko
12267 C      print *,"wchodze"
12268 C structure of box:
12269 C      water
12270 C--bordliptop-- buffore starts
12271 C--bufliptop--- here true lipid starts
12272 C      lipid
12273 C--buflipbot--- lipid ends buffore starts
12274 C--bordlipbot--buffore ends
12275       eliptran=0.0
12276       do i=ilip_start,ilip_end
12277 C       do i=1,1
12278         if (itype(i).eq.ntyp1) cycle
12279
12280         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12281         if (positi.le.0.0) positi=positi+boxzsize
12282 C        print *,i
12283 C first for peptide groups
12284 c for each residue check if it is in lipid or lipid water border area
12285        if ((positi.gt.bordlipbot)
12286      &.and.(positi.lt.bordliptop)) then
12287 C the energy transfer exist
12288         if (positi.lt.buflipbot) then
12289 C what fraction I am in
12290          fracinbuf=1.0d0-
12291      &        ((positi-bordlipbot)/lipbufthick)
12292 C lipbufthick is thickenes of lipid buffore
12293          sslip=sscalelip(fracinbuf)
12294          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12295          eliptran=eliptran+sslip*pepliptran
12296          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12297          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12298 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12299
12300 C        print *,"doing sccale for lower part"
12301 C         print *,i,sslip,fracinbuf,ssgradlip
12302         elseif (positi.gt.bufliptop) then
12303          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12304          sslip=sscalelip(fracinbuf)
12305          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12306          eliptran=eliptran+sslip*pepliptran
12307          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12308          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12309 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12310 C          print *, "doing sscalefor top part"
12311 C         print *,i,sslip,fracinbuf,ssgradlip
12312         else
12313          eliptran=eliptran+pepliptran
12314 C         print *,"I am in true lipid"
12315         endif
12316 C       else
12317 C       eliptran=elpitran+0.0 ! I am in water
12318        endif
12319        enddo
12320 C       print *, "nic nie bylo w lipidzie?"
12321 C now multiply all by the peptide group transfer factor
12322 C       eliptran=eliptran*pepliptran
12323 C now the same for side chains
12324 CV       do i=1,1
12325        do i=ilip_start,ilip_end
12326         if (itype(i).eq.ntyp1) cycle
12327         positi=(mod(c(3,i+nres),boxzsize))
12328         if (positi.le.0) positi=positi+boxzsize
12329 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12330 c for each residue check if it is in lipid or lipid water border area
12331 C       respos=mod(c(3,i+nres),boxzsize)
12332 C       print *,positi,bordlipbot,buflipbot
12333        if ((positi.gt.bordlipbot)
12334      & .and.(positi.lt.bordliptop)) then
12335 C the energy transfer exist
12336         if (positi.lt.buflipbot) then
12337          fracinbuf=1.0d0-
12338      &     ((positi-bordlipbot)/lipbufthick)
12339 C lipbufthick is thickenes of lipid buffore
12340          sslip=sscalelip(fracinbuf)
12341          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12342          eliptran=eliptran+sslip*liptranene(itype(i))
12343          gliptranx(3,i)=gliptranx(3,i)
12344      &+ssgradlip*liptranene(itype(i))
12345          gliptranc(3,i-1)= gliptranc(3,i-1)
12346      &+ssgradlip*liptranene(itype(i))
12347 C         print *,"doing sccale for lower part"
12348         elseif (positi.gt.bufliptop) then
12349          fracinbuf=1.0d0-
12350      &((bordliptop-positi)/lipbufthick)
12351          sslip=sscalelip(fracinbuf)
12352          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12353          eliptran=eliptran+sslip*liptranene(itype(i))
12354          gliptranx(3,i)=gliptranx(3,i)
12355      &+ssgradlip*liptranene(itype(i))
12356          gliptranc(3,i-1)= gliptranc(3,i-1)
12357      &+ssgradlip*liptranene(itype(i))
12358 C          print *, "doing sscalefor top part",sslip,fracinbuf
12359         else
12360          eliptran=eliptran+liptranene(itype(i))
12361 C         print *,"I am in true lipid"
12362         endif
12363         endif ! if in lipid or buffor
12364 C       else
12365 C       eliptran=elpitran+0.0 ! I am in water
12366        enddo
12367        return
12368        end
12369 C---------------------------------------------------------
12370 C AFM soubroutine for constant force
12371        subroutine AFMforce(Eafmforce)
12372        implicit real*8 (a-h,o-z)
12373       include 'DIMENSIONS'
12374       include 'COMMON.GEO'
12375       include 'COMMON.VAR'
12376       include 'COMMON.LOCAL'
12377       include 'COMMON.CHAIN'
12378       include 'COMMON.DERIV'
12379       include 'COMMON.NAMES'
12380       include 'COMMON.INTERACT'
12381       include 'COMMON.IOUNITS'
12382       include 'COMMON.CALC'
12383       include 'COMMON.CONTROL'
12384       include 'COMMON.SPLITELE'
12385       include 'COMMON.SBRIDGE'
12386       real*8 diffafm(3)
12387       dist=0.0d0
12388       Eafmforce=0.0d0
12389       do i=1,3
12390       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12391       dist=dist+diffafm(i)**2
12392       enddo
12393       dist=dsqrt(dist)
12394       Eafmforce=-forceAFMconst*(dist-distafminit)
12395       do i=1,3
12396       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12397       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12398       enddo
12399 C      print *,'AFM',Eafmforce
12400       return
12401       end
12402 C---------------------------------------------------------
12403 C AFM subroutine with pseudoconstant velocity
12404        subroutine AFMvel(Eafmforce)
12405        implicit real*8 (a-h,o-z)
12406       include 'DIMENSIONS'
12407       include 'COMMON.GEO'
12408       include 'COMMON.VAR'
12409       include 'COMMON.LOCAL'
12410       include 'COMMON.CHAIN'
12411       include 'COMMON.DERIV'
12412       include 'COMMON.NAMES'
12413       include 'COMMON.INTERACT'
12414       include 'COMMON.IOUNITS'
12415       include 'COMMON.CALC'
12416       include 'COMMON.CONTROL'
12417       include 'COMMON.SPLITELE'
12418       include 'COMMON.SBRIDGE'
12419       real*8 diffafm(3)
12420 C Only for check grad COMMENT if not used for checkgrad
12421 C      totT=3.0d0
12422 C--------------------------------------------------------
12423 C      print *,"wchodze"
12424       dist=0.0d0
12425       Eafmforce=0.0d0
12426       do i=1,3
12427       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12428       dist=dist+diffafm(i)**2
12429       enddo
12430       dist=dsqrt(dist)
12431       Eafmforce=0.5d0*forceAFMconst
12432      & *(distafminit+totTafm*velAFMconst-dist)**2
12433 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12434       do i=1,3
12435       gradafm(i,afmend-1)=-forceAFMconst*
12436      &(distafminit+totTafm*velAFMconst-dist)
12437      &*diffafm(i)/dist
12438       gradafm(i,afmbeg-1)=forceAFMconst*
12439      &(distafminit+totTafm*velAFMconst-dist)
12440      &*diffafm(i)/dist
12441       enddo
12442 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12443       return
12444       end
12445 C-----------------------------------------------------------
12446 C first for shielding is setting of function of side-chains
12447        subroutine set_shield_fac
12448       implicit real*8 (a-h,o-z)
12449       include 'DIMENSIONS'
12450       include 'COMMON.CHAIN'
12451       include 'COMMON.DERIV'
12452       include 'COMMON.IOUNITS'
12453       include 'COMMON.SHIELD'
12454       include 'COMMON.INTERACT'
12455 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12456       double precision div77_81/0.974996043d0/,
12457      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12458
12459 C the vector between center of side_chain and peptide group
12460        double precision pep_side(3),long,side_calf(3),
12461      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12462      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12463 C the line belowe needs to be changed for FGPROC>1
12464       do i=1,nres-1
12465       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12466       ishield_list(i)=0
12467 Cif there two consequtive dummy atoms there is no peptide group between them
12468 C the line below has to be changed for FGPROC>1
12469       VolumeTotal=0.0
12470       do k=1,nres
12471        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12472        dist_pep_side=0.0
12473        dist_side_calf=0.0
12474        do j=1,3
12475 C first lets set vector conecting the ithe side-chain with kth side-chain
12476       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12477 C      pep_side(j)=2.0d0
12478 C and vector conecting the side-chain with its proper calfa
12479       side_calf(j)=c(j,k+nres)-c(j,k)
12480 C      side_calf(j)=2.0d0
12481       pept_group(j)=c(j,i)-c(j,i+1)
12482 C lets have their lenght
12483       dist_pep_side=pep_side(j)**2+dist_pep_side
12484       dist_side_calf=dist_side_calf+side_calf(j)**2
12485       dist_pept_group=dist_pept_group+pept_group(j)**2
12486       enddo
12487        dist_pep_side=dsqrt(dist_pep_side)
12488        dist_pept_group=dsqrt(dist_pept_group)
12489        dist_side_calf=dsqrt(dist_side_calf)
12490       do j=1,3
12491         pep_side_norm(j)=pep_side(j)/dist_pep_side
12492         side_calf_norm(j)=dist_side_calf
12493       enddo
12494 C now sscale fraction
12495        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12496 C       print *,buff_shield,"buff"
12497 C now sscale
12498         if (sh_frac_dist.le.0.0) cycle
12499 C If we reach here it means that this side chain reaches the shielding sphere
12500 C Lets add him to the list for gradient
12501         ishield_list(i)=ishield_list(i)+1
12502 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12503 C this list is essential otherwise problem would be O3
12504         shield_list(ishield_list(i),i)=k
12505 C Lets have the sscale value
12506         if (sh_frac_dist.gt.1.0) then
12507          scale_fac_dist=1.0d0
12508          do j=1,3
12509          sh_frac_dist_grad(j)=0.0d0
12510          enddo
12511         else
12512          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12513      &                   *(2.0*sh_frac_dist-3.0d0)
12514          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12515      &                  /dist_pep_side/buff_shield*0.5
12516 C remember for the final gradient multiply sh_frac_dist_grad(j)
12517 C for side_chain by factor -2 !
12518          do j=1,3
12519          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12520 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12521 C     &                    sh_frac_dist_grad(j)
12522          enddo
12523         endif
12524 C        if ((i.eq.3).and.(k.eq.2)) then
12525 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12526 C     & ,"TU"
12527 C        endif
12528
12529 C this is what is now we have the distance scaling now volume...
12530       short=short_r_sidechain(itype(k))
12531       long=long_r_sidechain(itype(k))
12532       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12533 C now costhet_grad
12534 C       costhet=0.0d0
12535        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12536 C       costhet_fac=0.0d0
12537        do j=1,3
12538          costhet_grad(j)=costhet_fac*pep_side(j)
12539        enddo
12540 C remember for the final gradient multiply costhet_grad(j)
12541 C for side_chain by factor -2 !
12542 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12543 C pep_side0pept_group is vector multiplication
12544       pep_side0pept_group=0.0
12545       do j=1,3
12546       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12547       enddo
12548       cosalfa=(pep_side0pept_group/
12549      & (dist_pep_side*dist_side_calf))
12550       fac_alfa_sin=1.0-cosalfa**2
12551       fac_alfa_sin=dsqrt(fac_alfa_sin)
12552       rkprim=fac_alfa_sin*(long-short)+short
12553 C now costhet_grad
12554        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12555        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12556
12557        do j=1,3
12558          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12559      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12560      &*(long-short)/fac_alfa_sin*cosalfa/
12561      &((dist_pep_side*dist_side_calf))*
12562      &((side_calf(j))-cosalfa*
12563      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12564
12565         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12566      &*(long-short)/fac_alfa_sin*cosalfa
12567      &/((dist_pep_side*dist_side_calf))*
12568      &(pep_side(j)-
12569      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12570        enddo
12571
12572       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12573      &                    /VSolvSphere_div
12574      &                    *wshield
12575 C now the gradient...
12576 C grad_shield is gradient of Calfa for peptide groups
12577 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12578 C     &               costhet,cosphi
12579 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12580 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12581       do j=1,3
12582       grad_shield(j,i)=grad_shield(j,i)
12583 C gradient po skalowaniu
12584      &                +(sh_frac_dist_grad(j)
12585 C  gradient po costhet
12586      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12587      &-scale_fac_dist*(cosphi_grad_long(j))
12588      &/(1.0-cosphi) )*div77_81
12589      &*VofOverlap
12590 C grad_shield_side is Cbeta sidechain gradient
12591       grad_shield_side(j,ishield_list(i),i)=
12592      &        (sh_frac_dist_grad(j)*(-2.0d0)
12593      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12594      &       +scale_fac_dist*(cosphi_grad_long(j))
12595      &        *2.0d0/(1.0-cosphi))
12596      &        *div77_81*VofOverlap
12597
12598        grad_shield_loc(j,ishield_list(i),i)=
12599      &   scale_fac_dist*cosphi_grad_loc(j)
12600      &        *2.0d0/(1.0-cosphi)
12601      &        *div77_81*VofOverlap
12602       enddo
12603       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12604       enddo
12605       fac_shield(i)=VolumeTotal*div77_81+div4_81
12606 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12607       enddo
12608       return
12609       end
12610 C--------------------------------------------------------------------------
12611       double precision function tschebyshev(m,n,x,y)
12612       implicit none
12613       include "DIMENSIONS"
12614       integer i,m,n
12615       double precision x(n),y,yy(0:maxvar),aux
12616 c Tschebyshev polynomial. Note that the first term is omitted
12617 c m=0: the constant term is included
12618 c m=1: the constant term is not included
12619       yy(0)=1.0d0
12620       yy(1)=y
12621       do i=2,n
12622         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12623       enddo
12624       aux=0.0d0
12625       do i=m,n
12626         aux=aux+x(i)*yy(i)
12627       enddo
12628       tschebyshev=aux
12629       return
12630       end
12631 C--------------------------------------------------------------------------
12632       double precision function gradtschebyshev(m,n,x,y)
12633       implicit none
12634       include "DIMENSIONS"
12635       integer i,m,n
12636       double precision x(n+1),y,yy(0:maxvar),aux
12637 c Tschebyshev polynomial. Note that the first term is omitted
12638 c m=0: the constant term is included
12639 c m=1: the constant term is not included
12640       yy(0)=1.0d0
12641       yy(1)=2.0d0*y
12642       do i=2,n
12643         yy(i)=2*y*yy(i-1)-yy(i-2)
12644       enddo
12645       aux=0.0d0
12646       do i=m,n
12647         aux=aux+x(i+1)*yy(i)*(i+1)
12648 C        print *, x(i+1),yy(i),i
12649       enddo
12650       gradtschebyshev=aux
12651       return
12652       end
12653 C------------------------------------------------------------------------
12654 C first for shielding is setting of function of side-chains
12655        subroutine set_shield_fac2
12656       implicit real*8 (a-h,o-z)
12657       include 'DIMENSIONS'
12658       include 'COMMON.CHAIN'
12659       include 'COMMON.DERIV'
12660       include 'COMMON.IOUNITS'
12661       include 'COMMON.SHIELD'
12662       include 'COMMON.INTERACT'
12663 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12664       double precision div77_81/0.974996043d0/,
12665      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12666
12667 C the vector between center of side_chain and peptide group
12668        double precision pep_side(3),long,side_calf(3),
12669      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12670      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12671 C the line belowe needs to be changed for FGPROC>1
12672       do i=1,nres-1
12673       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12674       ishield_list(i)=0
12675 Cif there two consequtive dummy atoms there is no peptide group between them
12676 C the line below has to be changed for FGPROC>1
12677       VolumeTotal=0.0
12678       do k=1,nres
12679        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12680        dist_pep_side=0.0
12681        dist_side_calf=0.0
12682        do j=1,3
12683 C first lets set vector conecting the ithe side-chain with kth side-chain
12684       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12685 C      pep_side(j)=2.0d0
12686 C and vector conecting the side-chain with its proper calfa
12687       side_calf(j)=c(j,k+nres)-c(j,k)
12688 C      side_calf(j)=2.0d0
12689       pept_group(j)=c(j,i)-c(j,i+1)
12690 C lets have their lenght
12691       dist_pep_side=pep_side(j)**2+dist_pep_side
12692       dist_side_calf=dist_side_calf+side_calf(j)**2
12693       dist_pept_group=dist_pept_group+pept_group(j)**2
12694       enddo
12695        dist_pep_side=dsqrt(dist_pep_side)
12696        dist_pept_group=dsqrt(dist_pept_group)
12697        dist_side_calf=dsqrt(dist_side_calf)
12698       do j=1,3
12699         pep_side_norm(j)=pep_side(j)/dist_pep_side
12700         side_calf_norm(j)=dist_side_calf
12701       enddo
12702 C now sscale fraction
12703        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12704 C       print *,buff_shield,"buff"
12705 C now sscale
12706         if (sh_frac_dist.le.0.0) cycle
12707 C If we reach here it means that this side chain reaches the shielding sphere
12708 C Lets add him to the list for gradient
12709         ishield_list(i)=ishield_list(i)+1
12710 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12711 C this list is essential otherwise problem would be O3
12712         shield_list(ishield_list(i),i)=k
12713 C Lets have the sscale value
12714         if (sh_frac_dist.gt.1.0) then
12715          scale_fac_dist=1.0d0
12716          do j=1,3
12717          sh_frac_dist_grad(j)=0.0d0
12718          enddo
12719         else
12720          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12721      &                   *(2.0d0*sh_frac_dist-3.0d0)
12722          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12723      &                  /dist_pep_side/buff_shield*0.5d0
12724 C remember for the final gradient multiply sh_frac_dist_grad(j)
12725 C for side_chain by factor -2 !
12726          do j=1,3
12727          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12728 C         sh_frac_dist_grad(j)=0.0d0
12729 C         scale_fac_dist=1.0d0
12730 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12731 C     &                    sh_frac_dist_grad(j)
12732          enddo
12733         endif
12734 C this is what is now we have the distance scaling now volume...
12735       short=short_r_sidechain(itype(k))
12736       long=long_r_sidechain(itype(k))
12737       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12738       sinthet=short/dist_pep_side*costhet
12739 C now costhet_grad
12740 C       costhet=0.6d0
12741 C       sinthet=0.8
12742        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12743 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12744 C     &             -short/dist_pep_side**2/costhet)
12745 C       costhet_fac=0.0d0
12746        do j=1,3
12747          costhet_grad(j)=costhet_fac*pep_side(j)
12748        enddo
12749 C remember for the final gradient multiply costhet_grad(j)
12750 C for side_chain by factor -2 !
12751 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12752 C pep_side0pept_group is vector multiplication
12753       pep_side0pept_group=0.0d0
12754       do j=1,3
12755       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12756       enddo
12757       cosalfa=(pep_side0pept_group/
12758      & (dist_pep_side*dist_side_calf))
12759       fac_alfa_sin=1.0d0-cosalfa**2
12760       fac_alfa_sin=dsqrt(fac_alfa_sin)
12761       rkprim=fac_alfa_sin*(long-short)+short
12762 C      rkprim=short
12763
12764 C now costhet_grad
12765        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12766 C       cosphi=0.6
12767        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12768        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12769      &      dist_pep_side**2)
12770 C       sinphi=0.8
12771        do j=1,3
12772          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12773      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12774      &*(long-short)/fac_alfa_sin*cosalfa/
12775      &((dist_pep_side*dist_side_calf))*
12776      &((side_calf(j))-cosalfa*
12777      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12778 C       cosphi_grad_long(j)=0.0d0
12779         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12780      &*(long-short)/fac_alfa_sin*cosalfa
12781      &/((dist_pep_side*dist_side_calf))*
12782      &(pep_side(j)-
12783      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12784 C       cosphi_grad_loc(j)=0.0d0
12785        enddo
12786 C      print *,sinphi,sinthet
12787 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12788 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12789       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12790      &                    /VSolvSphere_div
12791 C     &                    *wshield
12792 C now the gradient...
12793       do j=1,3
12794       grad_shield(j,i)=grad_shield(j,i)
12795 C gradient po skalowaniu
12796      &                +(sh_frac_dist_grad(j)*VofOverlap
12797 C  gradient po costhet
12798      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12799      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12800      &       sinphi/sinthet*costhet*costhet_grad(j)
12801      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12802      & )*wshield
12803 C grad_shield_side is Cbeta sidechain gradient
12804       grad_shield_side(j,ishield_list(i),i)=
12805      &        (sh_frac_dist_grad(j)*(-2.0d0)
12806      &        *VofOverlap
12807      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12808      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12809      &       sinphi/sinthet*costhet*costhet_grad(j)
12810      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12811      &       )*wshield
12812
12813        grad_shield_loc(j,ishield_list(i),i)=
12814      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12815      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12816      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12817      &        ))
12818      &        *wshield
12819       enddo
12820 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12821 c     & scale_fac_dist
12822       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12823       enddo
12824       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12825 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12826 c     &  " wshield",wshield
12827 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12828       enddo
12829       return
12830       end
12831 C-----------------------------------------------------------------------
12832 C-----------------------------------------------------------
12833 C This subroutine is to mimic the histone like structure but as well can be
12834 C utilizet to nanostructures (infinit) small modification has to be used to
12835 C make it finite (z gradient at the ends has to be changes as well as the x,y
12836 C gradient has to be modified at the ends
12837 C The energy function is Kihara potential
12838 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12839 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12840 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12841 C simple Kihara potential
12842       subroutine calctube(Etube)
12843        implicit real*8 (a-h,o-z)
12844       include 'DIMENSIONS'
12845       include 'COMMON.GEO'
12846       include 'COMMON.VAR'
12847       include 'COMMON.LOCAL'
12848       include 'COMMON.CHAIN'
12849       include 'COMMON.DERIV'
12850       include 'COMMON.NAMES'
12851       include 'COMMON.INTERACT'
12852       include 'COMMON.IOUNITS'
12853       include 'COMMON.CALC'
12854       include 'COMMON.CONTROL'
12855       include 'COMMON.SPLITELE'
12856       include 'COMMON.SBRIDGE'
12857       double precision tub_r,vectube(3),enetube(maxres*2)
12858       Etube=0.0d0
12859       do i=1,2*nres
12860         enetube(i)=0.0d0
12861       enddo
12862 C first we calculate the distance from tube center
12863 C first sugare-phosphate group for NARES this would be peptide group
12864 C for UNRES
12865       do i=1,nres
12866 C lets ommit dummy atoms for now
12867        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12868 C now calculate distance from center of tube and direction vectors
12869       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12870           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12871       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12872           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12873       vectube(1)=vectube(1)-tubecenter(1)
12874       vectube(2)=vectube(2)-tubecenter(2)
12875
12876 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12877 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,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        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12893 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12894 C       print *,rdiff,rdiff6,pep_aa_tube
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*pep_aa_tube/rdiff6+
12898      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12899 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12900 C     &rdiff,fac
12901
12902 C now direction of gg_tube vector
12903         do j=1,3
12904         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12905         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12906         enddo
12907         enddo
12908 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12909         do i=1,nres
12910 C Lets not jump over memory as we use many times iti
12911          iti=itype(i)
12912 C lets ommit dummy atoms for now
12913          if ((iti.eq.ntyp1)
12914 C in UNRES uncomment the line below as GLY has no side-chain...
12915 C      .or.(iti.eq.10)
12916      &   ) cycle
12917           vectube(1)=c(1,i+nres)
12918           vectube(1)=mod(vectube(1),boxxsize)
12919           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12920           vectube(2)=c(2,i+nres)
12921           vectube(2)=mod(vectube(2),boxxsize)
12922           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12923
12924       vectube(1)=vectube(1)-tubecenter(1)
12925       vectube(2)=vectube(2)-tubecenter(2)
12926
12927 C as the tube is infinity we do not calculate the Z-vector use of Z
12928 C as chosen axis
12929       vectube(3)=0.0d0
12930 C now calculte the distance
12931        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12932 C now normalize vector
12933       vectube(1)=vectube(1)/tub_r
12934       vectube(2)=vectube(2)/tub_r
12935 C calculte rdiffrence between r and r0
12936       rdiff=tub_r-tubeR0
12937 C and its 6 power
12938       rdiff6=rdiff**6.0d0
12939 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12940        sc_aa_tube=sc_aa_tube_par(iti)
12941        sc_bb_tube=sc_bb_tube_par(iti)
12942        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12943 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12944 C now we calculate gradient
12945        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12946      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12947 C now direction of gg_tube vector
12948          do j=1,3
12949           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12950           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12951          enddo
12952         enddo
12953         do i=1,2*nres
12954           Etube=Etube+enetube(i)
12955         enddo
12956 C        print *,"ETUBE", etube
12957         return
12958         end
12959 C TO DO 1) add to total energy
12960 C       2) add to gradient summation
12961 C       3) add reading parameters (AND of course oppening of PARAM file)
12962 C       4) add reading the center of tube
12963 C       5) add COMMONs
12964 C       6) add to zerograd
12965
12966 C-----------------------------------------------------------------------
12967 C-----------------------------------------------------------
12968 C This subroutine is to mimic the histone like structure but as well can be
12969 C utilizet to nanostructures (infinit) small modification has to be used to
12970 C make it finite (z gradient at the ends has to be changes as well as the x,y
12971 C gradient has to be modified at the ends
12972 C The energy function is Kihara potential
12973 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12974 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12975 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12976 C simple Kihara potential
12977       subroutine calctube2(Etube)
12978        implicit real*8 (a-h,o-z)
12979       include 'DIMENSIONS'
12980       include 'COMMON.GEO'
12981       include 'COMMON.VAR'
12982       include 'COMMON.LOCAL'
12983       include 'COMMON.CHAIN'
12984       include 'COMMON.DERIV'
12985       include 'COMMON.NAMES'
12986       include 'COMMON.INTERACT'
12987       include 'COMMON.IOUNITS'
12988       include 'COMMON.CALC'
12989       include 'COMMON.CONTROL'
12990       include 'COMMON.SPLITELE'
12991       include 'COMMON.SBRIDGE'
12992       double precision tub_r,vectube(3),enetube(maxres*2)
12993       Etube=0.0d0
12994       do i=1,2*nres
12995         enetube(i)=0.0d0
12996       enddo
12997 C first we calculate the distance from tube center
12998 C first sugare-phosphate group for NARES this would be peptide group
12999 C for UNRES
13000       do i=1,nres
13001 C lets ommit dummy atoms for now
13002        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
13003 C now calculate distance from center of tube and direction vectors
13004       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
13005           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
13006       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
13007           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
13008       vectube(1)=vectube(1)-tubecenter(1)
13009       vectube(2)=vectube(2)-tubecenter(2)
13010
13011 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
13012 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
13013
13014 C as the tube is infinity we do not calculate the Z-vector use of Z
13015 C as chosen axis
13016       vectube(3)=0.0d0
13017 C now calculte the distance
13018        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13019 C now normalize vector
13020       vectube(1)=vectube(1)/tub_r
13021       vectube(2)=vectube(2)/tub_r
13022 C calculte rdiffrence between r and r0
13023       rdiff=tub_r-tubeR0
13024 C and its 6 power
13025       rdiff6=rdiff**6.0d0
13026 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13027        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
13028 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
13029 C       print *,rdiff,rdiff6,pep_aa_tube
13030 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13031 C now we calculate gradient
13032        fac=(-12.0d0*pep_aa_tube/rdiff6+
13033      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
13034 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
13035 C     &rdiff,fac
13036
13037 C now direction of gg_tube vector
13038         do j=1,3
13039         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
13040         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
13041         enddo
13042         enddo
13043 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
13044         do i=1,nres
13045 C Lets not jump over memory as we use many times iti
13046          iti=itype(i)
13047 C lets ommit dummy atoms for now
13048          if ((iti.eq.ntyp1)
13049 C in UNRES uncomment the line below as GLY has no side-chain...
13050      &      .or.(iti.eq.10)
13051      &   ) cycle
13052           vectube(1)=c(1,i+nres)
13053           vectube(1)=mod(vectube(1),boxxsize)
13054           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
13055           vectube(2)=c(2,i+nres)
13056           vectube(2)=mod(vectube(2),boxxsize)
13057           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
13058
13059       vectube(1)=vectube(1)-tubecenter(1)
13060       vectube(2)=vectube(2)-tubecenter(2)
13061 C THIS FRAGMENT MAKES TUBE FINITE
13062         positi=(mod(c(3,i+nres),boxzsize))
13063         if (positi.le.0) positi=positi+boxzsize
13064 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
13065 c for each residue check if it is in lipid or lipid water border area
13066 C       respos=mod(c(3,i+nres),boxzsize)
13067        print *,positi,bordtubebot,buftubebot,bordtubetop
13068        if ((positi.gt.bordtubebot)
13069      & .and.(positi.lt.bordtubetop)) then
13070 C the energy transfer exist
13071         if (positi.lt.buftubebot) then
13072          fracinbuf=1.0d0-
13073      &     ((positi-bordtubebot)/tubebufthick)
13074 C lipbufthick is thickenes of lipid buffore
13075          sstube=sscalelip(fracinbuf)
13076          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
13077          print *,ssgradtube, sstube,tubetranene(itype(i))
13078          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13079          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13080      &+ssgradtube*tubetranene(itype(i))
13081          gg_tube(3,i-1)= gg_tube(3,i-1)
13082      &+ssgradtube*tubetranene(itype(i))
13083 C         print *,"doing sccale for lower part"
13084         elseif (positi.gt.buftubetop) then
13085          fracinbuf=1.0d0-
13086      &((bordtubetop-positi)/tubebufthick)
13087          sstube=sscalelip(fracinbuf)
13088          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
13089          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13090 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
13091 C     &+ssgradtube*tubetranene(itype(i))
13092 C         gg_tube(3,i-1)= gg_tube(3,i-1)
13093 C     &+ssgradtube*tubetranene(itype(i))
13094 C          print *, "doing sscalefor top part",sslip,fracinbuf
13095         else
13096          sstube=1.0d0
13097          ssgradtube=0.0d0
13098          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13099 C         print *,"I am in true lipid"
13100         endif
13101         else
13102 C          sstube=0.0d0
13103 C          ssgradtube=0.0d0
13104         cycle
13105         endif ! if in lipid or buffor
13106 CEND OF FINITE FRAGMENT
13107 C as the tube is infinity we do not calculate the Z-vector use of Z
13108 C as chosen axis
13109       vectube(3)=0.0d0
13110 C now calculte the distance
13111        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13112 C now normalize vector
13113       vectube(1)=vectube(1)/tub_r
13114       vectube(2)=vectube(2)/tub_r
13115 C calculte rdiffrence between r and r0
13116       rdiff=tub_r-tubeR0
13117 C and its 6 power
13118       rdiff6=rdiff**6.0d0
13119 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13120        sc_aa_tube=sc_aa_tube_par(iti)
13121        sc_bb_tube=sc_bb_tube_par(iti)
13122        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13123      &                 *sstube+enetube(i+nres)
13124 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13125 C now we calculate gradient
13126        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13127      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13128 C now direction of gg_tube vector
13129          do j=1,3
13130           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13131           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13132          enddo
13133          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13134      &+ssgradtube*enetube(i+nres)/sstube
13135          gg_tube(3,i-1)= gg_tube(3,i-1)
13136      &+ssgradtube*enetube(i+nres)/sstube
13137
13138         enddo
13139         do i=1,2*nres
13140           Etube=Etube+enetube(i)
13141         enddo
13142 C        print *,"ETUBE", etube
13143         return
13144         end
13145 C TO DO 1) add to total energy
13146 C       2) add to gradient summation
13147 C       3) add reading parameters (AND of course oppening of PARAM file)
13148 C       4) add reading the center of tube
13149 C       5) add COMMONs
13150 C       6) add to zerograd
13151 c----------------------------------------------------------------------------
13152       subroutine e_saxs(Esaxs_constr)
13153       implicit none
13154       include 'DIMENSIONS'
13155 #ifdef MPI
13156       include "mpif.h"
13157       include "COMMON.SETUP"
13158       integer IERR
13159 #endif
13160       include 'COMMON.SBRIDGE'
13161       include 'COMMON.CHAIN'
13162       include 'COMMON.GEO'
13163       include 'COMMON.DERIV'
13164       include 'COMMON.LOCAL'
13165       include 'COMMON.INTERACT'
13166       include 'COMMON.VAR'
13167       include 'COMMON.IOUNITS'
13168 c      include 'COMMON.MD'
13169 #ifdef LANG0
13170 #ifdef FIVEDIAG
13171       include 'COMMON.LANGEVIN.lang0.5diag'
13172 #else
13173       include 'COMMON.LANGEVIN.lang0'
13174 #endif
13175 #else
13176       include 'COMMON.LANGEVIN'
13177 #endif
13178       include 'COMMON.CONTROL'
13179       include 'COMMON.SAXS'
13180       include 'COMMON.NAMES'
13181       include 'COMMON.TIME1'
13182       include 'COMMON.FFIELD'
13183 c
13184       double precision Esaxs_constr
13185       integer i,iint,j,k,l
13186       double precision PgradC(maxSAXS,3,maxres),
13187      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13188 #ifdef MPI
13189       double precision PgradC_(maxSAXS,3,maxres),
13190      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13191 #endif
13192       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13193      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13194      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13195      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13196       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13197       double precision dist,mygauss,mygaussder
13198       external dist
13199       integer llicz,lllicz
13200       double precision time01
13201 c  SAXS restraint penalty function
13202 #ifdef DEBUG
13203       write(iout,*) "------- SAXS penalty function start -------"
13204       write (iout,*) "nsaxs",nsaxs
13205       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13206       write (iout,*) "Psaxs"
13207       do i=1,nsaxs
13208         write (iout,'(i5,e15.5)') i, Psaxs(i)
13209       enddo
13210 #endif
13211 #ifdef TIMING
13212       time01=MPI_Wtime()
13213 #endif
13214       Esaxs_constr = 0.0d0
13215       do k=1,nsaxs
13216         Pcalc(k)=0.0d0
13217         do j=1,nres
13218           do l=1,3
13219             PgradC(k,l,j)=0.0d0
13220             PgradX(k,l,j)=0.0d0
13221           enddo
13222         enddo
13223       enddo
13224 c      lllicz=0
13225       do i=iatsc_s,iatsc_e
13226        if (itype(i).eq.ntyp1) cycle
13227        do iint=1,nint_gr(i)
13228          do j=istart(i,iint),iend(i,iint)
13229            if (itype(j).eq.ntyp1) cycle
13230 #ifdef ALLSAXS
13231            dijCACA=dist(i,j)
13232            dijCASC=dist(i,j+nres)
13233            dijSCCA=dist(i+nres,j)
13234            dijSCSC=dist(i+nres,j+nres)
13235            sigma2CACA=2.0d0/(pstok**2)
13236            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13237            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13238            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13239            do k=1,nsaxs
13240              dk = distsaxs(k)
13241              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13242              if (itype(j).ne.10) then
13243              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13244              else
13245              endif
13246              expCASC = 0.0d0
13247              if (itype(i).ne.10) then
13248              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13249              else
13250              expSCCA = 0.0d0
13251              endif
13252              if (itype(i).ne.10 .and. itype(j).ne.10) then
13253              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13254              else
13255              expSCSC = 0.0d0
13256              endif
13257              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13258 #ifdef DEBUG
13259              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13260 #endif
13261              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13262              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13263              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13264              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13265              do l=1,3
13266 c CA CA
13267                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13268                PgradC(k,l,i) = PgradC(k,l,i)-aux
13269                PgradC(k,l,j) = PgradC(k,l,j)+aux
13270 c CA SC
13271                if (itype(j).ne.10) then
13272                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13273                PgradC(k,l,i) = PgradC(k,l,i)-aux
13274                PgradC(k,l,j) = PgradC(k,l,j)+aux
13275                PgradX(k,l,j) = PgradX(k,l,j)+aux
13276                endif
13277 c SC CA
13278                if (itype(i).ne.10) then
13279                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13280                PgradX(k,l,i) = PgradX(k,l,i)-aux
13281                PgradC(k,l,i) = PgradC(k,l,i)-aux
13282                PgradC(k,l,j) = PgradC(k,l,j)+aux
13283                endif
13284 c SC SC
13285                if (itype(i).ne.10 .and. itype(j).ne.10) then
13286                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13287                PgradC(k,l,i) = PgradC(k,l,i)-aux
13288                PgradC(k,l,j) = PgradC(k,l,j)+aux
13289                PgradX(k,l,i) = PgradX(k,l,i)-aux
13290                PgradX(k,l,j) = PgradX(k,l,j)+aux
13291                endif
13292              enddo ! l
13293            enddo ! k
13294 #else
13295            dijCACA=dist(i,j)
13296            sigma2CACA=scal_rad**2*0.25d0/
13297      &        (restok(itype(j))**2+restok(itype(i))**2)
13298 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13299 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13300 #ifdef MYGAUSS
13301            sigmaCACA=dsqrt(sigma2CACA)
13302            threesig=3.0d0/sigmaCACA
13303 c           llicz=0
13304            do k=1,nsaxs
13305              dk = distsaxs(k)
13306              if (dabs(dijCACA-dk).ge.threesig) cycle
13307 c             llicz=llicz+1
13308 c             lllicz=lllicz+1
13309              aux = sigmaCACA*(dijCACA-dk)
13310              expCACA = mygauss(aux)
13311 c             if (expcaca.eq.0.0d0) cycle
13312              Pcalc(k) = Pcalc(k)+expCACA
13313              CACAgrad = -sigmaCACA*mygaussder(aux)
13314 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13315              do l=1,3
13316                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13317                PgradC(k,l,i) = PgradC(k,l,i)-aux
13318                PgradC(k,l,j) = PgradC(k,l,j)+aux
13319              enddo ! l
13320            enddo ! k
13321 c           write (iout,*) "i",i," j",j," llicz",llicz
13322 #else
13323            IF (saxs_cutoff.eq.0) THEN
13324            do k=1,nsaxs
13325              dk = distsaxs(k)
13326              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13327              Pcalc(k) = Pcalc(k)+expCACA
13328              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13329              do l=1,3
13330                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13331                PgradC(k,l,i) = PgradC(k,l,i)-aux
13332                PgradC(k,l,j) = PgradC(k,l,j)+aux
13333              enddo ! l
13334            enddo ! k
13335            ELSE
13336            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13337            do k=1,nsaxs
13338              dk = distsaxs(k)
13339 c             write (2,*) "ijk",i,j,k
13340              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13341              if (sss2.eq.0.0d0) cycle
13342              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13343              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13344      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13345      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13346      &           sss2,ssgrad2
13347              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13348              Pcalc(k) = Pcalc(k)+expCACA
13349 #ifdef DEBUG
13350              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13351 #endif
13352              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13353      &             ssgrad2*expCACA/sss2
13354              do l=1,3
13355 c CA CA
13356                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13357                PgradC(k,l,i) = PgradC(k,l,i)+aux
13358                PgradC(k,l,j) = PgradC(k,l,j)-aux
13359              enddo ! l
13360            enddo ! k
13361            ENDIF
13362 #endif
13363 #endif
13364          enddo ! j
13365        enddo ! iint
13366       enddo ! i
13367 c#ifdef TIMING
13368 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13369 c#endif
13370 c      write (iout,*) "lllicz",lllicz
13371 c#ifdef TIMING
13372 c      time01=MPI_Wtime()
13373 c#endif
13374 #ifdef MPI
13375       if (nfgtasks.gt.1) then
13376        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13377      &    MPI_SUM,FG_COMM,IERR)
13378 c        if (fg_rank.eq.king) then
13379           do k=1,nsaxs
13380             Pcalc(k) = Pcalc_(k)
13381           enddo
13382 c        endif
13383 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13384 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13385 c        if (fg_rank.eq.king) then
13386 c          do i=1,nres
13387 c            do l=1,3
13388 c              do k=1,nsaxs
13389 c                PgradC(k,l,i) = PgradC_(k,l,i)
13390 c              enddo
13391 c            enddo
13392 c          enddo
13393 c        endif
13394 #ifdef ALLSAXS
13395 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13396 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13397 c        if (fg_rank.eq.king) then
13398 c          do i=1,nres
13399 c            do l=1,3
13400 c              do k=1,nsaxs
13401 c                PgradX(k,l,i) = PgradX_(k,l,i)
13402 c              enddo
13403 c            enddo
13404 c          enddo
13405 c        endif
13406 #endif
13407       endif
13408 #endif
13409       Cnorm = 0.0d0
13410       do k=1,nsaxs
13411         Cnorm = Cnorm + Pcalc(k)
13412       enddo
13413 #ifdef MPI
13414       if (fg_rank.eq.king) then
13415 #endif
13416       Esaxs_constr = dlog(Cnorm)-wsaxs0
13417       do k=1,nsaxs
13418         if (Pcalc(k).gt.0.0d0)
13419      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13420 #ifdef DEBUG
13421         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13422 #endif
13423       enddo
13424 #ifdef DEBUG
13425       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13426 #endif
13427 #ifdef MPI
13428       endif
13429 #endif
13430       gsaxsC=0.0d0
13431       gsaxsX=0.0d0
13432       do i=nnt,nct
13433         do l=1,3
13434           auxC=0.0d0
13435           auxC1=0.0d0
13436           auxX=0.0d0
13437           auxX1=0.d0
13438           do k=1,nsaxs
13439             if (Pcalc(k).gt.0)
13440      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13441             auxC1 = auxC1+PgradC(k,l,i)
13442 #ifdef ALLSAXS
13443             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13444             auxX1 = auxX1+PgradX(k,l,i)
13445 #endif
13446           enddo
13447           gsaxsC(l,i) = auxC - auxC1/Cnorm
13448 #ifdef ALLSAXS
13449           gsaxsX(l,i) = auxX - auxX1/Cnorm
13450 #endif
13451 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13452 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13453 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13454 c     *     " gradX",wsaxs*gsaxsX(l,i)
13455         enddo
13456       enddo
13457 #ifdef TIMING
13458       time_SAXS=time_SAXS+MPI_Wtime()-time01
13459 #endif
13460 #ifdef DEBUG
13461       write (iout,*) "gsaxsc"
13462       do i=nnt,nct
13463         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13464       enddo
13465 #endif
13466 #ifdef MPI
13467 c      endif
13468 #endif
13469       return
13470       end
13471 c----------------------------------------------------------------------------
13472       subroutine e_saxsC(Esaxs_constr)
13473       implicit none
13474       include 'DIMENSIONS'
13475 #ifdef MPI
13476       include "mpif.h"
13477       include "COMMON.SETUP"
13478       integer IERR
13479 #endif
13480       include 'COMMON.SBRIDGE'
13481       include 'COMMON.CHAIN'
13482       include 'COMMON.GEO'
13483       include 'COMMON.DERIV'
13484       include 'COMMON.LOCAL'
13485       include 'COMMON.INTERACT'
13486       include 'COMMON.VAR'
13487       include 'COMMON.IOUNITS'
13488 c      include 'COMMON.MD'
13489 #ifdef LANG0
13490 #ifdef FIVEDIAG
13491       include 'COMMON.LANGEVIN.lang0.5diag'
13492 #else
13493       include 'COMMON.LANGEVIN.lang0'
13494 #endif
13495 #else
13496       include 'COMMON.LANGEVIN'
13497 #endif
13498       include 'COMMON.CONTROL'
13499       include 'COMMON.SAXS'
13500       include 'COMMON.NAMES'
13501       include 'COMMON.TIME1'
13502       include 'COMMON.FFIELD'
13503 c
13504       double precision Esaxs_constr
13505       integer i,iint,j,k,l
13506       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13507 #ifdef MPI
13508       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13509 #endif
13510       double precision dk,dijCASPH,dijSCSPH,
13511      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13512      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13513      & auxX,auxX1,Cnorm
13514 c  SAXS restraint penalty function
13515 #ifdef DEBUG
13516       write(iout,*) "------- SAXS penalty function start -------"
13517       write (iout,*) "nsaxs",nsaxs
13518
13519       do i=nnt,nct
13520         print *,MyRank,"C",i,(C(j,i),j=1,3)
13521       enddo
13522       do i=nnt,nct
13523         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13524       enddo
13525 #endif
13526       Esaxs_constr = 0.0d0
13527       logPtot=0.0d0
13528       do j=isaxs_start,isaxs_end
13529         Pcalc=0.0d0
13530         do i=1,nres
13531           do l=1,3
13532             PgradC(l,i)=0.0d0
13533             PgradX(l,i)=0.0d0
13534           enddo
13535         enddo
13536         do i=nnt,nct
13537           if (itype(i).eq.ntyp1) cycle
13538           dijCASPH=0.0d0
13539           dijSCSPH=0.0d0
13540           do l=1,3
13541             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13542           enddo
13543           if (itype(i).ne.10) then
13544           do l=1,3
13545             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13546           enddo
13547           endif
13548           sigma2CA=2.0d0/pstok**2
13549           sigma2SC=4.0d0/restok(itype(i))**2
13550           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13551           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13552           Pcalc = Pcalc+expCASPH+expSCSPH
13553 #ifdef DEBUG
13554           write(*,*) "processor i j Pcalc",
13555      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13556 #endif
13557           CASPHgrad = sigma2CA*expCASPH
13558           SCSPHgrad = sigma2SC*expSCSPH
13559           do l=1,3
13560             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13561             PgradX(l,i) = PgradX(l,i) + aux
13562             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13563           enddo ! l
13564         enddo ! i
13565         do i=nnt,nct
13566           do l=1,3
13567             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13568             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13569           enddo
13570         enddo
13571         logPtot = logPtot - dlog(Pcalc)
13572 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13573 c     &    " logPtot",logPtot
13574       enddo ! j
13575 #ifdef MPI
13576       if (nfgtasks.gt.1) then
13577 c        write (iout,*) "logPtot before reduction",logPtot
13578         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13579      &    MPI_SUM,king,FG_COMM,IERR)
13580         logPtot = logPtot_
13581 c        write (iout,*) "logPtot after reduction",logPtot
13582         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13583      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13584         if (fg_rank.eq.king) then
13585           do i=1,nres
13586             do l=1,3
13587               gsaxsC(l,i) = gsaxsC_(l,i)
13588             enddo
13589           enddo
13590         endif
13591         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13592      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13593         if (fg_rank.eq.king) then
13594           do i=1,nres
13595             do l=1,3
13596               gsaxsX(l,i) = gsaxsX_(l,i)
13597             enddo
13598           enddo
13599         endif
13600       endif
13601 #endif
13602       Esaxs_constr = logPtot
13603       return
13604       end
13605 c----------------------------------------------------------------------------
13606       double precision function sscale2(r,r_cut,r0,rlamb)
13607       implicit none
13608       double precision r,gamm,r_cut,r0,rlamb,rr
13609       rr = dabs(r-r0)
13610 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13611 c      write (2,*) "rr",rr
13612       if(rr.lt.r_cut-rlamb) then
13613         sscale2=1.0d0
13614       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13615         gamm=(rr-(r_cut-rlamb))/rlamb
13616         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13617       else
13618         sscale2=0d0
13619       endif
13620       return
13621       end
13622 C-----------------------------------------------------------------------
13623       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13624       implicit none
13625       double precision r,gamm,r_cut,r0,rlamb,rr
13626       rr = dabs(r-r0)
13627       if(rr.lt.r_cut-rlamb) then
13628         sscalgrad2=0.0d0
13629       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13630         gamm=(rr-(r_cut-rlamb))/rlamb
13631         if (r.ge.r0) then
13632           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13633         else
13634           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13635         endif
13636       else
13637         sscalgrad2=0.0d0
13638       endif
13639       return
13640       end