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

   1       subroutine etotal(energia)
   2       implicit none
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  34      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  35      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  36      & eliptran,Eafmforce,Etube,
  37      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  38       integer n_corr,n_corr1
  39 #ifdef MPI
  40 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  41 c     & " nfgtasks",nfgtasks
  42       if (nfgtasks.gt.1) then
  43         time00=MPI_Wtime()
  44 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  45         if (fg_rank.eq.0) then
  46           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  47 c          print *,"Processor",myrank," BROADCAST iorder"
  48 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  49 C FG slaves as WEIGHTS array.
  50           weights_(1)=wsc
  51           weights_(2)=wscp
  52           weights_(3)=welec
  53           weights_(4)=wcorr
  54           weights_(5)=wcorr5
  55           weights_(6)=wcorr6
  56           weights_(7)=wel_loc
  57           weights_(8)=wturn3
  58           weights_(9)=wturn4
  59           weights_(10)=wturn6
  60           weights_(11)=wang
  61           weights_(12)=wscloc
  62           weights_(13)=wtor
  63           weights_(14)=wtor_d
  64           weights_(15)=wstrain
  65           weights_(16)=wvdwpp
  66           weights_(17)=wbond
  67           weights_(18)=scal14
  68           weights_(21)=wsccor
  69           weights_(22)=wliptran
  70           weights_(25)=wtube
  71           weights_(26)=wsaxs
  72           weights_(28)=wdfa_dist
  73           weights_(29)=wdfa_tor
  74           weights_(30)=wdfa_nei
  75           weights_(31)=wdfa_beta
  76 C FG Master broadcasts the WEIGHTS_ array
  77           call MPI_Bcast(weights_(1),n_ene,
  78      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  79         else
  80 C FG slaves receive the WEIGHTS array
  81           call MPI_Bcast(weights(1),n_ene,
  82      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  83           wsc=weights(1)
  84           wscp=weights(2)
  85           welec=weights(3)
  86           wcorr=weights(4)
  87           wcorr5=weights(5)
  88           wcorr6=weights(6)
  89           wel_loc=weights(7)
  90           wturn3=weights(8)
  91           wturn4=weights(9)
  92           wturn6=weights(10)
  93           wang=weights(11)
  94           wscloc=weights(12)
  95           wtor=weights(13)
  96           wtor_d=weights(14)
  97           wstrain=weights(15)
  98           wvdwpp=weights(16)
  99           wbond=weights(17)
 100           scal14=weights(18)
 101           wsccor=weights(21)
 102           wliptran=weights(22)
 103           wtube=weights(25)
 104           wsaxs=weights(26)
 105           wdfa_dist=weights_(28)
 106           wdfa_tor=weights_(29)
 107           wdfa_nei=weights_(30)
 108           wdfa_beta=weights_(31)
 109         endif
 110         time_Bcast=time_Bcast+MPI_Wtime()-time00
 111         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 112 c        call chainbuild_cart
 113       endif
 114 #ifndef DFA
 115       edfadis=0.0d0
 116       edfator=0.0d0
 117       edfanei=0.0d0
 118       edfabet=0.0d0
 119 #endif
 120 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 121 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 122 #else
 123 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 124 c        call int_from_cart1(.false.)
 125 c      endif
 126 #endif
 127 #ifdef TIMING
 128       time00=MPI_Wtime()
 129 #endif
 130 C
 131 C Compute the side-chain and electrostatic interaction energy
 132 C
 133 C      print *,ipot
 134       goto (101,102,103,104,105,106) ipot
 135 C Lennard-Jones potential.
 136   101 call elj(evdw)
 137 cd    print '(a)','Exit ELJ'
 138       goto 107
 139 C Lennard-Jones-Kihara potential (shifted).
 140   102 call eljk(evdw)
 141       goto 107
 142 C Berne-Pechukas potential (dilated LJ, angular dependence).
 143   103 call ebp(evdw)
 144       goto 107
 145 C Gay-Berne potential (shifted LJ, angular dependence).
 146   104 call egb(evdw)
 147 C      print *,"bylem w egb"
 148       goto 107
 149 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 150   105 call egbv(evdw)
 151       goto 107
 152 C Soft-sphere potential
 153   106 call e_softsphere(evdw)
 154 C
 155 C Calculate electrostatic (H-bonding) energy of the main chain.
 156 C
 157   107 continue
 158 #ifdef DFA
 159 C     BARTEK for dfa test!
 160       if (wdfa_dist.gt.0) then
 161         call edfad(edfadis)
 162       else
 163         edfadis=0
 164       endif
 165 c      print*, 'edfad is finished!', edfadis
 166       if (wdfa_tor.gt.0) then
 167         call edfat(edfator)
 168       else
 169         edfator=0
 170       endif
 171 c      print*, 'edfat is finished!', edfator
 172       if (wdfa_nei.gt.0) then
 173         call edfan(edfanei)
 174       else
 175         edfanei=0
 176       endif
 177 c      print*, 'edfan is finished!', edfanei
 178       if (wdfa_beta.gt.0) then
 179         call edfab(edfabet)
 180       else
 181         edfabet=0
 182       endif
 183 #endif
 184 cmc
 185 cmc Sep-06: egb takes care of dynamic ss bonds too
 186 cmc
 187 c      if (dyn_ss) call dyn_set_nss
 188
 189 c      print *,"Processor",myrank," computed USCSC"
 190 #ifdef TIMING
 191       time01=MPI_Wtime()
 192 #endif
 193       call vec_and_deriv
 194 #ifdef TIMING
 195       time_vec=time_vec+MPI_Wtime()-time01
 196 #endif
 197 C Introduction of shielding effect first for each peptide group
 198 C the shielding factor is set this factor is describing how each
 199 C peptide group is shielded by side-chains
 200 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 201 C      write (iout,*) "shield_mode",shield_mode
 202       if (shield_mode.eq.1) then
 203        call set_shield_fac
 204       else if  (shield_mode.eq.2) then
 205        call set_shield_fac2
 206       endif
 207 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 208       if (ipot.lt.6) then
 209 #ifdef SPLITELE
 210          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 211      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 212      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 213      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 214 #else
 215          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 216      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 217      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 218      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 219 #endif
 220             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 221          else
 222             ees=0.0d0
 223             evdw1=0.0d0
 224             eel_loc=0.0d0
 225             eello_turn3=0.0d0
 226             eello_turn4=0.0d0
 227          endif
 228       else
 229         write (iout,*) "Soft-spheer ELEC potential"
 230 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 231 c     &   eello_turn4)
 232       endif
 233 c#ifdef TIMING
 234 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 235 c#endif
 236 c      print *,"Processor",myrank," computed UELEC"
 237 C
 238 C Calculate excluded-volume interaction energy between peptide groups
 239 C and side chains.
 240 C
 241       if (ipot.lt.6) then
 242        if(wscp.gt.0d0) then
 243         call escp(evdw2,evdw2_14)
 244        else
 245         evdw2=0
 246         evdw2_14=0
 247        endif
 248       else
 249 c        write (iout,*) "Soft-sphere SCP potential"
 250         call escp_soft_sphere(evdw2,evdw2_14)
 251       endif
 252 c
 253 c Calculate the bond-stretching energy
 254 c
 255       call ebond(estr)
 256 C
 257 C Calculate the disulfide-bridge and other energy and the contributions
 258 C from other distance constraints.
 259 cd      write (iout,*) 'Calling EHPB'
 260       call edis(ehpb)
 261 cd    print *,'EHPB exitted succesfully.'
 262 C
 263 C Calculate the virtual-bond-angle energy.
 264 C
 265       if (wang.gt.0d0) then
 266        if (tor_mode.eq.0) then
 267          call ebend(ebe)
 268        else
 269 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 270 C energy function
 271          call ebend_kcc(ebe)
 272        endif
 273       else
 274         ebe=0.0d0
 275       endif
 276       ethetacnstr=0.0d0
 277       if (with_theta_constr) call etheta_constr(ethetacnstr)
 278 c      print *,"Processor",myrank," computed UB"
 279 C
 280 C Calculate the SC local energy.
 281 C
 282 C      print *,"TU DOCHODZE?"
 283       call esc(escloc)
 284 c      print *,"Processor",myrank," computed USC"
 285 C
 286 C Calculate the virtual-bond torsional energy.
 287 C
 288 cd    print *,'nterm=',nterm
 289 C      print *,"tor",tor_mode
 290       if (wtor.gt.0.0d0) then
 291          if (tor_mode.eq.0) then
 292            call etor(etors)
 293          else
 294 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 295 C energy function
 296            call etor_kcc(etors)
 297          endif
 298       else
 299         etors=0.0d0
 300       endif
 301       edihcnstr=0.0d0
 302       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 303 c      print *,"Processor",myrank," computed Utor"
 304       if (constr_homology.ge.1) then
 305         call e_modeller(ehomology_constr)
 306 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 307 c     &  'Processor',fg_rank,' CG group',kolor,
 308 c     &  ' absolute rank',MyRank
 309       else
 310         ehomology_constr=0.0d0
 311       endif
 312 C
 313 C 6/23/01 Calculate double-torsional energy
 314 C
 315       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 316         call etor_d(etors_d)
 317       else
 318         etors_d=0
 319       endif
 320 c      print *,"Processor",myrank," computed Utord"
 321 C
 322 C 21/5/07 Calculate local sicdechain correlation energy
 323 C
 324       if (wsccor.gt.0.0d0) then
 325         call eback_sc_corr(esccor)
 326       else
 327         esccor=0.0d0
 328       endif
 329 #ifdef FOURBODY
 330 C      print *,"PRZED MULIt"
 331 c      print *,"Processor",myrank," computed Usccorr"
 332 C
 333 C 12/1/95 Multi-body terms
 334 C
 335       n_corr=0
 336       n_corr1=0
 337       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 338      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 339          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 340 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 341 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 342 c        call flush(iout)
 343       else
 344          ecorr=0.0d0
 345          ecorr5=0.0d0
 346          ecorr6=0.0d0
 347          eturn6=0.0d0
 348       endif
 349       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 350 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 351 c     &     n_corr,n_corr1
 352 c         call flush(iout)
 353          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 354 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 355 c     &     n_corr1
 356 c         call flush(iout)
 357       endif
 358 #endif
 359 c      print *,"Processor",myrank," computed Ucorr"
 360 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 361       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 362         call e_saxs(Esaxs_constr)
 363 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 364       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 365         call e_saxsC(Esaxs_constr)
 366 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 367       else
 368         Esaxs_constr = 0.0d0
 369       endif
 370 C
 371 C If performing constraint dynamics, call the constraint energy
 372 C  after the equilibration time
 373 c      if(usampl.and.totT.gt.eq_time) then
 374 c      write (iout,*) "usampl",usampl
 375       if(usampl) then
 376          call EconstrQ
 377          if (loc_qlike) then
 378            call Econstr_back_qlike
 379          else
 380            call Econstr_back
 381          endif
 382       else
 383          Uconst=0.0d0
 384          Uconst_back=0.0d0
 385       endif
 386 C 01/27/2015 added by adasko
 387 C the energy component below is energy transfer into lipid environment
 388 C based on partition function
 389 C      print *,"przed lipidami"
 390       if (wliptran.gt.0) then
 391         call Eliptransfer(eliptran)
 392       else
 393         eliptran=0.0d0
 394       endif
 395 C      print *,"za lipidami"
 396       if (AFMlog.gt.0) then
 397         call AFMforce(Eafmforce)
 398       else if (selfguide.gt.0) then
 399         call AFMvel(Eafmforce)
 400       endif
 401       if (TUBElog.eq.1) then
 402 C      print *,"just before call"
 403         call calctube(Etube)
 404        elseif (TUBElog.eq.2) then
 405         call calctube2(Etube)
 406        else
 407        Etube=0.0d0
 408        endif
 409
 410 #ifdef TIMING
 411       time_enecalc=time_enecalc+MPI_Wtime()-time00
 412 #endif
 413 c      print *,"Processor",myrank," computed Uconstr"
 414 #ifdef TIMING
 415       time00=MPI_Wtime()
 416 #endif
 417 c
 418 C Sum the energies
 419 C
 420       energia(1)=evdw
 421 #ifdef SCP14
 422       energia(2)=evdw2-evdw2_14
 423       energia(18)=evdw2_14
 424 #else
 425       energia(2)=evdw2
 426       energia(18)=0.0d0
 427 #endif
 428 #ifdef SPLITELE
 429       energia(3)=ees
 430       energia(16)=evdw1
 431 #else
 432       energia(3)=ees+evdw1
 433       energia(16)=0.0d0
 434 #endif
 435       energia(4)=ecorr
 436       energia(5)=ecorr5
 437       energia(6)=ecorr6
 438       energia(7)=eel_loc
 439       energia(8)=eello_turn3
 440       energia(9)=eello_turn4
 441       energia(10)=eturn6
 442       energia(11)=ebe
 443       energia(12)=escloc
 444       energia(13)=etors
 445       energia(14)=etors_d
 446       energia(15)=ehpb
 447       energia(19)=edihcnstr
 448       energia(17)=estr
 449       energia(20)=Uconst+Uconst_back
 450       energia(21)=esccor
 451       energia(22)=eliptran
 452       energia(23)=Eafmforce
 453       energia(24)=ethetacnstr
 454       energia(25)=Etube
 455       energia(26)=Esaxs_constr
 456       energia(27)=ehomology_constr
 457       energia(28)=edfadis
 458       energia(29)=edfator
 459       energia(30)=edfanei
 460       energia(31)=edfabet
 461 c      write (iout,*) "esaxs_constr",energia(26)
 462 c    Here are the energies showed per procesor if the are more processors
 463 c    per molecule then we sum it up in sum_energy subroutine
 464 c      print *," Processor",myrank," calls SUM_ENERGY"
 465       call sum_energy(energia,.true.)
 466 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 467       if (dyn_ss) call dyn_set_nss
 468 c      print *," Processor",myrank," left SUM_ENERGY"
 469 #ifdef TIMING
 470       time_sumene=time_sumene+MPI_Wtime()-time00
 471 #endif
 472       return
 473       end
 474 c-------------------------------------------------------------------------------
 475       subroutine sum_energy(energia,reduce)
 476       implicit none
 477       include 'DIMENSIONS'
 478 #ifndef ISNAN
 479       external proc_proc
 480 #ifdef WINPGI
 481 cMS$ATTRIBUTES C ::  proc_proc
 482 #endif
 483 #endif
 484 #ifdef MPI
 485       include "mpif.h"
 486       integer ierr
 487       double precision time00
 488 #endif
 489       include 'COMMON.SETUP'
 490       include 'COMMON.IOUNITS'
 491       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 492       include 'COMMON.FFIELD'
 493       include 'COMMON.DERIV'
 494       include 'COMMON.INTERACT'
 495       include 'COMMON.SBRIDGE'
 496       include 'COMMON.CHAIN'
 497       include 'COMMON.VAR'
 498       include 'COMMON.CONTROL'
 499       include 'COMMON.TIME1'
 500       logical reduce
 501       integer i
 502       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 503      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 504      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 505      & eliptran,Eafmforce,Etube,
 506      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 507       double precision Uconst,etot
 508 #ifdef MPI
 509       if (nfgtasks.gt.1 .and. reduce) then
 510 #ifdef DEBUG
 511         write (iout,*) "energies before REDUCE"
 512         call enerprint(energia)
 513         call flush(iout)
 514 #endif
 515         do i=0,n_ene
 516           enebuff(i)=energia(i)
 517         enddo
 518         time00=MPI_Wtime()
 519         call MPI_Barrier(FG_COMM,IERR)
 520         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 521         time00=MPI_Wtime()
 522         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 523      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 524 #ifdef DEBUG
 525         write (iout,*) "energies after REDUCE"
 526         call enerprint(energia)
 527         call flush(iout)
 528 #endif
 529         time_Reduce=time_Reduce+MPI_Wtime()-time00
 530       endif
 531       if (fg_rank.eq.0) then
 532 #endif
 533       evdw=energia(1)
 534 #ifdef SCP14
 535       evdw2=energia(2)+energia(18)
 536       evdw2_14=energia(18)
 537 #else
 538       evdw2=energia(2)
 539 #endif
 540 #ifdef SPLITELE
 541       ees=energia(3)
 542       evdw1=energia(16)
 543 #else
 544       ees=energia(3)
 545       evdw1=0.0d0
 546 #endif
 547       ecorr=energia(4)
 548       ecorr5=energia(5)
 549       ecorr6=energia(6)
 550       eel_loc=energia(7)
 551       eello_turn3=energia(8)
 552       eello_turn4=energia(9)
 553       eturn6=energia(10)
 554       ebe=energia(11)
 555       escloc=energia(12)
 556       etors=energia(13)
 557       etors_d=energia(14)
 558       ehpb=energia(15)
 559       edihcnstr=energia(19)
 560       estr=energia(17)
 561       Uconst=energia(20)
 562       esccor=energia(21)
 563       eliptran=energia(22)
 564       Eafmforce=energia(23)
 565       ethetacnstr=energia(24)
 566       Etube=energia(25)
 567       esaxs_constr=energia(26)
 568       ehomology_constr=energia(27)
 569       edfadis=energia(28)
 570       edfator=energia(29)
 571       edfanei=energia(30)
 572       edfabet=energia(31)
 573 #ifdef SPLITELE
 574       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 575      & +wang*ebe+wtor*etors+wscloc*escloc
 576      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 577      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 578      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 579      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 580      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 581      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 582      & +wdfa_beta*edfabet
 583 #else
 584       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 585      & +wang*ebe+wtor*etors+wscloc*escloc
 586      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 587      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 588      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 589      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 590      & +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 #endif
 595       energia(0)=etot
 596 c detecting NaNQ
 597 #ifdef ISNAN
 598 #ifdef AIX
 599       if (isnan(etot).ne.0) energia(0)=1.0d+99
 600 #else
 601       if (isnan(etot)) energia(0)=1.0d+99
 602 #endif
 603 #else
 604       i=0
 605 #ifdef WINPGI
 606       idumm=proc_proc(etot,i)
 607 #else
 608       call proc_proc(etot,i)
 609 #endif
 610       if(i.eq.1)energia(0)=1.0d+99
 611 #endif
 612 #ifdef MPI
 613       endif
 614 #endif
 615       return
 616       end
 617 c-------------------------------------------------------------------------------
 618       subroutine sum_gradient
 619       implicit none
 620       include 'DIMENSIONS'
 621 #ifndef ISNAN
 622       external proc_proc
 623 #ifdef WINPGI
 624 cMS$ATTRIBUTES C ::  proc_proc
 625 #endif
 626 #endif
 627 #ifdef MPI
 628       include 'mpif.h'
 629       integer ierror,ierr
 630       double precision time00,time01
 631 #endif
 632       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 633      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 634      & ,gloc_scbuf(3,-1:maxres)
 635       include 'COMMON.SETUP'
 636       include 'COMMON.IOUNITS'
 637       include 'COMMON.FFIELD'
 638       include 'COMMON.DERIV'
 639       include 'COMMON.INTERACT'
 640       include 'COMMON.SBRIDGE'
 641       include 'COMMON.CHAIN'
 642       include 'COMMON.VAR'
 643       include 'COMMON.CONTROL'
 644       include 'COMMON.TIME1'
 645       include 'COMMON.MAXGRAD'
 646       include 'COMMON.SCCOR'
 647 c      include 'COMMON.MD'
 648       include 'COMMON.QRESTR'
 649       integer i,j,k
 650       double precision scalar
 651       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 652      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 653      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 654      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 655      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 656      &gsclocx_norm
 657 #ifdef TIMING
 658       time01=MPI_Wtime()
 659 #endif
 660 #ifdef DEBUG
 661       write (iout,*) "sum_gradient gvdwc, gvdwx"
 662       do i=1,nres
 663         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 664      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 665       enddo
 666       call flush(iout)
 667 #endif
 668 #ifdef DEBUG
 669       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 670       do i=0,nres
 671         write (iout,'(i3,3e15.5,5x,3e15.5)')
 672      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 673       enddo
 674       call flush(iout)
 675 #endif
 676 #ifdef MPI
 677 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 678         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 679      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 680 #endif
 681 C
 682 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 683 C            in virtual-bond-vector coordinates
 684 C
 685 #ifdef DEBUG
 686 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 687 c      do i=1,nres-1
 688 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 689 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 690 c      enddo
 691 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 692 c      do i=1,nres-1
 693 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 694 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 695 c      enddo
 696       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 697       do i=1,nres
 698         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 699      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 700      &   g_corr5_loc(i)
 701       enddo
 702       call flush(iout)
 703 #endif
 704 #ifdef DEBUG
 705       write (iout,*) "gsaxsc"
 706       do i=1,nres
 707         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 708       enddo
 709       call flush(iout)
 710 #endif
 711 #ifdef SPLITELE
 712       do i=0,nct
 713         do j=1,3
 714           gradbufc(j,i)=wsc*gvdwc(j,i)+
 715      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 716      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 717      &                wel_loc*gel_loc_long(j,i)+
 718      &                wcorr*gradcorr_long(j,i)+
 719      &                wcorr5*gradcorr5_long(j,i)+
 720      &                wcorr6*gradcorr6_long(j,i)+
 721      &                wturn6*gcorr6_turn_long(j,i)+
 722      &                wstrain*ghpbc(j,i)
 723      &                +wliptran*gliptranc(j,i)
 724      &                +gradafm(j,i)
 725      &                +welec*gshieldc(j,i)
 726      &                +wcorr*gshieldc_ec(j,i)
 727      &                +wturn3*gshieldc_t3(j,i)
 728      &                +wturn4*gshieldc_t4(j,i)
 729      &                +wel_loc*gshieldc_ll(j,i)
 730      &                +wtube*gg_tube(j,i)
 731      &                +wsaxs*gsaxsc(j,i)
 732         enddo
 733       enddo
 734 #else
 735       do i=0,nct
 736         do j=1,3
 737           gradbufc(j,i)=wsc*gvdwc(j,i)+
 738      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 739      &                welec*gelc_long(j,i)+
 740      &                wbond*gradb(j,i)+
 741      &                wel_loc*gel_loc_long(j,i)+
 742      &                wcorr*gradcorr_long(j,i)+
 743      &                wcorr5*gradcorr5_long(j,i)+
 744      &                wcorr6*gradcorr6_long(j,i)+
 745      &                wturn6*gcorr6_turn_long(j,i)+
 746      &                wstrain*ghpbc(j,i)
 747      &                +wliptran*gliptranc(j,i)
 748      &                +gradafm(j,i)
 749      &                 +welec*gshieldc(j,i)
 750      &                 +wcorr*gshieldc_ec(j,i)
 751      &                 +wturn4*gshieldc_t4(j,i)
 752      &                 +wel_loc*gshieldc_ll(j,i)
 753      &                +wtube*gg_tube(j,i)
 754      &                +wsaxs*gsaxsc(j,i)
 755         enddo
 756       enddo
 757 #endif
 758       do i=1,nct
 759         do j=1,3
 760           gradbufc(j,i)=gradbufc(j,i)+
 761      &                wdfa_dist*gdfad(j,i)+
 762      &                wdfa_tor*gdfat(j,i)+
 763      &                wdfa_nei*gdfan(j,i)+
 764      &                wdfa_beta*gdfab(j,i)
 765         enddo
 766       enddo
 767 #ifdef DEBUG
 768       write (iout,*) "gradc from gradbufc"
 769       do i=1,nres
 770         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 771       enddo
 772       call flush(iout)
 773 #endif
 774 #ifdef MPI
 775       if (nfgtasks.gt.1) then
 776       time00=MPI_Wtime()
 777 #ifdef DEBUG
 778       write (iout,*) "gradbufc before allreduce"
 779       do i=1,nres
 780         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 781       enddo
 782       call flush(iout)
 783 #endif
 784       do i=0,nres
 785         do j=1,3
 786           gradbufc_sum(j,i)=gradbufc(j,i)
 787         enddo
 788       enddo
 789 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 790 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 791 c      time_reduce=time_reduce+MPI_Wtime()-time00
 792 #ifdef DEBUG
 793 c      write (iout,*) "gradbufc_sum after allreduce"
 794 c      do i=1,nres
 795 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 796 c      enddo
 797 c      call flush(iout)
 798 #endif
 799 #ifdef TIMING
 800 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 801 #endif
 802       do i=nnt,nres
 803         do k=1,3
 804           gradbufc(k,i)=0.0d0
 805         enddo
 806       enddo
 807 #ifdef DEBUG
 808       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 809       write (iout,*) (i," jgrad_start",jgrad_start(i),
 810      &                  " jgrad_end  ",jgrad_end(i),
 811      &                  i=igrad_start,igrad_end)
 812 #endif
 813 c
 814 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 815 c do not parallelize this part.
 816 c
 817 c      do i=igrad_start,igrad_end
 818 c        do j=jgrad_start(i),jgrad_end(i)
 819 c          do k=1,3
 820 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 821 c          enddo
 822 c        enddo
 823 c      enddo
 824       do j=1,3
 825         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 826       enddo
 827       do i=nres-2,-1,-1
 828         do j=1,3
 829           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 830         enddo
 831       enddo
 832 #ifdef DEBUG
 833       write (iout,*) "gradbufc after summing"
 834       do i=1,nres
 835         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 836       enddo
 837       call flush(iout)
 838 #endif
 839       else
 840 #endif
 841 #ifdef DEBUG
 842       write (iout,*) "gradbufc"
 843       do i=1,nres
 844         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 845       enddo
 846       call flush(iout)
 847 #endif
 848       do i=-1,nres
 849         do j=1,3
 850           gradbufc_sum(j,i)=gradbufc(j,i)
 851           gradbufc(j,i)=0.0d0
 852         enddo
 853       enddo
 854       do j=1,3
 855         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 856       enddo
 857       do i=nres-2,-1,-1
 858         do j=1,3
 859           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 860         enddo
 861       enddo
 862 c      do i=nnt,nres-1
 863 c        do k=1,3
 864 c          gradbufc(k,i)=0.0d0
 865 c        enddo
 866 c        do j=i+1,nres
 867 c          do k=1,3
 868 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 869 c          enddo
 870 c        enddo
 871 c      enddo
 872 #ifdef DEBUG
 873       write (iout,*) "gradbufc after summing"
 874       do i=1,nres
 875         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 876       enddo
 877       call flush(iout)
 878 #endif
 879 #ifdef MPI
 880       endif
 881 #endif
 882       do k=1,3
 883         gradbufc(k,nres)=0.0d0
 884       enddo
 885       do i=-1,nct
 886         do j=1,3
 887 #ifdef SPLITELE
 888 C          print *,gradbufc(1,13)
 889 C          print *,welec*gelc(1,13)
 890 C          print *,wel_loc*gel_loc(1,13)
 891 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 892 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 893 C          print *,wel_loc*gel_loc_long(1,13)
 894 C          print *,gradafm(1,13),"AFM"
 895           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 896      &                wel_loc*gel_loc(j,i)+
 897      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 898      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 899      &                wel_loc*gel_loc_long(j,i)+
 900      &                wcorr*gradcorr_long(j,i)+
 901      &                wcorr5*gradcorr5_long(j,i)+
 902      &                wcorr6*gradcorr6_long(j,i)+
 903      &                wturn6*gcorr6_turn_long(j,i))+
 904      &                wbond*gradb(j,i)+
 905      &                wcorr*gradcorr(j,i)+
 906      &                wturn3*gcorr3_turn(j,i)+
 907      &                wturn4*gcorr4_turn(j,i)+
 908      &                wcorr5*gradcorr5(j,i)+
 909      &                wcorr6*gradcorr6(j,i)+
 910      &                wturn6*gcorr6_turn(j,i)+
 911      &                wsccor*gsccorc(j,i)
 912      &               +wscloc*gscloc(j,i)
 913      &               +wliptran*gliptranc(j,i)
 914      &                +gradafm(j,i)
 915      &                 +welec*gshieldc(j,i)
 916      &                 +welec*gshieldc_loc(j,i)
 917      &                 +wcorr*gshieldc_ec(j,i)
 918      &                 +wcorr*gshieldc_loc_ec(j,i)
 919      &                 +wturn3*gshieldc_t3(j,i)
 920      &                 +wturn3*gshieldc_loc_t3(j,i)
 921      &                 +wturn4*gshieldc_t4(j,i)
 922      &                 +wturn4*gshieldc_loc_t4(j,i)
 923      &                 +wel_loc*gshieldc_ll(j,i)
 924      &                 +wel_loc*gshieldc_loc_ll(j,i)
 925      &                +wtube*gg_tube(j,i)
 926
 927 #else
 928           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 929      &                wel_loc*gel_loc(j,i)+
 930      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 931      &                welec*gelc_long(j,i)+
 932      &                wel_loc*gel_loc_long(j,i)+
 933      &                wcorr*gcorr_long(j,i)+
 934      &                wcorr5*gradcorr5_long(j,i)+
 935      &                wcorr6*gradcorr6_long(j,i)+
 936      &                wturn6*gcorr6_turn_long(j,i))+
 937      &                wbond*gradb(j,i)+
 938      &                wcorr*gradcorr(j,i)+
 939      &                wturn3*gcorr3_turn(j,i)+
 940      &                wturn4*gcorr4_turn(j,i)+
 941      &                wcorr5*gradcorr5(j,i)+
 942      &                wcorr6*gradcorr6(j,i)+
 943      &                wturn6*gcorr6_turn(j,i)+
 944      &                wsccor*gsccorc(j,i)
 945      &               +wscloc*gscloc(j,i)
 946      &               +wliptran*gliptranc(j,i)
 947      &                +gradafm(j,i)
 948      &                 +welec*gshieldc(j,i)
 949      &                 +welec*gshieldc_loc(j,i)
 950      &                 +wcorr*gshieldc_ec(j,i)
 951      &                 +wcorr*gshieldc_loc_ec(j,i)
 952      &                 +wturn3*gshieldc_t3(j,i)
 953      &                 +wturn3*gshieldc_loc_t3(j,i)
 954      &                 +wturn4*gshieldc_t4(j,i)
 955      &                 +wturn4*gshieldc_loc_t4(j,i)
 956      &                 +wel_loc*gshieldc_ll(j,i)
 957      &                 +wel_loc*gshieldc_loc_ll(j,i)
 958      &                +wtube*gg_tube(j,i)
 959
 960
 961 #endif
 962           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 963      &                  wbond*gradbx(j,i)+
 964      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 965      &                  wsccor*gsccorx(j,i)
 966      &                 +wscloc*gsclocx(j,i)
 967      &                 +wliptran*gliptranx(j,i)
 968      &                 +welec*gshieldx(j,i)
 969      &                 +wcorr*gshieldx_ec(j,i)
 970      &                 +wturn3*gshieldx_t3(j,i)
 971      &                 +wturn4*gshieldx_t4(j,i)
 972      &                 +wel_loc*gshieldx_ll(j,i)
 973      &                 +wtube*gg_tube_sc(j,i)
 974      &                 +wsaxs*gsaxsx(j,i)
 975
 976
 977
 978         enddo
 979       enddo
 980       if (constr_homology.gt.0) then
 981         do i=1,nct
 982           do j=1,3
 983             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 984             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 985           enddo
 986         enddo
 987       endif
 988 #ifdef DEBUG
 989       write (iout,*) "gradc gradx gloc after adding"
 990       do i=1,nres
 991         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 992      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 993       enddo
 994 #endif
 995 #ifdef DEBUG
 996       write (iout,*) "gloc before adding corr"
 997       do i=1,4*nres
 998         write (iout,*) i,gloc(i,icg)
 999       enddo
1000 #endif
1001       do i=1,nres-3
1002         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1003      &   +wcorr5*g_corr5_loc(i)
1004      &   +wcorr6*g_corr6_loc(i)
1005      &   +wturn4*gel_loc_turn4(i)
1006      &   +wturn3*gel_loc_turn3(i)
1007      &   +wturn6*gel_loc_turn6(i)
1008      &   +wel_loc*gel_loc_loc(i)
1009       enddo
1010 #ifdef DEBUG
1011       write (iout,*) "gloc after adding corr"
1012       do i=1,4*nres
1013         write (iout,*) i,gloc(i,icg)
1014       enddo
1015 #endif
1016 #ifdef MPI
1017       if (nfgtasks.gt.1) then
1018         do j=1,3
1019           do i=1,nres
1020             gradbufc(j,i)=gradc(j,i,icg)
1021             gradbufx(j,i)=gradx(j,i,icg)
1022           enddo
1023         enddo
1024         do i=1,4*nres
1025           glocbuf(i)=gloc(i,icg)
1026         enddo
1027 c#define DEBUG
1028 #ifdef DEBUG
1029       write (iout,*) "gloc_sc before reduce"
1030       do i=1,nres
1031        do j=1,1
1032         write (iout,*) i,j,gloc_sc(j,i,icg)
1033        enddo
1034       enddo
1035 #endif
1036 c#undef DEBUG
1037         do i=1,nres
1038          do j=1,3
1039           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1040          enddo
1041         enddo
1042         time00=MPI_Wtime()
1043         call MPI_Barrier(FG_COMM,IERR)
1044         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1045         time00=MPI_Wtime()
1046         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1047      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1048         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1049      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1050         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1051      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1052         time_reduce=time_reduce+MPI_Wtime()-time00
1053         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1054      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1055         time_reduce=time_reduce+MPI_Wtime()-time00
1056 #ifdef DEBUG
1057       write (iout,*) "gradc after reduce"
1058       do i=1,nres
1059        do j=1,3
1060         write (iout,*) i,j,gradc(j,i,icg)
1061        enddo
1062       enddo
1063 #endif
1064 #ifdef DEBUG
1065       write (iout,*) "gloc_sc after reduce"
1066       do i=1,nres
1067        do j=1,1
1068         write (iout,*) i,j,gloc_sc(j,i,icg)
1069        enddo
1070       enddo
1071 #endif
1072 #ifdef DEBUG
1073       write (iout,*) "gloc after reduce"
1074       do i=1,4*nres
1075         write (iout,*) i,gloc(i,icg)
1076       enddo
1077 #endif
1078       endif
1079 #endif
1080       if (gnorm_check) then
1081 c
1082 c Compute the maximum elements of the gradient
1083 c
1084       gvdwc_max=0.0d0
1085       gvdwc_scp_max=0.0d0
1086       gelc_max=0.0d0
1087       gvdwpp_max=0.0d0
1088       gradb_max=0.0d0
1089       ghpbc_max=0.0d0
1090       gradcorr_max=0.0d0
1091       gel_loc_max=0.0d0
1092       gcorr3_turn_max=0.0d0
1093       gcorr4_turn_max=0.0d0
1094       gradcorr5_max=0.0d0
1095       gradcorr6_max=0.0d0
1096       gcorr6_turn_max=0.0d0
1097       gsccorrc_max=0.0d0
1098       gscloc_max=0.0d0
1099       gvdwx_max=0.0d0
1100       gradx_scp_max=0.0d0
1101       ghpbx_max=0.0d0
1102       gradxorr_max=0.0d0
1103       gsccorrx_max=0.0d0
1104       gsclocx_max=0.0d0
1105       do i=1,nct
1106         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1107         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1108         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1109         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1110      &   gvdwc_scp_max=gvdwc_scp_norm
1111         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1112         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1113         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1114         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1115         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1116         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1117         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1118         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1119         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1120         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1121         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1122         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1123         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1124      &    gcorr3_turn(1,i)))
1125         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1126      &    gcorr3_turn_max=gcorr3_turn_norm
1127         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1128      &    gcorr4_turn(1,i)))
1129         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1130      &    gcorr4_turn_max=gcorr4_turn_norm
1131         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1132         if (gradcorr5_norm.gt.gradcorr5_max)
1133      &    gradcorr5_max=gradcorr5_norm
1134         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1135         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1136         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1137      &    gcorr6_turn(1,i)))
1138         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1139      &    gcorr6_turn_max=gcorr6_turn_norm
1140         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1141         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1142         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1143         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1144         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1145         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1146         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1147         if (gradx_scp_norm.gt.gradx_scp_max)
1148      &    gradx_scp_max=gradx_scp_norm
1149         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1150         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1151         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1152         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1153         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1154         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1155         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1156         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1157       enddo
1158       if (gradout) then
1159 #if (defined AIX || defined CRAY)
1160         open(istat,file=statname,position="append")
1161 #else
1162         open(istat,file=statname,access="append")
1163 #endif
1164         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1165      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1166      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1167      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1168      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1169      &     gsccorrx_max,gsclocx_max
1170         close(istat)
1171         if (gvdwc_max.gt.1.0d4) then
1172           write (iout,*) "gvdwc gvdwx gradb gradbx"
1173           do i=nnt,nct
1174             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1175      &        gradb(j,i),gradbx(j,i),j=1,3)
1176           enddo
1177           call pdbout(0.0d0,'cipiszcze',iout)
1178           call flush(iout)
1179         endif
1180       endif
1181       endif
1182 #ifdef DEBUG
1183       write (iout,*) "gradc gradx gloc"
1184       do i=1,nres
1185         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1186      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1187       enddo
1188 #endif
1189 #ifdef TIMING
1190       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1191 #endif
1192       return
1193       end
1194 c-------------------------------------------------------------------------------
1195       subroutine rescale_weights(t_bath)
1196       implicit none
1197 #ifdef MPI
1198       include 'mpif.h'
1199       integer ierror
1200 #endif
1201       include 'DIMENSIONS'
1202       include 'COMMON.IOUNITS'
1203       include 'COMMON.FFIELD'
1204       include 'COMMON.SBRIDGE'
1205       include 'COMMON.CONTROL'
1206       double precision t_bath
1207       double precision facT,facT2,facT3,facT4,facT5
1208       double precision kfac /2.4d0/
1209       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1210 c      facT=temp0/t_bath
1211 c      facT=2*temp0/(t_bath+temp0)
1212       if (rescale_mode.eq.0) then
1213         facT=1.0d0
1214         facT2=1.0d0
1215         facT3=1.0d0
1216         facT4=1.0d0
1217         facT5=1.0d0
1218       else if (rescale_mode.eq.1) then
1219         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1220         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1221         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1222         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1223         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1224       else if (rescale_mode.eq.2) then
1225         x=t_bath/temp0
1226         x2=x*x
1227         x3=x2*x
1228         x4=x3*x
1229         x5=x4*x
1230         facT=licznik/dlog(dexp(x)+dexp(-x))
1231         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1232         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1233         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1234         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1235       else
1236         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1237         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1238 #ifdef MPI
1239        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1240 #endif
1241        stop 555
1242       endif
1243       if (shield_mode.gt.0) then
1244        wscp=weights(2)*fact
1245        wsc=weights(1)*fact
1246        wvdwpp=weights(16)*fact
1247       endif
1248       welec=weights(3)*fact
1249       wcorr=weights(4)*fact3
1250       wcorr5=weights(5)*fact4
1251       wcorr6=weights(6)*fact5
1252       wel_loc=weights(7)*fact2
1253       wturn3=weights(8)*fact2
1254       wturn4=weights(9)*fact3
1255       wturn6=weights(10)*fact5
1256       wtor=weights(13)*fact
1257       wtor_d=weights(14)*fact2
1258       wsccor=weights(21)*fact
1259       if (scale_umb) wumb=t_bath/temp0
1260 c      write (iout,*) "scale_umb",scale_umb
1261 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1262
1263       return
1264       end
1265 C------------------------------------------------------------------------
1266       subroutine enerprint(energia)
1267       implicit none
1268       include 'DIMENSIONS'
1269       include 'COMMON.IOUNITS'
1270       include 'COMMON.FFIELD'
1271       include 'COMMON.SBRIDGE'
1272       include 'COMMON.QRESTR'
1273       double precision energia(0:n_ene)
1274       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1275      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1276      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1277      & eello_turn6,
1278      & eliptran,Eafmforce,Etube,
1279      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1280       etot=energia(0)
1281       evdw=energia(1)
1282       evdw2=energia(2)
1283 #ifdef SCP14
1284       evdw2=energia(2)+energia(18)
1285 #else
1286       evdw2=energia(2)
1287 #endif
1288       ees=energia(3)
1289 #ifdef SPLITELE
1290       evdw1=energia(16)
1291 #endif
1292       ecorr=energia(4)
1293       ecorr5=energia(5)
1294       ecorr6=energia(6)
1295       eel_loc=energia(7)
1296       eello_turn3=energia(8)
1297       eello_turn4=energia(9)
1298       eello_turn6=energia(10)
1299       ebe=energia(11)
1300       escloc=energia(12)
1301       etors=energia(13)
1302       etors_d=energia(14)
1303       ehpb=energia(15)
1304       edihcnstr=energia(19)
1305       estr=energia(17)
1306       Uconst=energia(20)
1307       esccor=energia(21)
1308       eliptran=energia(22)
1309       Eafmforce=energia(23)
1310       ethetacnstr=energia(24)
1311       etube=energia(25)
1312       esaxs=energia(26)
1313       ehomology_constr=energia(27)
1314 C     Bartek
1315       edfadis = energia(28)
1316       edfator = energia(29)
1317       edfanei = energia(30)
1318       edfabet = energia(31)
1319 #ifdef SPLITELE
1320       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1321      &  estr,wbond,ebe,wang,
1322      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1323 #ifdef FOURBODY
1324      &  ecorr,wcorr,
1325      &  ecorr5,wcorr5,ecorr6,wcorr6,
1326 #endif
1327      &  eel_loc,wel_loc,eello_turn3,wturn3,
1328      &  eello_turn4,wturn4,
1329 #ifdef FOURBODY
1330      &  eello_turn6,wturn6,
1331 #endif
1332      &  esccor,wsccor,edihcnstr,
1333      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1334      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1335      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1336      &  edfabet,wdfa_beta,
1337      &  etot
1338    10 format (/'Virtual-chain energies:'//
1339      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1340      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1341      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1342      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1343      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1344      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1345      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1346      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1347      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1348      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1349      & ' (SS bridges & dist. cnstr.)'/
1350 #ifdef FOURBODY
1351      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1352      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1353      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1354 #endif
1355      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1356      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1357      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1358 #ifdef FOURBODY
1359      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1360 #endif
1361      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1362      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1363      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1364      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1365      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1366      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1367      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1368      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1369      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1370      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1371      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1372      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1373      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1374      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1375      & 'ETOT=  ',1pE16.6,' (total)')
1376
1377 #else
1378       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1379      &  estr,wbond,ebe,wang,
1380      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1381 #ifdef FOURBODY
1382      &  ecorr,wcorr,
1383      &  ecorr5,wcorr5,ecorr6,wcorr6,
1384 #endif
1385      &  eel_loc,wel_loc,eello_turn3,wturn3,
1386      &  eello_turn4,wturn4,
1387 #ifdef FOURBODY
1388      &  eello_turn6,wturn6,
1389 #endif
1390      &  esccor,wsccor,edihcnstr,
1391      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1392      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1393      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1394      &  edfabet,wdfa_beta,
1395      &  etot
1396    10 format (/'Virtual-chain energies:'//
1397      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1398      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1399      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1400      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1401      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1402      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1403      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1404      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1405      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1406      & ' (SS bridges & dist. restr.)'/
1407 #ifdef FOURBODY
1408      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1409      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1410      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1411 #endif
1412      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1413      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1414      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1415 #ifdef FOURBODY
1416      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1417 #endif
1418      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1419      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1420      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1421      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1422      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1423      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1424      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1425      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1426      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1427      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1428      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1429      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1430      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1431      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1432      & 'ETOT=  ',1pE16.6,' (total)')
1433 #endif
1434       return
1435       end
1436 C-----------------------------------------------------------------------
1437       subroutine elj(evdw)
1438 C
1439 C This subroutine calculates the interaction energy of nonbonded side chains
1440 C assuming the LJ potential of interaction.
1441 C
1442       implicit none
1443       double precision accur
1444       include 'DIMENSIONS'
1445       parameter (accur=1.0d-10)
1446       include 'COMMON.GEO'
1447       include 'COMMON.VAR'
1448       include 'COMMON.LOCAL'
1449       include 'COMMON.CHAIN'
1450       include 'COMMON.DERIV'
1451       include 'COMMON.INTERACT'
1452       include 'COMMON.TORSION'
1453       include 'COMMON.SBRIDGE'
1454       include 'COMMON.NAMES'
1455       include 'COMMON.IOUNITS'
1456       include 'COMMON.SPLITELE'
1457 #ifdef FOURBODY
1458       include 'COMMON.CONTACTS'
1459       include 'COMMON.CONTMAT'
1460 #endif
1461       double precision gg(3)
1462       double precision evdw,evdwij
1463       integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1464       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1465      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1466       double precision fcont,fprimcont
1467       double precision sscale,sscagrad
1468 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1469       evdw=0.0D0
1470       do i=iatsc_s,iatsc_e
1471         itypi=iabs(itype(i))
1472         if (itypi.eq.ntyp1) cycle
1473         itypi1=iabs(itype(i+1))
1474         xi=c(1,nres+i)
1475         yi=c(2,nres+i)
1476         zi=c(3,nres+i)
1477 C Change 12/1/95
1478         num_conti=0
1479 C
1480 C Calculate SC interaction energy.
1481 C
1482         do iint=1,nint_gr(i)
1483 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1484 cd   &                  'iend=',iend(i,iint)
1485           do j=istart(i,iint),iend(i,iint)
1486             itypj=iabs(itype(j))
1487             if (itypj.eq.ntyp1) cycle
1488             xj=c(1,nres+j)-xi
1489             yj=c(2,nres+j)-yi
1490             zj=c(3,nres+j)-zi
1491 C Change 12/1/95 to calculate four-body interactions
1492             rij=xj*xj+yj*yj+zj*zj
1493             rrij=1.0D0/rij
1494             sqrij=dsqrt(rij)
1495             sss1=sscale(sqrij,r_cut_int)
1496             if (sss1.eq.0.0d0) cycle
1497             sssgrad1=sscagrad(sqrij,r_cut_int)
1498
1499 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1500             eps0ij=eps(itypi,itypj)
1501             fac=rrij**expon2
1502 C have you changed here?
1503             e1=fac*fac*aa
1504             e2=fac*bb
1505             evdwij=e1+e2
1506 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1509 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1510 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1511 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1512             evdw=evdw+sss1*evdwij
1513 C
1514 C Calculate the components of the gradient in DC and X
1515 C
1516             fac=-rrij*(e1+evdwij)*sss1
1517      &          +evdwij*sssgrad1/sqrij/expon
1518             gg(1)=xj*fac
1519             gg(2)=yj*fac
1520             gg(3)=zj*fac
1521             do k=1,3
1522               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1523               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1524               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1525               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1526             enddo
1527 cgrad            do k=i,j-1
1528 cgrad              do l=1,3
1529 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1530 cgrad              enddo
1531 cgrad            enddo
1532 C
1533 #ifdef FOURBODY
1534 C 12/1/95, revised on 5/20/97
1535 C
1536 C Calculate the contact function. The ith column of the array JCONT will
1537 C contain the numbers of atoms that make contacts with the atom I (of numbers
1538 C greater than I). The arrays FACONT and GACONT will contain the values of
1539 C the contact function and its derivative.
1540 C
1541 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1542 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1543 C Uncomment next line, if the correlation interactions are contact function only
1544             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1545               rij=dsqrt(rij)
1546               sigij=sigma(itypi,itypj)
1547               r0ij=rs0(itypi,itypj)
1548 C
1549 C Check whether the SC's are not too far to make a contact.
1550 C
1551               rcut=1.5d0*r0ij
1552               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1553 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1554 C
1555               if (fcont.gt.0.0D0) then
1556 C If the SC-SC distance if close to sigma, apply spline.
1557 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1558 cAdam &             fcont1,fprimcont1)
1559 cAdam           fcont1=1.0d0-fcont1
1560 cAdam           if (fcont1.gt.0.0d0) then
1561 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1562 cAdam             fcont=fcont*fcont1
1563 cAdam           endif
1564 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1565 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1566 cga             do k=1,3
1567 cga               gg(k)=gg(k)*eps0ij
1568 cga             enddo
1569 cga             eps0ij=-evdwij*eps0ij
1570 C Uncomment for AL's type of SC correlation interactions.
1571 cadam           eps0ij=-evdwij
1572                 num_conti=num_conti+1
1573                 jcont(num_conti,i)=j
1574                 facont(num_conti,i)=fcont*eps0ij
1575                 fprimcont=eps0ij*fprimcont/rij
1576                 fcont=expon*fcont
1577 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1578 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1579 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1580 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1581                 gacont(1,num_conti,i)=-fprimcont*xj
1582                 gacont(2,num_conti,i)=-fprimcont*yj
1583                 gacont(3,num_conti,i)=-fprimcont*zj
1584 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1585 cd              write (iout,'(2i3,3f10.5)')
1586 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1587               endif
1588             endif
1589 #endif
1590           enddo      ! j
1591         enddo        ! iint
1592 C Change 12/1/95
1593 #ifdef FOURBODY
1594         num_cont(i)=num_conti
1595 #endif
1596       enddo          ! i
1597       do i=1,nct
1598         do j=1,3
1599           gvdwc(j,i)=expon*gvdwc(j,i)
1600           gvdwx(j,i)=expon*gvdwx(j,i)
1601         enddo
1602       enddo
1603 C******************************************************************************
1604 C
1605 C                              N O T E !!!
1606 C
1607 C To save time, the factor of EXPON has been extracted from ALL components
1608 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1609 C use!
1610 C
1611 C******************************************************************************
1612       return
1613       end
1614 C-----------------------------------------------------------------------------
1615       subroutine eljk(evdw)
1616 C
1617 C This subroutine calculates the interaction energy of nonbonded side chains
1618 C assuming the LJK potential of interaction.
1619 C
1620       implicit none
1621       include 'DIMENSIONS'
1622       include 'COMMON.GEO'
1623       include 'COMMON.VAR'
1624       include 'COMMON.LOCAL'
1625       include 'COMMON.CHAIN'
1626       include 'COMMON.DERIV'
1627       include 'COMMON.INTERACT'
1628       include 'COMMON.IOUNITS'
1629       include 'COMMON.NAMES'
1630       include 'COMMON.SPLITELE'
1631       double precision gg(3)
1632       double precision evdw,evdwij
1633       integer i,j,k,itypi,itypj,itypi1,iint
1634       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1635      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1636       logical scheck
1637       double precision sscale,sscagrad
1638 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1639       evdw=0.0D0
1640       do i=iatsc_s,iatsc_e
1641         itypi=iabs(itype(i))
1642         if (itypi.eq.ntyp1) cycle
1643         itypi1=iabs(itype(i+1))
1644         xi=c(1,nres+i)
1645         yi=c(2,nres+i)
1646         zi=c(3,nres+i)
1647 C
1648 C Calculate SC interaction energy.
1649 C
1650         do iint=1,nint_gr(i)
1651           do j=istart(i,iint),iend(i,iint)
1652             itypj=iabs(itype(j))
1653             if (itypj.eq.ntyp1) cycle
1654             xj=c(1,nres+j)-xi
1655             yj=c(2,nres+j)-yi
1656             zj=c(3,nres+j)-zi
1657             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1658             fac_augm=rrij**expon
1659             e_augm=augm(itypi,itypj)*fac_augm
1660             r_inv_ij=dsqrt(rrij)
1661             rij=1.0D0/r_inv_ij
1662             sss1=sscale(rij,r_cut_int)
1663             if (sss1.eq.0.0d0) cycle
1664             sssgrad1=sscagrad(rij,r_cut_int)
1665             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1666             fac=r_shift_inv**expon
1667 C have you changed here?
1668             e1=fac*fac*aa
1669             e2=fac*bb
1670             evdwij=e_augm+e1+e2
1671 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1672 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1673 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1674 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1675 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1676 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1677 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1678             evdw=evdw+evdwij*sss1
1679 C
1680 C Calculate the components of the gradient in DC and X
1681 C
1682             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1683      &          +evdwij*sssgrad1*r_inv_ij/expon
1684             gg(1)=xj*fac
1685             gg(2)=yj*fac
1686             gg(3)=zj*fac
1687             do k=1,3
1688               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1689               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1690               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1691               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1692             enddo
1693 cgrad            do k=i,j-1
1694 cgrad              do l=1,3
1695 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1696 cgrad              enddo
1697 cgrad            enddo
1698           enddo      ! j
1699         enddo        ! iint
1700       enddo          ! i
1701       do i=1,nct
1702         do j=1,3
1703           gvdwc(j,i)=expon*gvdwc(j,i)
1704           gvdwx(j,i)=expon*gvdwx(j,i)
1705         enddo
1706       enddo
1707       return
1708       end
1709 C-----------------------------------------------------------------------------
1710       subroutine ebp(evdw)
1711 C
1712 C This subroutine calculates the interaction energy of nonbonded side chains
1713 C assuming the Berne-Pechukas potential of interaction.
1714 C
1715       implicit none
1716       include 'DIMENSIONS'
1717       include 'COMMON.GEO'
1718       include 'COMMON.VAR'
1719       include 'COMMON.LOCAL'
1720       include 'COMMON.CHAIN'
1721       include 'COMMON.DERIV'
1722       include 'COMMON.NAMES'
1723       include 'COMMON.INTERACT'
1724       include 'COMMON.IOUNITS'
1725       include 'COMMON.CALC'
1726       include 'COMMON.SPLITELE'
1727       integer icall
1728       common /srutu/ icall
1729       double precision evdw
1730       integer itypi,itypj,itypi1,iint,ind
1731       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1732      & sss1,sssgrad1
1733       double precision sscale,sscagrad
1734 c     double precision rrsave(maxdim)
1735       logical lprn
1736       evdw=0.0D0
1737 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1738       evdw=0.0D0
1739 c     if (icall.eq.0) then
1740 c       lprn=.true.
1741 c     else
1742         lprn=.false.
1743 c     endif
1744       ind=0
1745       do i=iatsc_s,iatsc_e
1746         itypi=iabs(itype(i))
1747         if (itypi.eq.ntyp1) cycle
1748         itypi1=iabs(itype(i+1))
1749         xi=c(1,nres+i)
1750         yi=c(2,nres+i)
1751         zi=c(3,nres+i)
1752         dxi=dc_norm(1,nres+i)
1753         dyi=dc_norm(2,nres+i)
1754         dzi=dc_norm(3,nres+i)
1755 c        dsci_inv=dsc_inv(itypi)
1756         dsci_inv=vbld_inv(i+nres)
1757 C
1758 C Calculate SC interaction energy.
1759 C
1760         do iint=1,nint_gr(i)
1761           do j=istart(i,iint),iend(i,iint)
1762             ind=ind+1
1763             itypj=iabs(itype(j))
1764             if (itypj.eq.ntyp1) cycle
1765 c            dscj_inv=dsc_inv(itypj)
1766             dscj_inv=vbld_inv(j+nres)
1767             chi1=chi(itypi,itypj)
1768             chi2=chi(itypj,itypi)
1769             chi12=chi1*chi2
1770             chip1=chip(itypi)
1771             chip2=chip(itypj)
1772             chip12=chip1*chip2
1773             alf1=alp(itypi)
1774             alf2=alp(itypj)
1775             alf12=0.5D0*(alf1+alf2)
1776 C For diagnostics only!!!
1777 c           chi1=0.0D0
1778 c           chi2=0.0D0
1779 c           chi12=0.0D0
1780 c           chip1=0.0D0
1781 c           chip2=0.0D0
1782 c           chip12=0.0D0
1783 c           alf1=0.0D0
1784 c           alf2=0.0D0
1785 c           alf12=0.0D0
1786             xj=c(1,nres+j)-xi
1787             yj=c(2,nres+j)-yi
1788             zj=c(3,nres+j)-zi
1789             dxj=dc_norm(1,nres+j)
1790             dyj=dc_norm(2,nres+j)
1791             dzj=dc_norm(3,nres+j)
1792             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1793 cd          if (icall.eq.0) then
1794 cd            rrsave(ind)=rrij
1795 cd          else
1796 cd            rrij=rrsave(ind)
1797 cd          endif
1798             rij=dsqrt(rrij)
1799             sss1=sscale(1.0d0/rij,r_cut_int)
1800             if (sss1.eq.0.0d0) cycle
1801             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1802 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1803             call sc_angular
1804 C Calculate whole angle-dependent part of epsilon and contributions
1805 C to its derivatives
1806 C have you changed here?
1807             fac=(rrij*sigsq)**expon2
1808             e1=fac*fac*aa
1809             e2=fac*bb
1810             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1811             eps2der=evdwij*eps3rt
1812             eps3der=evdwij*eps2rt
1813             evdwij=evdwij*eps2rt*eps3rt
1814             evdw=evdw+sss1*evdwij
1815             if (lprn) then
1816             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1817             epsi=bb**2/aa
1818 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1819 cd     &        restyp(itypi),i,restyp(itypj),j,
1820 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1821 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1822 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1823 cd     &        evdwij
1824             endif
1825 C Calculate gradient components.
1826             e1=e1*eps1*eps2rt**2*eps3rt**2
1827             fac=-expon*(e1+evdwij)
1828             sigder=fac/sigsq
1829             fac=rrij*fac
1830      &          +evdwij*sssgrad1/sss1*rij
1831 C Calculate radial part of the gradient
1832             gg(1)=xj*fac
1833             gg(2)=yj*fac
1834             gg(3)=zj*fac
1835 C Calculate the angular part of the gradient and sum add the contributions
1836 C to the appropriate components of the Cartesian gradient.
1837             call sc_grad
1838           enddo      ! j
1839         enddo        ! iint
1840       enddo          ! i
1841 c     stop
1842       return
1843       end
1844 C-----------------------------------------------------------------------------
1845       subroutine egb(evdw)
1846 C
1847 C This subroutine calculates the interaction energy of nonbonded side chains
1848 C assuming the Gay-Berne potential of interaction.
1849 C
1850       implicit none
1851       include 'DIMENSIONS'
1852       include 'COMMON.GEO'
1853       include 'COMMON.VAR'
1854       include 'COMMON.LOCAL'
1855       include 'COMMON.CHAIN'
1856       include 'COMMON.DERIV'
1857       include 'COMMON.NAMES'
1858       include 'COMMON.INTERACT'
1859       include 'COMMON.IOUNITS'
1860       include 'COMMON.CALC'
1861       include 'COMMON.CONTROL'
1862       include 'COMMON.SPLITELE'
1863       include 'COMMON.SBRIDGE'
1864       logical lprn
1865       integer xshift,yshift,zshift,subchap
1866       double precision evdw
1867       integer itypi,itypj,itypi1,iint,ind
1868       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1869       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1870      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1871      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1872       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1873       evdw=0.0D0
1874 ccccc      energy_dec=.false.
1875 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1876       evdw=0.0D0
1877       lprn=.false.
1878 c     if (icall.eq.0) lprn=.false.
1879       ind=0
1880 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1881 C we have the original box)
1882 C      do xshift=-1,1
1883 C      do yshift=-1,1
1884 C      do zshift=-1,1
1885       do i=iatsc_s,iatsc_e
1886         itypi=iabs(itype(i))
1887         if (itypi.eq.ntyp1) cycle
1888         itypi1=iabs(itype(i+1))
1889         xi=c(1,nres+i)
1890         yi=c(2,nres+i)
1891         zi=c(3,nres+i)
1892 C Return atom into box, boxxsize is size of box in x dimension
1893 c  134   continue
1894 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1895 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1896 C Condition for being inside the proper box
1897 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1898 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1899 c        go to 134
1900 c        endif
1901 c  135   continue
1902 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1903 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1904 C Condition for being inside the proper box
1905 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1906 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1907 c        go to 135
1908 c        endif
1909 c  136   continue
1910 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1911 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1912 C Condition for being inside the proper box
1913 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1914 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1915 c        go to 136
1916 c        endif
1917           xi=mod(xi,boxxsize)
1918           if (xi.lt.0) xi=xi+boxxsize
1919           yi=mod(yi,boxysize)
1920           if (yi.lt.0) yi=yi+boxysize
1921           zi=mod(zi,boxzsize)
1922           if (zi.lt.0) zi=zi+boxzsize
1923 C define scaling factor for lipids
1924
1925 C        if (positi.le.0) positi=positi+boxzsize
1926 C        print *,i
1927 C first for peptide groups
1928 c for each residue check if it is in lipid or lipid water border area
1929        if ((zi.gt.bordlipbot)
1930      &.and.(zi.lt.bordliptop)) then
1931 C the energy transfer exist
1932         if (zi.lt.buflipbot) then
1933 C what fraction I am in
1934          fracinbuf=1.0d0-
1935      &        ((zi-bordlipbot)/lipbufthick)
1936 C lipbufthick is thickenes of lipid buffore
1937          sslipi=sscalelip(fracinbuf)
1938          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1939         elseif (zi.gt.bufliptop) then
1940          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1941          sslipi=sscalelip(fracinbuf)
1942          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1943         else
1944          sslipi=1.0d0
1945          ssgradlipi=0.0
1946         endif
1947        else
1948          sslipi=0.0d0
1949          ssgradlipi=0.0
1950        endif
1951
1952 C          xi=xi+xshift*boxxsize
1953 C          yi=yi+yshift*boxysize
1954 C          zi=zi+zshift*boxzsize
1955
1956         dxi=dc_norm(1,nres+i)
1957         dyi=dc_norm(2,nres+i)
1958         dzi=dc_norm(3,nres+i)
1959 c        dsci_inv=dsc_inv(itypi)
1960         dsci_inv=vbld_inv(i+nres)
1961 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1962 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1963 C
1964 C Calculate SC interaction energy.
1965 C
1966         do iint=1,nint_gr(i)
1967           do j=istart(i,iint),iend(i,iint)
1968             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1969
1970 c              write(iout,*) "PRZED ZWYKLE", evdwij
1971               call dyn_ssbond_ene(i,j,evdwij)
1972 c              write(iout,*) "PO ZWYKLE", evdwij
1973
1974               evdw=evdw+evdwij
1975               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1976      &                        'evdw',i,j,evdwij,' ss'
1977 C triple bond artifac removal
1978              do k=j+1,iend(i,iint)
1979 C search over all next residues
1980               if (dyn_ss_mask(k)) then
1981 C check if they are cysteins
1982 C              write(iout,*) 'k=',k
1983
1984 c              write(iout,*) "PRZED TRI", evdwij
1985                evdwij_przed_tri=evdwij
1986               call triple_ssbond_ene(i,j,k,evdwij)
1987 c               if(evdwij_przed_tri.ne.evdwij) then
1988 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1989 c               endif
1990
1991 c              write(iout,*) "PO TRI", evdwij
1992 C call the energy function that removes the artifical triple disulfide
1993 C bond the soubroutine is located in ssMD.F
1994               evdw=evdw+evdwij
1995               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1996      &                        'evdw',i,j,evdwij,'tss'
1997               endif!dyn_ss_mask(k)
1998              enddo! k
1999             ELSE
2000             ind=ind+1
2001             itypj=iabs(itype(j))
2002             if (itypj.eq.ntyp1) cycle
2003 c            dscj_inv=dsc_inv(itypj)
2004             dscj_inv=vbld_inv(j+nres)
2005 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2006 c     &       1.0d0/vbld(j+nres)
2007 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2008             sig0ij=sigma(itypi,itypj)
2009             chi1=chi(itypi,itypj)
2010             chi2=chi(itypj,itypi)
2011             chi12=chi1*chi2
2012             chip1=chip(itypi)
2013             chip2=chip(itypj)
2014             chip12=chip1*chip2
2015             alf1=alp(itypi)
2016             alf2=alp(itypj)
2017             alf12=0.5D0*(alf1+alf2)
2018 C For diagnostics only!!!
2019 c           chi1=0.0D0
2020 c           chi2=0.0D0
2021 c           chi12=0.0D0
2022 c           chip1=0.0D0
2023 c           chip2=0.0D0
2024 c           chip12=0.0D0
2025 c           alf1=0.0D0
2026 c           alf2=0.0D0
2027 c           alf12=0.0D0
2028             xj=c(1,nres+j)
2029             yj=c(2,nres+j)
2030             zj=c(3,nres+j)
2031 C Return atom J into box the original box
2032 c  137   continue
2033 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2034 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2035 C Condition for being inside the proper box
2036 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2037 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2038 c        go to 137
2039 c        endif
2040 c  138   continue
2041 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2042 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2043 C Condition for being inside the proper box
2044 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2045 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2046 c        go to 138
2047 c        endif
2048 c  139   continue
2049 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2050 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2051 C Condition for being inside the proper box
2052 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2053 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2054 c        go to 139
2055 c        endif
2056           xj=mod(xj,boxxsize)
2057           if (xj.lt.0) xj=xj+boxxsize
2058           yj=mod(yj,boxysize)
2059           if (yj.lt.0) yj=yj+boxysize
2060           zj=mod(zj,boxzsize)
2061           if (zj.lt.0) zj=zj+boxzsize
2062        if ((zj.gt.bordlipbot)
2063      &.and.(zj.lt.bordliptop)) then
2064 C the energy transfer exist
2065         if (zj.lt.buflipbot) then
2066 C what fraction I am in
2067          fracinbuf=1.0d0-
2068      &        ((zj-bordlipbot)/lipbufthick)
2069 C lipbufthick is thickenes of lipid buffore
2070          sslipj=sscalelip(fracinbuf)
2071          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2072         elseif (zj.gt.bufliptop) then
2073          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2074          sslipj=sscalelip(fracinbuf)
2075          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2076         else
2077          sslipj=1.0d0
2078          ssgradlipj=0.0
2079         endif
2080        else
2081          sslipj=0.0d0
2082          ssgradlipj=0.0
2083        endif
2084       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2085      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2086       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2087      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2088 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2089 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2090 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2091 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2092 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2093       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2094       xj_safe=xj
2095       yj_safe=yj
2096       zj_safe=zj
2097       subchap=0
2098       do xshift=-1,1
2099       do yshift=-1,1
2100       do zshift=-1,1
2101           xj=xj_safe+xshift*boxxsize
2102           yj=yj_safe+yshift*boxysize
2103           zj=zj_safe+zshift*boxzsize
2104           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2105           if(dist_temp.lt.dist_init) then
2106             dist_init=dist_temp
2107             xj_temp=xj
2108             yj_temp=yj
2109             zj_temp=zj
2110             subchap=1
2111           endif
2112        enddo
2113        enddo
2114        enddo
2115        if (subchap.eq.1) then
2116           xj=xj_temp-xi
2117           yj=yj_temp-yi
2118           zj=zj_temp-zi
2119        else
2120           xj=xj_safe-xi
2121           yj=yj_safe-yi
2122           zj=zj_safe-zi
2123        endif
2124             dxj=dc_norm(1,nres+j)
2125             dyj=dc_norm(2,nres+j)
2126             dzj=dc_norm(3,nres+j)
2127 C            xj=xj-xi
2128 C            yj=yj-yi
2129 C            zj=zj-zi
2130 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2131 c            write (iout,*) "j",j," dc_norm",
2132 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2133             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2134             rij=dsqrt(rrij)
2135             sss=sscale(1.0d0/rij,r_cut_int)
2136 c            write (iout,'(a7,4f8.3)')
2137 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2138             if (sss.eq.0.0d0) cycle
2139             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2140 C Calculate angle-dependent terms of energy and contributions to their
2141 C derivatives.
2142             call sc_angular
2143             sigsq=1.0D0/sigsq
2144             sig=sig0ij*dsqrt(sigsq)
2145             rij_shift=1.0D0/rij-sig+sig0ij
2146 c for diagnostics; uncomment
2147 c            rij_shift=1.2*sig0ij
2148 C I hate to put IF's in the loops, but here don't have another choice!!!!
2149             if (rij_shift.le.0.0D0) then
2150               evdw=1.0D20
2151 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2152 cd     &        restyp(itypi),i,restyp(itypj),j,
2153 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2154               return
2155             endif
2156             sigder=-sig*sigsq
2157 c---------------------------------------------------------------
2158             rij_shift=1.0D0/rij_shift
2159             fac=rij_shift**expon
2160 C here to start with
2161 C            if (c(i,3).gt.
2162             faclip=fac
2163             e1=fac*fac*aa
2164             e2=fac*bb
2165             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2166             eps2der=evdwij*eps3rt
2167             eps3der=evdwij*eps2rt
2168 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2169 C     &((sslipi+sslipj)/2.0d0+
2170 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2171 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2172 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2173             evdwij=evdwij*eps2rt*eps3rt
2174             evdw=evdw+evdwij*sss
2175             if (lprn) then
2176             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2177             epsi=bb**2/aa
2178             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2179      &        restyp(itypi),i,restyp(itypj),j,
2180      &        epsi,sigm,chi1,chi2,chip1,chip2,
2181      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2182      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2183      &        evdwij
2184             endif
2185
2186             if (energy_dec) write (iout,'(a,2i5,3f10.5)')
2187      &                    'r sss evdw',i,j,rij,sss,evdwij
2188
2189 C Calculate gradient components.
2190             e1=e1*eps1*eps2rt**2*eps3rt**2
2191             fac=-expon*(e1+evdwij)*rij_shift
2192             sigder=fac*sigder
2193             fac=rij*fac
2194 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2195 c     &      evdwij,fac,sigma(itypi,itypj),expon
2196             fac=fac+evdwij*sssgrad/sss*rij
2197 c            fac=0.0d0
2198 C Calculate the radial part of the gradient
2199             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2200      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2201      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2202      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2203             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2204             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2205 C            gg_lipi(3)=0.0d0
2206 C            gg_lipj(3)=0.0d0
2207             gg(1)=xj*fac
2208             gg(2)=yj*fac
2209             gg(3)=zj*fac
2210 C Calculate angular part of the gradient.
2211 c            call sc_grad_scale(sss)
2212             call sc_grad
2213             ENDIF    ! dyn_ss
2214           enddo      ! j
2215         enddo        ! iint
2216       enddo          ! i
2217 C      enddo          ! zshift
2218 C      enddo          ! yshift
2219 C      enddo          ! xshift
2220 c      write (iout,*) "Number of loop steps in EGB:",ind
2221 cccc      energy_dec=.false.
2222       return
2223       end
2224 C-----------------------------------------------------------------------------
2225       subroutine egbv(evdw)
2226 C
2227 C This subroutine calculates the interaction energy of nonbonded side chains
2228 C assuming the Gay-Berne-Vorobjev potential of interaction.
2229 C
2230       implicit none
2231       include 'DIMENSIONS'
2232       include 'COMMON.GEO'
2233       include 'COMMON.VAR'
2234       include 'COMMON.LOCAL'
2235       include 'COMMON.CHAIN'
2236       include 'COMMON.DERIV'
2237       include 'COMMON.NAMES'
2238       include 'COMMON.INTERACT'
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.CALC'
2241       include 'COMMON.SPLITELE'
2242       integer xshift,yshift,zshift,subchap
2243       integer icall
2244       common /srutu/ icall
2245       logical lprn
2246       double precision evdw
2247       integer itypi,itypj,itypi1,iint,ind
2248       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2249      & xi,yi,zi,fac_augm,e_augm
2250       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2251      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2252      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip,sssgrad1
2253       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2254       evdw=0.0D0
2255 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2256       evdw=0.0D0
2257       lprn=.false.
2258 c     if (icall.eq.0) lprn=.true.
2259       ind=0
2260       do i=iatsc_s,iatsc_e
2261         itypi=iabs(itype(i))
2262         if (itypi.eq.ntyp1) cycle
2263         itypi1=iabs(itype(i+1))
2264         xi=c(1,nres+i)
2265         yi=c(2,nres+i)
2266         zi=c(3,nres+i)
2267           xi=mod(xi,boxxsize)
2268           if (xi.lt.0) xi=xi+boxxsize
2269           yi=mod(yi,boxysize)
2270           if (yi.lt.0) yi=yi+boxysize
2271           zi=mod(zi,boxzsize)
2272           if (zi.lt.0) zi=zi+boxzsize
2273 C define scaling factor for lipids
2274
2275 C        if (positi.le.0) positi=positi+boxzsize
2276 C        print *,i
2277 C first for peptide groups
2278 c for each residue check if it is in lipid or lipid water border area
2279        if ((zi.gt.bordlipbot)
2280      &.and.(zi.lt.bordliptop)) then
2281 C the energy transfer exist
2282         if (zi.lt.buflipbot) then
2283 C what fraction I am in
2284          fracinbuf=1.0d0-
2285      &        ((zi-bordlipbot)/lipbufthick)
2286 C lipbufthick is thickenes of lipid buffore
2287          sslipi=sscalelip(fracinbuf)
2288          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2289         elseif (zi.gt.bufliptop) then
2290          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2291          sslipi=sscalelip(fracinbuf)
2292          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2293         else
2294          sslipi=1.0d0
2295          ssgradlipi=0.0
2296         endif
2297        else
2298          sslipi=0.0d0
2299          ssgradlipi=0.0
2300        endif
2301
2302         dxi=dc_norm(1,nres+i)
2303         dyi=dc_norm(2,nres+i)
2304         dzi=dc_norm(3,nres+i)
2305 c        dsci_inv=dsc_inv(itypi)
2306         dsci_inv=vbld_inv(i+nres)
2307 C
2308 C Calculate SC interaction energy.
2309 C
2310         do iint=1,nint_gr(i)
2311           do j=istart(i,iint),iend(i,iint)
2312             ind=ind+1
2313             itypj=iabs(itype(j))
2314             if (itypj.eq.ntyp1) cycle
2315 c            dscj_inv=dsc_inv(itypj)
2316             dscj_inv=vbld_inv(j+nres)
2317             sig0ij=sigma(itypi,itypj)
2318             r0ij=r0(itypi,itypj)
2319             chi1=chi(itypi,itypj)
2320             chi2=chi(itypj,itypi)
2321             chi12=chi1*chi2
2322             chip1=chip(itypi)
2323             chip2=chip(itypj)
2324             chip12=chip1*chip2
2325             alf1=alp(itypi)
2326             alf2=alp(itypj)
2327             alf12=0.5D0*(alf1+alf2)
2328 C For diagnostics only!!!
2329 c           chi1=0.0D0
2330 c           chi2=0.0D0
2331 c           chi12=0.0D0
2332 c           chip1=0.0D0
2333 c           chip2=0.0D0
2334 c           chip12=0.0D0
2335 c           alf1=0.0D0
2336 c           alf2=0.0D0
2337 c           alf12=0.0D0
2338 C            xj=c(1,nres+j)-xi
2339 C            yj=c(2,nres+j)-yi
2340 C            zj=c(3,nres+j)-zi
2341           xj=mod(xj,boxxsize)
2342           if (xj.lt.0) xj=xj+boxxsize
2343           yj=mod(yj,boxysize)
2344           if (yj.lt.0) yj=yj+boxysize
2345           zj=mod(zj,boxzsize)
2346           if (zj.lt.0) zj=zj+boxzsize
2347        if ((zj.gt.bordlipbot)
2348      &.and.(zj.lt.bordliptop)) then
2349 C the energy transfer exist
2350         if (zj.lt.buflipbot) then
2351 C what fraction I am in
2352          fracinbuf=1.0d0-
2353      &        ((zj-bordlipbot)/lipbufthick)
2354 C lipbufthick is thickenes of lipid buffore
2355          sslipj=sscalelip(fracinbuf)
2356          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2357         elseif (zj.gt.bufliptop) then
2358          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2359          sslipj=sscalelip(fracinbuf)
2360          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2361         else
2362          sslipj=1.0d0
2363          ssgradlipj=0.0
2364         endif
2365        else
2366          sslipj=0.0d0
2367          ssgradlipj=0.0
2368        endif
2369       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2370      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2371       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2372      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2373 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2374 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2375 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2376       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2377       xj_safe=xj
2378       yj_safe=yj
2379       zj_safe=zj
2380       subchap=0
2381       do xshift=-1,1
2382       do yshift=-1,1
2383       do zshift=-1,1
2384           xj=xj_safe+xshift*boxxsize
2385           yj=yj_safe+yshift*boxysize
2386           zj=zj_safe+zshift*boxzsize
2387           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2388           if(dist_temp.lt.dist_init) then
2389             dist_init=dist_temp
2390             xj_temp=xj
2391             yj_temp=yj
2392             zj_temp=zj
2393             subchap=1
2394           endif
2395        enddo
2396        enddo
2397        enddo
2398        if (subchap.eq.1) then
2399           xj=xj_temp-xi
2400           yj=yj_temp-yi
2401           zj=zj_temp-zi
2402        else
2403           xj=xj_safe-xi
2404           yj=yj_safe-yi
2405           zj=zj_safe-zi
2406        endif
2407             dxj=dc_norm(1,nres+j)
2408             dyj=dc_norm(2,nres+j)
2409             dzj=dc_norm(3,nres+j)
2410             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2411             rij=dsqrt(rrij)
2412             sss=sscale(1.0d0/rij,r_cut_int)
2413             if (sss.eq.0.0d0) cycle
2414             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2415 C Calculate angle-dependent terms of energy and contributions to their
2416 C derivatives.
2417             call sc_angular
2418             sigsq=1.0D0/sigsq
2419             sig=sig0ij*dsqrt(sigsq)
2420             rij_shift=1.0D0/rij-sig+r0ij
2421 C I hate to put IF's in the loops, but here don't have another choice!!!!
2422             if (rij_shift.le.0.0D0) then
2423               evdw=1.0D20
2424               return
2425             endif
2426             sigder=-sig*sigsq
2427 c---------------------------------------------------------------
2428             rij_shift=1.0D0/rij_shift
2429             fac=rij_shift**expon
2430             e1=fac*fac*aa
2431             e2=fac*bb
2432             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2433             eps2der=evdwij*eps3rt
2434             eps3der=evdwij*eps2rt
2435             fac_augm=rrij**expon
2436             e_augm=augm(itypi,itypj)*fac_augm
2437             evdwij=evdwij*eps2rt*eps3rt
2438             evdw=evdw+evdwij+e_augm
2439             if (lprn) then
2440             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2441             epsi=bb**2/aa
2442             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2443      &        restyp(itypi),i,restyp(itypj),j,
2444      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2445      &        chi1,chi2,chip1,chip2,
2446      &        eps1,eps2rt**2,eps3rt**2,
2447      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2448      &        evdwij+e_augm
2449             endif
2450 C Calculate gradient components.
2451             e1=e1*eps1*eps2rt**2*eps3rt**2
2452             fac=-expon*(e1+evdwij)*rij_shift
2453             sigder=fac*sigder
2454             fac=rij*fac-2*expon*rrij*e_augm
2455             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2456 C Calculate the radial part of the gradient
2457             gg(1)=xj*fac
2458             gg(2)=yj*fac
2459             gg(3)=zj*fac
2460 C Calculate angular part of the gradient.
2461 c            call sc_grad_scale(sss)
2462             call sc_grad
2463           enddo      ! j
2464         enddo        ! iint
2465       enddo          ! i
2466       end
2467 C-----------------------------------------------------------------------------
2468       subroutine sc_angular
2469 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2470 C om12. Called by ebp, egb, and egbv.
2471       implicit none
2472       include 'COMMON.CALC'
2473       include 'COMMON.IOUNITS'
2474       erij(1)=xj*rij
2475       erij(2)=yj*rij
2476       erij(3)=zj*rij
2477       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2478       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2479       om12=dxi*dxj+dyi*dyj+dzi*dzj
2480       chiom12=chi12*om12
2481 C Calculate eps1(om12) and its derivative in om12
2482       faceps1=1.0D0-om12*chiom12
2483       faceps1_inv=1.0D0/faceps1
2484       eps1=dsqrt(faceps1_inv)
2485 C Following variable is eps1*deps1/dom12
2486       eps1_om12=faceps1_inv*chiom12
2487 c diagnostics only
2488 c      faceps1_inv=om12
2489 c      eps1=om12
2490 c      eps1_om12=1.0d0
2491 c      write (iout,*) "om12",om12," eps1",eps1
2492 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2493 C and om12.
2494       om1om2=om1*om2
2495       chiom1=chi1*om1
2496       chiom2=chi2*om2
2497       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2498       sigsq=1.0D0-facsig*faceps1_inv
2499       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2500       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2501       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2502 c diagnostics only
2503 c      sigsq=1.0d0
2504 c      sigsq_om1=0.0d0
2505 c      sigsq_om2=0.0d0
2506 c      sigsq_om12=0.0d0
2507 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2508 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2509 c     &    " eps1",eps1
2510 C Calculate eps2 and its derivatives in om1, om2, and om12.
2511       chipom1=chip1*om1
2512       chipom2=chip2*om2
2513       chipom12=chip12*om12
2514       facp=1.0D0-om12*chipom12
2515       facp_inv=1.0D0/facp
2516       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2517 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2518 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2519 C Following variable is the square root of eps2
2520       eps2rt=1.0D0-facp1*facp_inv
2521 C Following three variables are the derivatives of the square root of eps
2522 C in om1, om2, and om12.
2523       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2524       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2525       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2526 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2527       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2528 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2529 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2530 c     &  " eps2rt_om12",eps2rt_om12
2531 C Calculate whole angle-dependent part of epsilon and contributions
2532 C to its derivatives
2533       return
2534       end
2535 C----------------------------------------------------------------------------
2536       subroutine sc_grad
2537       implicit real*8 (a-h,o-z)
2538       include 'DIMENSIONS'
2539       include 'COMMON.CHAIN'
2540       include 'COMMON.DERIV'
2541       include 'COMMON.CALC'
2542       include 'COMMON.IOUNITS'
2543       double precision dcosom1(3),dcosom2(3)
2544 cc      print *,'sss=',sss
2545       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2546       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2547       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2548      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2549 c diagnostics only
2550 c      eom1=0.0d0
2551 c      eom2=0.0d0
2552 c      eom12=evdwij*eps1_om12
2553 c end diagnostics
2554 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2555 c     &  " sigder",sigder
2556 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2557 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2558       do k=1,3
2559         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2560         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2561       enddo
2562       do k=1,3
2563         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2564       enddo
2565 c      write (iout,*) "gg",(gg(k),k=1,3)
2566       do k=1,3
2567         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2568      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2569      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2570         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2571      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2572      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2573 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2574 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2575 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2576 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2577       enddo
2578 C
2579 C Calculate the components of the gradient in DC and X
2580 C
2581 cgrad      do k=i,j-1
2582 cgrad        do l=1,3
2583 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2584 cgrad        enddo
2585 cgrad      enddo
2586       do l=1,3
2587         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2588         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2589       enddo
2590       return
2591       end
2592 C-----------------------------------------------------------------------
2593       subroutine e_softsphere(evdw)
2594 C
2595 C This subroutine calculates the interaction energy of nonbonded side chains
2596 C assuming the LJ potential of interaction.
2597 C
2598       implicit real*8 (a-h,o-z)
2599       include 'DIMENSIONS'
2600       parameter (accur=1.0d-10)
2601       include 'COMMON.GEO'
2602       include 'COMMON.VAR'
2603       include 'COMMON.LOCAL'
2604       include 'COMMON.CHAIN'
2605       include 'COMMON.DERIV'
2606       include 'COMMON.INTERACT'
2607       include 'COMMON.TORSION'
2608       include 'COMMON.SBRIDGE'
2609       include 'COMMON.NAMES'
2610       include 'COMMON.IOUNITS'
2611 c      include 'COMMON.CONTACTS'
2612       dimension gg(3)
2613 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2614       evdw=0.0D0
2615       do i=iatsc_s,iatsc_e
2616         itypi=iabs(itype(i))
2617         if (itypi.eq.ntyp1) cycle
2618         itypi1=iabs(itype(i+1))
2619         xi=c(1,nres+i)
2620         yi=c(2,nres+i)
2621         zi=c(3,nres+i)
2622 C
2623 C Calculate SC interaction energy.
2624 C
2625         do iint=1,nint_gr(i)
2626 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2627 cd   &                  'iend=',iend(i,iint)
2628           do j=istart(i,iint),iend(i,iint)
2629             itypj=iabs(itype(j))
2630             if (itypj.eq.ntyp1) cycle
2631             xj=c(1,nres+j)-xi
2632             yj=c(2,nres+j)-yi
2633             zj=c(3,nres+j)-zi
2634             rij=xj*xj+yj*yj+zj*zj
2635 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2636             r0ij=r0(itypi,itypj)
2637             r0ijsq=r0ij*r0ij
2638 c            print *,i,j,r0ij,dsqrt(rij)
2639             if (rij.lt.r0ijsq) then
2640               evdwij=0.25d0*(rij-r0ijsq)**2
2641               fac=rij-r0ijsq
2642             else
2643               evdwij=0.0d0
2644               fac=0.0d0
2645             endif
2646             evdw=evdw+evdwij
2647 C
2648 C Calculate the components of the gradient in DC and X
2649 C
2650             gg(1)=xj*fac
2651             gg(2)=yj*fac
2652             gg(3)=zj*fac
2653             do k=1,3
2654               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2655               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2656               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2657               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2658             enddo
2659 cgrad            do k=i,j-1
2660 cgrad              do l=1,3
2661 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2662 cgrad              enddo
2663 cgrad            enddo
2664           enddo ! j
2665         enddo ! iint
2666       enddo ! i
2667       return
2668       end
2669 C--------------------------------------------------------------------------
2670       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2671      &              eello_turn4)
2672 C
2673 C Soft-sphere potential of p-p interaction
2674 C
2675       implicit real*8 (a-h,o-z)
2676       include 'DIMENSIONS'
2677       include 'COMMON.CONTROL'
2678       include 'COMMON.IOUNITS'
2679       include 'COMMON.GEO'
2680       include 'COMMON.VAR'
2681       include 'COMMON.LOCAL'
2682       include 'COMMON.CHAIN'
2683       include 'COMMON.DERIV'
2684       include 'COMMON.INTERACT'
2685 c      include 'COMMON.CONTACTS'
2686       include 'COMMON.TORSION'
2687       include 'COMMON.VECTORS'
2688       include 'COMMON.FFIELD'
2689       dimension ggg(3)
2690       integer xshift,yshift,zshift
2691 C      write(iout,*) 'In EELEC_soft_sphere'
2692       ees=0.0D0
2693       evdw1=0.0D0
2694       eel_loc=0.0d0
2695       eello_turn3=0.0d0
2696       eello_turn4=0.0d0
2697       ind=0
2698       do i=iatel_s,iatel_e
2699         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2700         dxi=dc(1,i)
2701         dyi=dc(2,i)
2702         dzi=dc(3,i)
2703         xmedi=c(1,i)+0.5d0*dxi
2704         ymedi=c(2,i)+0.5d0*dyi
2705         zmedi=c(3,i)+0.5d0*dzi
2706           xmedi=mod(xmedi,boxxsize)
2707           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2708           ymedi=mod(ymedi,boxysize)
2709           if (ymedi.lt.0) ymedi=ymedi+boxysize
2710           zmedi=mod(zmedi,boxzsize)
2711           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2712         num_conti=0
2713 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2714         do j=ielstart(i),ielend(i)
2715           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2716           ind=ind+1
2717           iteli=itel(i)
2718           itelj=itel(j)
2719           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2720           r0ij=rpp(iteli,itelj)
2721           r0ijsq=r0ij*r0ij
2722           dxj=dc(1,j)
2723           dyj=dc(2,j)
2724           dzj=dc(3,j)
2725           xj=c(1,j)+0.5D0*dxj
2726           yj=c(2,j)+0.5D0*dyj
2727           zj=c(3,j)+0.5D0*dzj
2728           xj=mod(xj,boxxsize)
2729           if (xj.lt.0) xj=xj+boxxsize
2730           yj=mod(yj,boxysize)
2731           if (yj.lt.0) yj=yj+boxysize
2732           zj=mod(zj,boxzsize)
2733           if (zj.lt.0) zj=zj+boxzsize
2734       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2735       xj_safe=xj
2736       yj_safe=yj
2737       zj_safe=zj
2738       isubchap=0
2739       do xshift=-1,1
2740       do yshift=-1,1
2741       do zshift=-1,1
2742           xj=xj_safe+xshift*boxxsize
2743           yj=yj_safe+yshift*boxysize
2744           zj=zj_safe+zshift*boxzsize
2745           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2746           if(dist_temp.lt.dist_init) then
2747             dist_init=dist_temp
2748             xj_temp=xj
2749             yj_temp=yj
2750             zj_temp=zj
2751             isubchap=1
2752           endif
2753        enddo
2754        enddo
2755        enddo
2756        if (isubchap.eq.1) then
2757           xj=xj_temp-xmedi
2758           yj=yj_temp-ymedi
2759           zj=zj_temp-zmedi
2760        else
2761           xj=xj_safe-xmedi
2762           yj=yj_safe-ymedi
2763           zj=zj_safe-zmedi
2764        endif
2765           rij=xj*xj+yj*yj+zj*zj
2766             sss=sscale(sqrt(rij),r_cut_int)
2767             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2768           if (rij.lt.r0ijsq) then
2769             evdw1ij=0.25d0*(rij-r0ijsq)**2
2770             fac=rij-r0ijsq
2771           else
2772             evdw1ij=0.0d0
2773             fac=0.0d0
2774           endif
2775           evdw1=evdw1+evdw1ij*sss
2776 C
2777 C Calculate contributions to the Cartesian gradient.
2778 C
2779           ggg(1)=fac*xj*sssgrad
2780           ggg(2)=fac*yj*sssgrad
2781           ggg(3)=fac*zj*sssgrad
2782           do k=1,3
2783             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2784             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2785           enddo
2786 *
2787 * Loop over residues i+1 thru j-1.
2788 *
2789 cgrad          do k=i+1,j-1
2790 cgrad            do l=1,3
2791 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2792 cgrad            enddo
2793 cgrad          enddo
2794         enddo ! j
2795       enddo   ! i
2796 cgrad      do i=nnt,nct-1
2797 cgrad        do k=1,3
2798 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2799 cgrad        enddo
2800 cgrad        do j=i+1,nct-1
2801 cgrad          do k=1,3
2802 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2803 cgrad          enddo
2804 cgrad        enddo
2805 cgrad      enddo
2806       return
2807       end
2808 c------------------------------------------------------------------------------
2809       subroutine vec_and_deriv
2810       implicit real*8 (a-h,o-z)
2811       include 'DIMENSIONS'
2812 #ifdef MPI
2813       include 'mpif.h'
2814 #endif
2815       include 'COMMON.IOUNITS'
2816       include 'COMMON.GEO'
2817       include 'COMMON.VAR'
2818       include 'COMMON.LOCAL'
2819       include 'COMMON.CHAIN'
2820       include 'COMMON.VECTORS'
2821       include 'COMMON.SETUP'
2822       include 'COMMON.TIME1'
2823       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2824 C Compute the local reference systems. For reference system (i), the
2825 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2826 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2827 #ifdef PARVEC
2828       do i=ivec_start,ivec_end
2829 #else
2830       do i=1,nres-1
2831 #endif
2832           if (i.eq.nres-1) then
2833 C Case of the last full residue
2834 C Compute the Z-axis
2835             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2836             costh=dcos(pi-theta(nres))
2837             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2838             do k=1,3
2839               uz(k,i)=fac*uz(k,i)
2840             enddo
2841 C Compute the derivatives of uz
2842             uzder(1,1,1)= 0.0d0
2843             uzder(2,1,1)=-dc_norm(3,i-1)
2844             uzder(3,1,1)= dc_norm(2,i-1)
2845             uzder(1,2,1)= dc_norm(3,i-1)
2846             uzder(2,2,1)= 0.0d0
2847             uzder(3,2,1)=-dc_norm(1,i-1)
2848             uzder(1,3,1)=-dc_norm(2,i-1)
2849             uzder(2,3,1)= dc_norm(1,i-1)
2850             uzder(3,3,1)= 0.0d0
2851             uzder(1,1,2)= 0.0d0
2852             uzder(2,1,2)= dc_norm(3,i)
2853             uzder(3,1,2)=-dc_norm(2,i)
2854             uzder(1,2,2)=-dc_norm(3,i)
2855             uzder(2,2,2)= 0.0d0
2856             uzder(3,2,2)= dc_norm(1,i)
2857             uzder(1,3,2)= dc_norm(2,i)
2858             uzder(2,3,2)=-dc_norm(1,i)
2859             uzder(3,3,2)= 0.0d0
2860 C Compute the Y-axis
2861             facy=fac
2862             do k=1,3
2863               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2864             enddo
2865 C Compute the derivatives of uy
2866             do j=1,3
2867               do k=1,3
2868                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2869      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2870                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2871               enddo
2872               uyder(j,j,1)=uyder(j,j,1)-costh
2873               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2874             enddo
2875             do j=1,2
2876               do k=1,3
2877                 do l=1,3
2878                   uygrad(l,k,j,i)=uyder(l,k,j)
2879                   uzgrad(l,k,j,i)=uzder(l,k,j)
2880                 enddo
2881               enddo
2882             enddo
2883             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2884             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2885             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2886             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2887           else
2888 C Other residues
2889 C Compute the Z-axis
2890             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2891             costh=dcos(pi-theta(i+2))
2892             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2893             do k=1,3
2894               uz(k,i)=fac*uz(k,i)
2895             enddo
2896 C Compute the derivatives of uz
2897             uzder(1,1,1)= 0.0d0
2898             uzder(2,1,1)=-dc_norm(3,i+1)
2899             uzder(3,1,1)= dc_norm(2,i+1)
2900             uzder(1,2,1)= dc_norm(3,i+1)
2901             uzder(2,2,1)= 0.0d0
2902             uzder(3,2,1)=-dc_norm(1,i+1)
2903             uzder(1,3,1)=-dc_norm(2,i+1)
2904             uzder(2,3,1)= dc_norm(1,i+1)
2905             uzder(3,3,1)= 0.0d0
2906             uzder(1,1,2)= 0.0d0
2907             uzder(2,1,2)= dc_norm(3,i)
2908             uzder(3,1,2)=-dc_norm(2,i)
2909             uzder(1,2,2)=-dc_norm(3,i)
2910             uzder(2,2,2)= 0.0d0
2911             uzder(3,2,2)= dc_norm(1,i)
2912             uzder(1,3,2)= dc_norm(2,i)
2913             uzder(2,3,2)=-dc_norm(1,i)
2914             uzder(3,3,2)= 0.0d0
2915 C Compute the Y-axis
2916             facy=fac
2917             do k=1,3
2918               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2919             enddo
2920 C Compute the derivatives of uy
2921             do j=1,3
2922               do k=1,3
2923                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2924      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2925                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2926               enddo
2927               uyder(j,j,1)=uyder(j,j,1)-costh
2928               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2929             enddo
2930             do j=1,2
2931               do k=1,3
2932                 do l=1,3
2933                   uygrad(l,k,j,i)=uyder(l,k,j)
2934                   uzgrad(l,k,j,i)=uzder(l,k,j)
2935                 enddo
2936               enddo
2937             enddo
2938             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2939             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2940             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2941             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2942           endif
2943       enddo
2944       do i=1,nres-1
2945         vbld_inv_temp(1)=vbld_inv(i+1)
2946         if (i.lt.nres-1) then
2947           vbld_inv_temp(2)=vbld_inv(i+2)
2948           else
2949           vbld_inv_temp(2)=vbld_inv(i)
2950           endif
2951         do j=1,2
2952           do k=1,3
2953             do l=1,3
2954               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2955               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2956             enddo
2957           enddo
2958         enddo
2959       enddo
2960 #if defined(PARVEC) && defined(MPI)
2961       if (nfgtasks1.gt.1) then
2962         time00=MPI_Wtime()
2963 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2964 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2965 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2966         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2967      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2968      &   FG_COMM1,IERR)
2969         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2970      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2971      &   FG_COMM1,IERR)
2972         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2973      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2974      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2975         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2976      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2977      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2978         time_gather=time_gather+MPI_Wtime()-time00
2979       endif
2980 #endif
2981 #ifdef DEBUG
2982       if (fg_rank.eq.0) then
2983         write (iout,*) "Arrays UY and UZ"
2984         do i=1,nres-1
2985           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2986      &     (uz(k,i),k=1,3)
2987         enddo
2988       endif
2989 #endif
2990       return
2991       end
2992 C--------------------------------------------------------------------------
2993       subroutine set_matrices
2994       implicit real*8 (a-h,o-z)
2995       include 'DIMENSIONS'
2996 #ifdef MPI
2997       include "mpif.h"
2998       include "COMMON.SETUP"
2999       integer IERR
3000       integer status(MPI_STATUS_SIZE)
3001 #endif
3002       include 'COMMON.IOUNITS'
3003       include 'COMMON.GEO'
3004       include 'COMMON.VAR'
3005       include 'COMMON.LOCAL'
3006       include 'COMMON.CHAIN'
3007       include 'COMMON.DERIV'
3008       include 'COMMON.INTERACT'
3009       include 'COMMON.CORRMAT'
3010       include 'COMMON.TORSION'
3011       include 'COMMON.VECTORS'
3012       include 'COMMON.FFIELD'
3013       double precision auxvec(2),auxmat(2,2)
3014 C
3015 C Compute the virtual-bond-torsional-angle dependent quantities needed
3016 C to calculate the el-loc multibody terms of various order.
3017 C
3018 c      write(iout,*) 'nphi=',nphi,nres
3019 c      write(iout,*) "itype2loc",itype2loc
3020 #ifdef PARMAT
3021       do i=ivec_start+2,ivec_end+2
3022 #else
3023       do i=3,nres+1
3024 #endif
3025         ii=ireschain(i-2)
3026 c        write (iout,*) "i",i,i-2," ii",ii
3027         if (ii.eq.0) cycle
3028         innt=chain_border(1,ii)
3029         inct=chain_border(2,ii)
3030 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3031 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3032         if (i.gt. innt+2 .and. i.lt.inct+2) then
3033           iti = itype2loc(itype(i-2))
3034         else
3035           iti=nloctyp
3036         endif
3037 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3038         if (i.gt. innt+1 .and. i.lt.inct+1) then
3039           iti1 = itype2loc(itype(i-1))
3040         else
3041           iti1=nloctyp
3042         endif
3043 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3044 c     &  " iti1",itype(i-1),iti1
3045 #ifdef NEWCORR
3046         cost1=dcos(theta(i-1))
3047         sint1=dsin(theta(i-1))
3048         sint1sq=sint1*sint1
3049         sint1cub=sint1sq*sint1
3050         sint1cost1=2*sint1*cost1
3051 c        write (iout,*) "bnew1",i,iti
3052 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
3053 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3054 c        write (iout,*) "bnew2",i,iti
3055 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3056 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3057         do k=1,2
3058           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3059           b1(k,i-2)=sint1*b1k
3060           gtb1(k,i-2)=cost1*b1k-sint1sq*
3061      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3062           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3063           b2(k,i-2)=sint1*b2k
3064           gtb2(k,i-2)=cost1*b2k-sint1sq*
3065      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3066         enddo
3067         do k=1,2
3068           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3069           cc(1,k,i-2)=sint1sq*aux
3070           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3071      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3072           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3073           dd(1,k,i-2)=sint1sq*aux
3074           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3075      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3076         enddo
3077         cc(2,1,i-2)=cc(1,2,i-2)
3078         cc(2,2,i-2)=-cc(1,1,i-2)
3079         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3080         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3081         dd(2,1,i-2)=dd(1,2,i-2)
3082         dd(2,2,i-2)=-dd(1,1,i-2)
3083         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3084         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3085         do k=1,2
3086           do l=1,2
3087             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3088             EE(l,k,i-2)=sint1sq*aux
3089             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3090           enddo
3091         enddo
3092         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3093         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3094         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3095         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3096         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3097         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3098         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3099 c        b1tilde(1,i-2)=b1(1,i-2)
3100 c        b1tilde(2,i-2)=-b1(2,i-2)
3101 c        b2tilde(1,i-2)=b2(1,i-2)
3102 c        b2tilde(2,i-2)=-b2(2,i-2)
3103 #ifdef DEBUG
3104         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3105         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3106         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3107         write (iout,*) 'theta=', theta(i-1)
3108 #endif
3109 #else
3110         if (i.gt. innt+2 .and. i.lt.inct+2) then
3111 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3112           iti = itype2loc(itype(i-2))
3113         else
3114           iti=nloctyp
3115         endif
3116 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3117 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3118         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3119           iti1 = itype2loc(itype(i-1))
3120         else
3121           iti1=nloctyp
3122         endif
3123         b1(1,i-2)=b(3,iti)
3124         b1(2,i-2)=b(5,iti)
3125         b2(1,i-2)=b(2,iti)
3126         b2(2,i-2)=b(4,iti)
3127         do k=1,2
3128           do l=1,2
3129            CC(k,l,i-2)=ccold(k,l,iti)
3130            DD(k,l,i-2)=ddold(k,l,iti)
3131            EE(k,l,i-2)=eeold(k,l,iti)
3132            gtEE(k,l,i-2)=0.0d0
3133           enddo
3134         enddo
3135 #endif
3136         b1tilde(1,i-2)= b1(1,i-2)
3137         b1tilde(2,i-2)=-b1(2,i-2)
3138         b2tilde(1,i-2)= b2(1,i-2)
3139         b2tilde(2,i-2)=-b2(2,i-2)
3140 c
3141         Ctilde(1,1,i-2)= CC(1,1,i-2)
3142         Ctilde(1,2,i-2)= CC(1,2,i-2)
3143         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3144         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3145 c
3146         Dtilde(1,1,i-2)= DD(1,1,i-2)
3147         Dtilde(1,2,i-2)= DD(1,2,i-2)
3148         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3149         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3150 #ifdef DEBUG
3151         write(iout,*) "i",i," iti",iti
3152         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3153         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3154 #endif
3155       enddo
3156       mu=0.0d0
3157 #ifdef PARMAT
3158       do i=ivec_start+2,ivec_end+2
3159 #else
3160       do i=3,nres+1
3161 #endif
3162 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3163         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3164           sin1=dsin(phi(i))
3165           cos1=dcos(phi(i))
3166           sintab(i-2)=sin1
3167           costab(i-2)=cos1
3168           obrot(1,i-2)=cos1
3169           obrot(2,i-2)=sin1
3170           sin2=dsin(2*phi(i))
3171           cos2=dcos(2*phi(i))
3172           sintab2(i-2)=sin2
3173           costab2(i-2)=cos2
3174           obrot2(1,i-2)=cos2
3175           obrot2(2,i-2)=sin2
3176           Ug(1,1,i-2)=-cos1
3177           Ug(1,2,i-2)=-sin1
3178           Ug(2,1,i-2)=-sin1
3179           Ug(2,2,i-2)= cos1
3180           Ug2(1,1,i-2)=-cos2
3181           Ug2(1,2,i-2)=-sin2
3182           Ug2(2,1,i-2)=-sin2
3183           Ug2(2,2,i-2)= cos2
3184         else
3185           costab(i-2)=1.0d0
3186           sintab(i-2)=0.0d0
3187           obrot(1,i-2)=1.0d0
3188           obrot(2,i-2)=0.0d0
3189           obrot2(1,i-2)=0.0d0
3190           obrot2(2,i-2)=0.0d0
3191           Ug(1,1,i-2)=1.0d0
3192           Ug(1,2,i-2)=0.0d0
3193           Ug(2,1,i-2)=0.0d0
3194           Ug(2,2,i-2)=1.0d0
3195           Ug2(1,1,i-2)=0.0d0
3196           Ug2(1,2,i-2)=0.0d0
3197           Ug2(2,1,i-2)=0.0d0
3198           Ug2(2,2,i-2)=0.0d0
3199         endif
3200         if (i .gt. 3) then
3201           obrot_der(1,i-2)=-sin1
3202           obrot_der(2,i-2)= cos1
3203           Ugder(1,1,i-2)= sin1
3204           Ugder(1,2,i-2)=-cos1
3205           Ugder(2,1,i-2)=-cos1
3206           Ugder(2,2,i-2)=-sin1
3207           dwacos2=cos2+cos2
3208           dwasin2=sin2+sin2
3209           obrot2_der(1,i-2)=-dwasin2
3210           obrot2_der(2,i-2)= dwacos2
3211           Ug2der(1,1,i-2)= dwasin2
3212           Ug2der(1,2,i-2)=-dwacos2
3213           Ug2der(2,1,i-2)=-dwacos2
3214           Ug2der(2,2,i-2)=-dwasin2
3215         else
3216           obrot_der(1,i-2)=0.0d0
3217           obrot_der(2,i-2)=0.0d0
3218           Ugder(1,1,i-2)=0.0d0
3219           Ugder(1,2,i-2)=0.0d0
3220           Ugder(2,1,i-2)=0.0d0
3221           Ugder(2,2,i-2)=0.0d0
3222           obrot2_der(1,i-2)=0.0d0
3223           obrot2_der(2,i-2)=0.0d0
3224           Ug2der(1,1,i-2)=0.0d0
3225           Ug2der(1,2,i-2)=0.0d0
3226           Ug2der(2,1,i-2)=0.0d0
3227           Ug2der(2,2,i-2)=0.0d0
3228         endif
3229 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3230 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3231         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3232           iti = itype2loc(itype(i-2))
3233         else
3234           iti=nloctyp
3235         endif
3236 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3237         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3238           iti1 = itype2loc(itype(i-1))
3239         else
3240           iti1=nloctyp
3241         endif
3242 cd        write (iout,*) '*******i',i,' iti1',iti
3243 cd        write (iout,*) 'b1',b1(:,iti)
3244 cd        write (iout,*) 'b2',b2(:,iti)
3245 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3246 c        if (i .gt. iatel_s+2) then
3247         if (i .gt. nnt+2) then
3248           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3249 #ifdef NEWCORR
3250           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3251 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3252 #endif
3253 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3254 c     &    EE(1,2,iti),EE(2,2,i)
3255           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3256           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3257 c          write(iout,*) "Macierz EUG",
3258 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3259 c     &    eug(2,2,i-2)
3260 #ifdef FOURBODY
3261           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3262      &    then
3263           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3264           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3265           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3266           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3267           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3268           endif
3269 #endif
3270         else
3271           do k=1,2
3272             Ub2(k,i-2)=0.0d0
3273             Ctobr(k,i-2)=0.0d0
3274             Dtobr2(k,i-2)=0.0d0
3275             do l=1,2
3276               EUg(l,k,i-2)=0.0d0
3277               CUg(l,k,i-2)=0.0d0
3278               DUg(l,k,i-2)=0.0d0
3279               DtUg2(l,k,i-2)=0.0d0
3280             enddo
3281           enddo
3282         endif
3283         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3284         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3285         do k=1,2
3286           muder(k,i-2)=Ub2der(k,i-2)
3287         enddo
3288 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3289         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3290           if (itype(i-1).le.ntyp) then
3291             iti1 = itype2loc(itype(i-1))
3292           else
3293             iti1=nloctyp
3294           endif
3295         else
3296           iti1=nloctyp
3297         endif
3298         do k=1,2
3299           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3300 c          mu(k,i-2)=b1(k,i-1)
3301 c          mu(k,i-2)=Ub2(k,i-2)
3302         enddo
3303 #ifdef MUOUT
3304         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3305      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3306      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3307      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3308      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3309      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3310 #endif
3311 cd        write (iout,*) 'mu1',mu1(:,i-2)
3312 cd        write (iout,*) 'mu2',mu2(:,i-2)
3313 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3314 #ifdef FOURBODY
3315         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3316      &  then
3317         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3318         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3319         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3320         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3321         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3322 C Vectors and matrices dependent on a single virtual-bond dihedral.
3323         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3324         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3325         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3326         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3327         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3328         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3329         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3330         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3331         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3332         endif
3333 #endif
3334       enddo
3335 #ifdef FOURBODY
3336 C Matrices dependent on two consecutive virtual-bond dihedrals.
3337 C The order of matrices is from left to right.
3338       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3339      &then
3340 c      do i=max0(ivec_start,2),ivec_end
3341       do i=2,nres-1
3342         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3343         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3344         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3345         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3346         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3347         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3348         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3349         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3350       enddo
3351       endif
3352 #endif
3353 #if defined(MPI) && defined(PARMAT)
3354 #ifdef DEBUG
3355 c      if (fg_rank.eq.0) then
3356         write (iout,*) "Arrays UG and UGDER before GATHER"
3357         do i=1,nres-1
3358           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3359      &     ((ug(l,k,i),l=1,2),k=1,2),
3360      &     ((ugder(l,k,i),l=1,2),k=1,2)
3361         enddo
3362         write (iout,*) "Arrays UG2 and UG2DER"
3363         do i=1,nres-1
3364           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3365      &     ((ug2(l,k,i),l=1,2),k=1,2),
3366      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3367         enddo
3368         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3369         do i=1,nres-1
3370           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3371      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3372      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3373         enddo
3374         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3375         do i=1,nres-1
3376           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3377      &     costab(i),sintab(i),costab2(i),sintab2(i)
3378         enddo
3379         write (iout,*) "Array MUDER"
3380         do i=1,nres-1
3381           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3382         enddo
3383 c      endif
3384 #endif
3385       if (nfgtasks.gt.1) then
3386         time00=MPI_Wtime()
3387 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3388 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3389 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3390 #ifdef MATGATHER
3391         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3392      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3393      &   FG_COMM1,IERR)
3394         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3395      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3396      &   FG_COMM1,IERR)
3397         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3398      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3399      &   FG_COMM1,IERR)
3400         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3401      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3402      &   FG_COMM1,IERR)
3403         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3404      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3405      &   FG_COMM1,IERR)
3406         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3407      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3408      &   FG_COMM1,IERR)
3409         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3410      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3411      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3412         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3413      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3414      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3415         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3416      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3417      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3418         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3419      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3420      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3421 #ifdef FOURBODY
3422         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3423      &  then
3424         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3425      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3426      &   FG_COMM1,IERR)
3427         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3428      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3429      &   FG_COMM1,IERR)
3430         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3431      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3432      &   FG_COMM1,IERR)
3433        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3434      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3435      &   FG_COMM1,IERR)
3436         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3437      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3438      &   FG_COMM1,IERR)
3439         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3440      &   ivec_count(fg_rank1),
3441      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3442      &   FG_COMM1,IERR)
3443         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3444      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3445      &   FG_COMM1,IERR)
3446         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3447      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3448      &   FG_COMM1,IERR)
3449         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3450      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3451      &   FG_COMM1,IERR)
3452         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3453      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3454      &   FG_COMM1,IERR)
3455         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3456      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3457      &   FG_COMM1,IERR)
3458         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3459      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3460      &   FG_COMM1,IERR)
3461         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3462      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3463      &   FG_COMM1,IERR)
3464         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3465      &   ivec_count(fg_rank1),
3466      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3467      &   FG_COMM1,IERR)
3468         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3469      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3470      &   FG_COMM1,IERR)
3471        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3472      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3473      &   FG_COMM1,IERR)
3474         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3475      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3476      &   FG_COMM1,IERR)
3477        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3478      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3479      &   FG_COMM1,IERR)
3480         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3481      &   ivec_count(fg_rank1),
3482      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3483      &   FG_COMM1,IERR)
3484         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3485      &   ivec_count(fg_rank1),
3486      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3487      &   FG_COMM1,IERR)
3488         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3489      &   ivec_count(fg_rank1),
3490      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3491      &   MPI_MAT2,FG_COMM1,IERR)
3492         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3493      &   ivec_count(fg_rank1),
3494      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3495      &   MPI_MAT2,FG_COMM1,IERR)
3496         endif
3497 #endif
3498 #else
3499 c Passes matrix info through the ring
3500       isend=fg_rank1
3501       irecv=fg_rank1-1
3502       if (irecv.lt.0) irecv=nfgtasks1-1
3503       iprev=irecv
3504       inext=fg_rank1+1
3505       if (inext.ge.nfgtasks1) inext=0
3506       do i=1,nfgtasks1-1
3507 c        write (iout,*) "isend",isend," irecv",irecv
3508 c        call flush(iout)
3509         lensend=lentyp(isend)
3510         lenrecv=lentyp(irecv)
3511 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3512 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3513 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3514 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3515 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3516 c        write (iout,*) "Gather ROTAT1"
3517 c        call flush(iout)
3518 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3519 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3520 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3521 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3522 c        write (iout,*) "Gather ROTAT2"
3523 c        call flush(iout)
3524         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3525      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3526      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3527      &   iprev,4400+irecv,FG_COMM,status,IERR)
3528 c        write (iout,*) "Gather ROTAT_OLD"
3529 c        call flush(iout)
3530         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3531      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3532      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3533      &   iprev,5500+irecv,FG_COMM,status,IERR)
3534 c        write (iout,*) "Gather PRECOMP11"
3535 c        call flush(iout)
3536         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3537      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3538      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3539      &   iprev,6600+irecv,FG_COMM,status,IERR)
3540 c        write (iout,*) "Gather PRECOMP12"
3541 c        call flush(iout)
3542 #ifdef FOURBODY
3543         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3544      &  then
3545         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3546      &   MPI_ROTAT2(lensend),inext,7700+isend,
3547      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3548      &   iprev,7700+irecv,FG_COMM,status,IERR)
3549 c        write (iout,*) "Gather PRECOMP21"
3550 c        call flush(iout)
3551         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3552      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3553      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3554      &   iprev,8800+irecv,FG_COMM,status,IERR)
3555 c        write (iout,*) "Gather PRECOMP22"
3556 c        call flush(iout)
3557         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3558      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3559      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3560      &   MPI_PRECOMP23(lenrecv),
3561      &   iprev,9900+irecv,FG_COMM,status,IERR)
3562 #endif
3563 c        write (iout,*) "Gather PRECOMP23"
3564 c        call flush(iout)
3565         endif
3566         isend=irecv
3567         irecv=irecv-1
3568         if (irecv.lt.0) irecv=nfgtasks1-1
3569       enddo
3570 #endif
3571         time_gather=time_gather+MPI_Wtime()-time00
3572       endif
3573 #ifdef DEBUG
3574 c      if (fg_rank.eq.0) then
3575         write (iout,*) "Arrays UG and UGDER"
3576         do i=1,nres-1
3577           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3578      &     ((ug(l,k,i),l=1,2),k=1,2),
3579      &     ((ugder(l,k,i),l=1,2),k=1,2)
3580         enddo
3581         write (iout,*) "Arrays UG2 and UG2DER"
3582         do i=1,nres-1
3583           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3584      &     ((ug2(l,k,i),l=1,2),k=1,2),
3585      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3586         enddo
3587         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3588         do i=1,nres-1
3589           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3590      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3591      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3592         enddo
3593         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3594         do i=1,nres-1
3595           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3596      &     costab(i),sintab(i),costab2(i),sintab2(i)
3597         enddo
3598         write (iout,*) "Array MUDER"
3599         do i=1,nres-1
3600           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3601         enddo
3602 c      endif
3603 #endif
3604 #endif
3605 cd      do i=1,nres
3606 cd        iti = itype2loc(itype(i))
3607 cd        write (iout,*) i
3608 cd        do j=1,2
3609 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3610 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3611 cd        enddo
3612 cd      enddo
3613       return
3614       end
3615 C-----------------------------------------------------------------------------
3616       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3617 C
3618 C This subroutine calculates the average interaction energy and its gradient
3619 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3620 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3621 C The potential depends both on the distance of peptide-group centers and on
3622 C the orientation of the CA-CA virtual bonds.
3623 C
3624       implicit real*8 (a-h,o-z)
3625 #ifdef MPI
3626       include 'mpif.h'
3627 #endif
3628       include 'DIMENSIONS'
3629       include 'COMMON.CONTROL'
3630       include 'COMMON.SETUP'
3631       include 'COMMON.IOUNITS'
3632       include 'COMMON.GEO'
3633       include 'COMMON.VAR'
3634       include 'COMMON.LOCAL'
3635       include 'COMMON.CHAIN'
3636       include 'COMMON.DERIV'
3637       include 'COMMON.INTERACT'
3638 #ifdef FOURBODY
3639       include 'COMMON.CONTACTS'
3640       include 'COMMON.CONTMAT'
3641 #endif
3642       include 'COMMON.CORRMAT'
3643       include 'COMMON.TORSION'
3644       include 'COMMON.VECTORS'
3645       include 'COMMON.FFIELD'
3646       include 'COMMON.TIME1'
3647       include 'COMMON.SPLITELE'
3648       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3649      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3650       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3651      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3652       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3653      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3654      &    num_conti,j1,j2
3655 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3656 #ifdef MOMENT
3657       double precision scal_el /1.0d0/
3658 #else
3659       double precision scal_el /0.5d0/
3660 #endif
3661 C 12/13/98
3662 C 13-go grudnia roku pamietnego...
3663       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3664      &                   0.0d0,1.0d0,0.0d0,
3665      &                   0.0d0,0.0d0,1.0d0/
3666 cd      write(iout,*) 'In EELEC'
3667 cd      do i=1,nloctyp
3668 cd        write(iout,*) 'Type',i
3669 cd        write(iout,*) 'B1',B1(:,i)
3670 cd        write(iout,*) 'B2',B2(:,i)
3671 cd        write(iout,*) 'CC',CC(:,:,i)
3672 cd        write(iout,*) 'DD',DD(:,:,i)
3673 cd        write(iout,*) 'EE',EE(:,:,i)
3674 cd      enddo
3675 cd      call check_vecgrad
3676 cd      stop
3677       if (icheckgrad.eq.1) then
3678         do i=1,nres-1
3679           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3680           do k=1,3
3681             dc_norm(k,i)=dc(k,i)*fac
3682           enddo
3683 c          write (iout,*) 'i',i,' fac',fac
3684         enddo
3685       endif
3686       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3687      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3688      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3689 c        call vec_and_deriv
3690 #ifdef TIMING
3691         time01=MPI_Wtime()
3692 #endif
3693         call set_matrices
3694 #ifdef TIMING
3695         time_mat=time_mat+MPI_Wtime()-time01
3696 #endif
3697       endif
3698 cd      do i=1,nres-1
3699 cd        write (iout,*) 'i=',i
3700 cd        do k=1,3
3701 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3702 cd        enddo
3703 cd        do k=1,3
3704 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3705 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3706 cd        enddo
3707 cd      enddo
3708       t_eelecij=0.0d0
3709       ees=0.0D0
3710       evdw1=0.0D0
3711       eel_loc=0.0d0
3712       eello_turn3=0.0d0
3713       eello_turn4=0.0d0
3714       ind=0
3715 #ifdef FOURBODY
3716       do i=1,nres
3717         num_cont_hb(i)=0
3718       enddo
3719 #endif
3720 cd      print '(a)','Enter EELEC'
3721 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3722       do i=1,nres
3723         gel_loc_loc(i)=0.0d0
3724         gcorr_loc(i)=0.0d0
3725       enddo
3726 c
3727 c
3728 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3729 C
3730 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3731 C
3732 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3733       do i=iturn3_start,iturn3_end
3734 c        if (i.le.1) cycle
3735 C        write(iout,*) "tu jest i",i
3736         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3737 C changes suggested by Ana to avoid out of bounds
3738 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3739 c     & .or.((i+4).gt.nres)
3740 c     & .or.((i-1).le.0)
3741 C end of changes by Ana
3742      &  .or. itype(i+2).eq.ntyp1
3743      &  .or. itype(i+3).eq.ntyp1) cycle
3744 C Adam: Instructions below will switch off existing interactions
3745 c        if(i.gt.1)then
3746 c          if(itype(i-1).eq.ntyp1)cycle
3747 c        end if
3748 c        if(i.LT.nres-3)then
3749 c          if (itype(i+4).eq.ntyp1) cycle
3750 c        end if
3751         dxi=dc(1,i)
3752         dyi=dc(2,i)
3753         dzi=dc(3,i)
3754         dx_normi=dc_norm(1,i)
3755         dy_normi=dc_norm(2,i)
3756         dz_normi=dc_norm(3,i)
3757         xmedi=c(1,i)+0.5d0*dxi
3758         ymedi=c(2,i)+0.5d0*dyi
3759         zmedi=c(3,i)+0.5d0*dzi
3760           xmedi=mod(xmedi,boxxsize)
3761           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3762           ymedi=mod(ymedi,boxysize)
3763           if (ymedi.lt.0) ymedi=ymedi+boxysize
3764           zmedi=mod(zmedi,boxzsize)
3765           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3766         num_conti=0
3767         call eelecij(i,i+2,ees,evdw1,eel_loc)
3768         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3769 #ifdef FOURBODY
3770         num_cont_hb(i)=num_conti
3771 #endif
3772       enddo
3773       do i=iturn4_start,iturn4_end
3774         if (i.lt.1) cycle
3775         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3776 C changes suggested by Ana to avoid out of bounds
3777 c     & .or.((i+5).gt.nres)
3778 c     & .or.((i-1).le.0)
3779 C end of changes suggested by Ana
3780      &    .or. itype(i+3).eq.ntyp1
3781      &    .or. itype(i+4).eq.ntyp1
3782 c     &    .or. itype(i+5).eq.ntyp1
3783 c     &    .or. itype(i).eq.ntyp1
3784 c     &    .or. itype(i-1).eq.ntyp1
3785      &                             ) cycle
3786         dxi=dc(1,i)
3787         dyi=dc(2,i)
3788         dzi=dc(3,i)
3789         dx_normi=dc_norm(1,i)
3790         dy_normi=dc_norm(2,i)
3791         dz_normi=dc_norm(3,i)
3792         xmedi=c(1,i)+0.5d0*dxi
3793         ymedi=c(2,i)+0.5d0*dyi
3794         zmedi=c(3,i)+0.5d0*dzi
3795 C Return atom into box, boxxsize is size of box in x dimension
3796 c  194   continue
3797 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3798 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3799 C Condition for being inside the proper box
3800 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3801 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3802 c        go to 194
3803 c        endif
3804 c  195   continue
3805 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3806 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3807 C Condition for being inside the proper box
3808 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3809 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3810 c        go to 195
3811 c        endif
3812 c  196   continue
3813 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3814 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3815 C Condition for being inside the proper box
3816 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3817 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3818 c        go to 196
3819 c        endif
3820           xmedi=mod(xmedi,boxxsize)
3821           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3822           ymedi=mod(ymedi,boxysize)
3823           if (ymedi.lt.0) ymedi=ymedi+boxysize
3824           zmedi=mod(zmedi,boxzsize)
3825           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3826
3827 #ifdef FOURBODY
3828         num_conti=num_cont_hb(i)
3829 #endif
3830 c        write(iout,*) "JESTEM W PETLI"
3831         call eelecij(i,i+3,ees,evdw1,eel_loc)
3832         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3833      &   call eturn4(i,eello_turn4)
3834 #ifdef FOURBODY
3835         num_cont_hb(i)=num_conti
3836 #endif
3837       enddo   ! i
3838 C Loop over all neighbouring boxes
3839 C      do xshift=-1,1
3840 C      do yshift=-1,1
3841 C      do zshift=-1,1
3842 c
3843 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3844 c
3845 CTU KURWA
3846       do i=iatel_s,iatel_e
3847 C        do i=75,75
3848 c        if (i.le.1) cycle
3849         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3850 C changes suggested by Ana to avoid out of bounds
3851 c     & .or.((i+2).gt.nres)
3852 c     & .or.((i-1).le.0)
3853 C end of changes by Ana
3854 c     &  .or. itype(i+2).eq.ntyp1
3855 c     &  .or. itype(i-1).eq.ntyp1
3856      &                ) cycle
3857         dxi=dc(1,i)
3858         dyi=dc(2,i)
3859         dzi=dc(3,i)
3860         dx_normi=dc_norm(1,i)
3861         dy_normi=dc_norm(2,i)
3862         dz_normi=dc_norm(3,i)
3863         xmedi=c(1,i)+0.5d0*dxi
3864         ymedi=c(2,i)+0.5d0*dyi
3865         zmedi=c(3,i)+0.5d0*dzi
3866           xmedi=mod(xmedi,boxxsize)
3867           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3868           ymedi=mod(ymedi,boxysize)
3869           if (ymedi.lt.0) ymedi=ymedi+boxysize
3870           zmedi=mod(zmedi,boxzsize)
3871           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3872 C          xmedi=xmedi+xshift*boxxsize
3873 C          ymedi=ymedi+yshift*boxysize
3874 C          zmedi=zmedi+zshift*boxzsize
3875
3876 C Return tom into box, boxxsize is size of box in x dimension
3877 c  164   continue
3878 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3879 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3880 C Condition for being inside the proper box
3881 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3882 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3883 c        go to 164
3884 c        endif
3885 c  165   continue
3886 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3887 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3888 C Condition for being inside the proper box
3889 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3890 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3891 c        go to 165
3892 c        endif
3893 c  166   continue
3894 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3895 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3896 cC Condition for being inside the proper box
3897 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3898 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3899 c        go to 166
3900 c        endif
3901
3902 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3903 #ifdef FOURBODY
3904         num_conti=num_cont_hb(i)
3905 #endif
3906 C I TU KURWA
3907         do j=ielstart(i),ielend(i)
3908 C          do j=16,17
3909 C          write (iout,*) i,j
3910 C         if (j.le.1) cycle
3911           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3912 C changes suggested by Ana to avoid out of bounds
3913 c     & .or.((j+2).gt.nres)
3914 c     & .or.((j-1).le.0)
3915 C end of changes by Ana
3916 c     & .or.itype(j+2).eq.ntyp1
3917 c     & .or.itype(j-1).eq.ntyp1
3918      &) cycle
3919           call eelecij(i,j,ees,evdw1,eel_loc)
3920         enddo ! j
3921 #ifdef FOURBODY
3922         num_cont_hb(i)=num_conti
3923 #endif
3924       enddo   ! i
3925 C     enddo   ! zshift
3926 C      enddo   ! yshift
3927 C      enddo   ! xshift
3928
3929 c      write (iout,*) "Number of loop steps in EELEC:",ind
3930 cd      do i=1,nres
3931 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3932 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3933 cd      enddo
3934 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3935 ccc      eel_loc=eel_loc+eello_turn3
3936 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3937       return
3938       end
3939 C-------------------------------------------------------------------------------
3940       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3941       implicit none
3942       include 'DIMENSIONS'
3943 #ifdef MPI
3944       include "mpif.h"
3945 #endif
3946       include 'COMMON.CONTROL'
3947       include 'COMMON.IOUNITS'
3948       include 'COMMON.GEO'
3949       include 'COMMON.VAR'
3950       include 'COMMON.LOCAL'
3951       include 'COMMON.CHAIN'
3952       include 'COMMON.DERIV'
3953       include 'COMMON.INTERACT'
3954 #ifdef FOURBODY
3955       include 'COMMON.CONTACTS'
3956       include 'COMMON.CONTMAT'
3957 #endif
3958       include 'COMMON.CORRMAT'
3959       include 'COMMON.TORSION'
3960       include 'COMMON.VECTORS'
3961       include 'COMMON.FFIELD'
3962       include 'COMMON.TIME1'
3963       include 'COMMON.SPLITELE'
3964       include 'COMMON.SHIELD'
3965       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3966      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3967       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3968      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3969      &    gmuij2(4),gmuji2(4)
3970       double precision dxi,dyi,dzi
3971       double precision dx_normi,dy_normi,dz_normi,aux
3972       integer j1,j2,lll,num_conti
3973       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3974      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3975      &    num_conti,j1,j2
3976       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3977       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3978       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3979       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3980      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3981      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3982      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3983      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3984      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3985      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3986      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3987       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3988       double precision dist_init,xj_safe,yj_safe,zj_safe,
3989      &  xj_temp,yj_temp,zj_temp,dist_temp,xmedi,ymedi,zmedi
3990       double precision sscale,sscagrad,scalar
3991
3992 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3993 #ifdef MOMENT
3994       double precision scal_el /1.0d0/
3995 #else
3996       double precision scal_el /0.5d0/
3997 #endif
3998 C 12/13/98
3999 C 13-go grudnia roku pamietnego...
4000       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4001      &                   0.0d0,1.0d0,0.0d0,
4002      &                   0.0d0,0.0d0,1.0d0/
4003        integer xshift,yshift,zshift
4004 c          time00=MPI_Wtime()
4005 cd      write (iout,*) "eelecij",i,j
4006 c          ind=ind+1
4007           iteli=itel(i)
4008           itelj=itel(j)
4009           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4010           aaa=app(iteli,itelj)
4011           bbb=bpp(iteli,itelj)
4012           ael6i=ael6(iteli,itelj)
4013           ael3i=ael3(iteli,itelj)
4014           dxj=dc(1,j)
4015           dyj=dc(2,j)
4016           dzj=dc(3,j)
4017           dx_normj=dc_norm(1,j)
4018           dy_normj=dc_norm(2,j)
4019           dz_normj=dc_norm(3,j)
4020 C          xj=c(1,j)+0.5D0*dxj-xmedi
4021 C          yj=c(2,j)+0.5D0*dyj-ymedi
4022 C          zj=c(3,j)+0.5D0*dzj-zmedi
4023           xj=c(1,j)+0.5D0*dxj
4024           yj=c(2,j)+0.5D0*dyj
4025           zj=c(3,j)+0.5D0*dzj
4026           xj=mod(xj,boxxsize)
4027           if (xj.lt.0) xj=xj+boxxsize
4028           yj=mod(yj,boxysize)
4029           if (yj.lt.0) yj=yj+boxysize
4030           zj=mod(zj,boxzsize)
4031           if (zj.lt.0) zj=zj+boxzsize
4032           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4033       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4034       xj_safe=xj
4035       yj_safe=yj
4036       zj_safe=zj
4037       isubchap=0
4038       do xshift=-1,1
4039       do yshift=-1,1
4040       do zshift=-1,1
4041           xj=xj_safe+xshift*boxxsize
4042           yj=yj_safe+yshift*boxysize
4043           zj=zj_safe+zshift*boxzsize
4044           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4045           if(dist_temp.lt.dist_init) then
4046             dist_init=dist_temp
4047             xj_temp=xj
4048             yj_temp=yj
4049             zj_temp=zj
4050             isubchap=1
4051           endif
4052        enddo
4053        enddo
4054        enddo
4055        if (isubchap.eq.1) then
4056           xj=xj_temp-xmedi
4057           yj=yj_temp-ymedi
4058           zj=zj_temp-zmedi
4059        else
4060           xj=xj_safe-xmedi
4061           yj=yj_safe-ymedi
4062           zj=zj_safe-zmedi
4063        endif
4064 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4065 c  174   continue
4066 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4067 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4068 C Condition for being inside the proper box
4069 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4070 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4071 c        go to 174
4072 c        endif
4073 c  175   continue
4074 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4075 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4076 C Condition for being inside the proper box
4077 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4078 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4079 c        go to 175
4080 c        endif
4081 c  176   continue
4082 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4083 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4084 C Condition for being inside the proper box
4085 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4086 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4087 c        go to 176
4088 c        endif
4089 C        endif !endPBC condintion
4090 C        xj=xj-xmedi
4091 C        yj=yj-ymedi
4092 C        zj=zj-zmedi
4093           rij=xj*xj+yj*yj+zj*zj
4094
4095           sss=sscale(dsqrt(rij),r_cut_int)
4096           if (sss.eq.0.0d0) return
4097           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
4098 c            if (sss.gt.0.0d0) then
4099           rrmij=1.0D0/rij
4100           rij=dsqrt(rij)
4101           rmij=1.0D0/rij
4102           r3ij=rrmij*rmij
4103           r6ij=r3ij*r3ij
4104           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4105           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4106           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4107           fac=cosa-3.0D0*cosb*cosg
4108           ev1=aaa*r6ij*r6ij
4109 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4110           if (j.eq.i+2) ev1=scal_el*ev1
4111           ev2=bbb*r6ij
4112           fac3=ael6i*r6ij
4113           fac4=ael3i*r3ij
4114           evdwij=(ev1+ev2)
4115           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4116           el2=fac4*fac
4117 C MARYSIA
4118 C          eesij=(el1+el2)
4119 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4120           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4121           if (shield_mode.gt.0) then
4122 C          fac_shield(i)=0.4
4123 C          fac_shield(j)=0.6
4124           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4125           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4126           eesij=(el1+el2)
4127           ees=ees+eesij
4128           else
4129           fac_shield(i)=1.0
4130           fac_shield(j)=1.0
4131           eesij=(el1+el2)
4132           ees=ees+eesij*sss
4133           endif
4134           evdw1=evdw1+evdwij*sss
4135 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4136 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4137 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4138 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4139
4140           if (energy_dec) then
4141             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4142      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4143             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4144      &        fac_shield(i),fac_shield(j)
4145           endif
4146
4147 C
4148 C Calculate contributions to the Cartesian gradient.
4149 C
4150 #ifdef SPLITELE
4151           facvdw=-6*rrmij*(ev1+evdwij)*sss
4152           facel=-3*rrmij*(el1+eesij)
4153           fac1=fac
4154           erij(1)=xj*rmij
4155           erij(2)=yj*rmij
4156           erij(3)=zj*rmij
4157
4158 *
4159 * Radial derivatives. First process both termini of the fragment (i,j)
4160 *
4161           aux=facel*sss+rmij*sssgrad*eesij
4162           ggg(1)=aux*xj
4163           ggg(2)=aux*yj
4164           ggg(3)=aux*zj
4165           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4166      &  (shield_mode.gt.0)) then
4167 C          print *,i,j
4168           do ilist=1,ishield_list(i)
4169            iresshield=shield_list(ilist,i)
4170            do k=1,3
4171            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4172      &      *2.0
4173            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4174      &              rlocshield
4175      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4176             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4177 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4178 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4179 C             if (iresshield.gt.i) then
4180 C               do ishi=i+1,iresshield-1
4181 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4182 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4183 C
4184 C              enddo
4185 C             else
4186 C               do ishi=iresshield,i
4187 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4188 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4189 C
4190 C               enddo
4191 C              endif
4192            enddo
4193           enddo
4194           do ilist=1,ishield_list(j)
4195            iresshield=shield_list(ilist,j)
4196            do k=1,3
4197            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4198      &     *2.0*sss
4199            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4200      &              rlocshield
4201      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4202            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4203
4204 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4205 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4206 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4207 C             if (iresshield.gt.j) then
4208 C               do ishi=j+1,iresshield-1
4209 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4210 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4211 C
4212 C               enddo
4213 C            else
4214 C               do ishi=iresshield,j
4215 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4216 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4217 C               enddo
4218 C              endif
4219            enddo
4220           enddo
4221
4222           do k=1,3
4223             gshieldc(k,i)=gshieldc(k,i)+
4224      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4225             gshieldc(k,j)=gshieldc(k,j)+
4226      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4227             gshieldc(k,i-1)=gshieldc(k,i-1)+
4228      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4229             gshieldc(k,j-1)=gshieldc(k,j-1)+
4230      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4231
4232            enddo
4233            endif
4234 c          do k=1,3
4235 c            ghalf=0.5D0*ggg(k)
4236 c            gelc(k,i)=gelc(k,i)+ghalf
4237 c            gelc(k,j)=gelc(k,j)+ghalf
4238 c          enddo
4239 c 9/28/08 AL Gradient compotents will be summed only at the end
4240 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4241           do k=1,3
4242             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4243 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4244             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4245 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4246 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4247 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4248 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4249 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4250           enddo
4251 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4252
4253 *
4254 * Loop over residues i+1 thru j-1.
4255 *
4256 cgrad          do k=i+1,j-1
4257 cgrad            do l=1,3
4258 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4259 cgrad            enddo
4260 cgrad          enddo
4261           facvdw=facvdw+sssgrad*rmij*evdwij
4262           ggg(1)=facvdw*xj
4263           ggg(2)=facvdw*yj
4264           ggg(3)=facvdw*zj
4265 c          do k=1,3
4266 c            ghalf=0.5D0*ggg(k)
4267 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4268 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4269 c          enddo
4270 c 9/28/08 AL Gradient compotents will be summed only at the end
4271           do k=1,3
4272             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4273             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4274           enddo
4275 *
4276 * Loop over residues i+1 thru j-1.
4277 *
4278 cgrad          do k=i+1,j-1
4279 cgrad            do l=1,3
4280 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4281 cgrad            enddo
4282 cgrad          enddo
4283 #else
4284 C MARYSIA
4285           facvdw=(ev1+evdwij)
4286           facel=(el1+eesij)
4287           fac1=fac
4288           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4289      &       +(evdwij+eesij)*sssgrad*rrmij
4290           erij(1)=xj*rmij
4291           erij(2)=yj*rmij
4292           erij(3)=zj*rmij
4293 *
4294 * Radial derivatives. First process both termini of the fragment (i,j)
4295 *
4296           ggg(1)=fac*xj
4297 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4298           ggg(2)=fac*yj
4299 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4300           ggg(3)=fac*zj
4301 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4302 c          do k=1,3
4303 c            ghalf=0.5D0*ggg(k)
4304 c            gelc(k,i)=gelc(k,i)+ghalf
4305 c            gelc(k,j)=gelc(k,j)+ghalf
4306 c          enddo
4307 c 9/28/08 AL Gradient compotents will be summed only at the end
4308           do k=1,3
4309             gelc_long(k,j)=gelc(k,j)+ggg(k)
4310             gelc_long(k,i)=gelc(k,i)-ggg(k)
4311           enddo
4312 *
4313 * Loop over residues i+1 thru j-1.
4314 *
4315 cgrad          do k=i+1,j-1
4316 cgrad            do l=1,3
4317 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4318 cgrad            enddo
4319 cgrad          enddo
4320 c 9/28/08 AL Gradient compotents will be summed only at the end
4321           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4322           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4323           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4324           do k=1,3
4325             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4326             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4327           enddo
4328 #endif
4329 *
4330 * Angular part
4331 *
4332           ecosa=2.0D0*fac3*fac1+fac4
4333           fac4=-3.0D0*fac4
4334           fac3=-6.0D0*fac3
4335           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4336           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4337           do k=1,3
4338             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4339             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4340           enddo
4341 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4342 cd   &          (dcosg(k),k=1,3)
4343           do k=1,3
4344             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4345      &      fac_shield(i)**2*fac_shield(j)**2*sss
4346           enddo
4347 c          do k=1,3
4348 c            ghalf=0.5D0*ggg(k)
4349 c            gelc(k,i)=gelc(k,i)+ghalf
4350 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4351 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4352 c            gelc(k,j)=gelc(k,j)+ghalf
4353 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4354 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4355 c          enddo
4356 cgrad          do k=i+1,j-1
4357 cgrad            do l=1,3
4358 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4359 cgrad            enddo
4360 cgrad          enddo
4361 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4362           do k=1,3
4363             gelc(k,i)=gelc(k,i)
4364      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4365      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4366      &           *fac_shield(i)**2*fac_shield(j)**2
4367             gelc(k,j)=gelc(k,j)
4368      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4369      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4370      &           *fac_shield(i)**2*fac_shield(j)**2
4371             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4372             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4373           enddo
4374 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4375
4376 C MARYSIA
4377 c          endif !sscale
4378           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4379      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4380      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4381 C
4382 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4383 C   energy of a peptide unit is assumed in the form of a second-order
4384 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4385 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4386 C   are computed for EVERY pair of non-contiguous peptide groups.
4387 C
4388
4389           if (j.lt.nres-1) then
4390             j1=j+1
4391             j2=j-1
4392           else
4393             j1=j-1
4394             j2=j-2
4395           endif
4396           kkk=0
4397           lll=0
4398           do k=1,2
4399             do l=1,2
4400               kkk=kkk+1
4401               muij(kkk)=mu(k,i)*mu(l,j)
4402 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4403 #ifdef NEWCORR
4404              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4405 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4406              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4407              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4408 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4409              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4410 #endif
4411             enddo
4412           enddo
4413 #ifdef DEBUG
4414           write (iout,*) 'EELEC: i',i,' j',j
4415           write (iout,*) 'j',j,' j1',j1,' j2',j2
4416           write(iout,*) 'muij',muij
4417 #endif
4418           ury=scalar(uy(1,i),erij)
4419           urz=scalar(uz(1,i),erij)
4420           vry=scalar(uy(1,j),erij)
4421           vrz=scalar(uz(1,j),erij)
4422           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4423           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4424           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4425           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4426           fac=dsqrt(-ael6i)*r3ij
4427 #ifdef DEBUG
4428           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4429           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4430      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4431      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4432      &      "uzvz",scalar(uz(1,i),uz(1,j))
4433           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4434           write (iout,*) "fac",fac
4435 #endif
4436           a22=a22*fac
4437           a23=a23*fac
4438           a32=a32*fac
4439           a33=a33*fac
4440 #ifdef DEBUG
4441           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4442 #endif
4443 #undef DEBUG
4444 cd          write (iout,'(4i5,4f10.5)')
4445 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4446 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4447 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4448 cd     &      uy(:,j),uz(:,j)
4449 cd          write (iout,'(4f10.5)')
4450 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4451 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4452 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4453 cd           write (iout,'(9f10.5/)')
4454 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4455 C Derivatives of the elements of A in virtual-bond vectors
4456           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4457           do k=1,3
4458             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4459             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4460             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4461             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4462             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4463             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4464             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4465             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4466             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4467             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4468             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4469             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4470           enddo
4471 C Compute radial contributions to the gradient
4472           facr=-3.0d0*rrmij
4473           a22der=a22*facr
4474           a23der=a23*facr
4475           a32der=a32*facr
4476           a33der=a33*facr
4477           agg(1,1)=a22der*xj
4478           agg(2,1)=a22der*yj
4479           agg(3,1)=a22der*zj
4480           agg(1,2)=a23der*xj
4481           agg(2,2)=a23der*yj
4482           agg(3,2)=a23der*zj
4483           agg(1,3)=a32der*xj
4484           agg(2,3)=a32der*yj
4485           agg(3,3)=a32der*zj
4486           agg(1,4)=a33der*xj
4487           agg(2,4)=a33der*yj
4488           agg(3,4)=a33der*zj
4489 C Add the contributions coming from er
4490           fac3=-3.0d0*fac
4491           do k=1,3
4492             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4493             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4494             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4495             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4496           enddo
4497           do k=1,3
4498 C Derivatives in DC(i)
4499 cgrad            ghalf1=0.5d0*agg(k,1)
4500 cgrad            ghalf2=0.5d0*agg(k,2)
4501 cgrad            ghalf3=0.5d0*agg(k,3)
4502 cgrad            ghalf4=0.5d0*agg(k,4)
4503             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4504      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4505             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4506      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4507             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4508      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4509             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4510      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4511 C Derivatives in DC(i+1)
4512             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4513      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4514             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4515      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4516             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4517      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4518             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4519      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4520 C Derivatives in DC(j)
4521             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4522      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4523             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4524      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4525             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4526      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4527             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4528      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4529 C Derivatives in DC(j+1) or DC(nres-1)
4530             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4531      &      -3.0d0*vryg(k,3)*ury)
4532             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4533      &      -3.0d0*vrzg(k,3)*ury)
4534             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4535      &      -3.0d0*vryg(k,3)*urz)
4536             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4537      &      -3.0d0*vrzg(k,3)*urz)
4538 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4539 cgrad              do l=1,4
4540 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4541 cgrad              enddo
4542 cgrad            endif
4543           enddo
4544           acipa(1,1)=a22
4545           acipa(1,2)=a23
4546           acipa(2,1)=a32
4547           acipa(2,2)=a33
4548           a22=-a22
4549           a23=-a23
4550           do l=1,2
4551             do k=1,3
4552               agg(k,l)=-agg(k,l)
4553               aggi(k,l)=-aggi(k,l)
4554               aggi1(k,l)=-aggi1(k,l)
4555               aggj(k,l)=-aggj(k,l)
4556               aggj1(k,l)=-aggj1(k,l)
4557             enddo
4558           enddo
4559           if (j.lt.nres-1) then
4560             a22=-a22
4561             a32=-a32
4562             do l=1,3,2
4563               do k=1,3
4564                 agg(k,l)=-agg(k,l)
4565                 aggi(k,l)=-aggi(k,l)
4566                 aggi1(k,l)=-aggi1(k,l)
4567                 aggj(k,l)=-aggj(k,l)
4568                 aggj1(k,l)=-aggj1(k,l)
4569               enddo
4570             enddo
4571           else
4572             a22=-a22
4573             a23=-a23
4574             a32=-a32
4575             a33=-a33
4576             do l=1,4
4577               do k=1,3
4578                 agg(k,l)=-agg(k,l)
4579                 aggi(k,l)=-aggi(k,l)
4580                 aggi1(k,l)=-aggi1(k,l)
4581                 aggj(k,l)=-aggj(k,l)
4582                 aggj1(k,l)=-aggj1(k,l)
4583               enddo
4584             enddo
4585           endif
4586           ENDIF ! WCORR
4587           IF (wel_loc.gt.0.0d0) THEN
4588 C Contribution to the local-electrostatic energy coming from the i-j pair
4589           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4590      &     +a33*muij(4)
4591 #ifdef DEBUG
4592           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4593      &     " a33",a33
4594           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4595      &     " wel_loc",wel_loc
4596 #endif
4597           if (shield_mode.eq.0) then
4598            fac_shield(i)=1.0
4599            fac_shield(j)=1.0
4600 C          else
4601 C           fac_shield(i)=0.4
4602 C           fac_shield(j)=0.6
4603           endif
4604           eel_loc_ij=eel_loc_ij
4605      &    *fac_shield(i)*fac_shield(j)*sss
4606 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4607 c     &            'eelloc',i,j,eel_loc_ij
4608 C Now derivative over eel_loc
4609           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4610      &  (shield_mode.gt.0)) then
4611 C          print *,i,j
4612
4613           do ilist=1,ishield_list(i)
4614            iresshield=shield_list(ilist,i)
4615            do k=1,3
4616            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4617      &                                          /fac_shield(i)
4618 C     &      *2.0
4619            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4620      &              rlocshield
4621      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4622             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4623      &      +rlocshield
4624            enddo
4625           enddo
4626           do ilist=1,ishield_list(j)
4627            iresshield=shield_list(ilist,j)
4628            do k=1,3
4629            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4630      &                                       /fac_shield(j)
4631 C     &     *2.0
4632            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4633      &              rlocshield
4634      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4635            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4636      &             +rlocshield
4637
4638            enddo
4639           enddo
4640
4641           do k=1,3
4642             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4643      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4644             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4645      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4646             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4647      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4648             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4649      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4650            enddo
4651            endif
4652
4653
4654 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4655 c     &                     ' eel_loc_ij',eel_loc_ij
4656 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4657 C Calculate patrial derivative for theta angle
4658 #ifdef NEWCORR
4659          geel_loc_ij=(a22*gmuij1(1)
4660      &     +a23*gmuij1(2)
4661      &     +a32*gmuij1(3)
4662      &     +a33*gmuij1(4))
4663      &    *fac_shield(i)*fac_shield(j)*sss
4664 c         write(iout,*) "derivative over thatai"
4665 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4666 c     &   a33*gmuij1(4)
4667          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4668      &      geel_loc_ij*wel_loc
4669 c         write(iout,*) "derivative over thatai-1"
4670 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4671 c     &   a33*gmuij2(4)
4672          geel_loc_ij=
4673      &     a22*gmuij2(1)
4674      &     +a23*gmuij2(2)
4675      &     +a32*gmuij2(3)
4676      &     +a33*gmuij2(4)
4677          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4678      &      geel_loc_ij*wel_loc
4679      &    *fac_shield(i)*fac_shield(j)*sss
4680
4681 c  Derivative over j residue
4682          geel_loc_ji=a22*gmuji1(1)
4683      &     +a23*gmuji1(2)
4684      &     +a32*gmuji1(3)
4685      &     +a33*gmuji1(4)
4686 c         write(iout,*) "derivative over thataj"
4687 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4688 c     &   a33*gmuji1(4)
4689
4690         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4691      &      geel_loc_ji*wel_loc
4692      &    *fac_shield(i)*fac_shield(j)*sss
4693
4694          geel_loc_ji=
4695      &     +a22*gmuji2(1)
4696      &     +a23*gmuji2(2)
4697      &     +a32*gmuji2(3)
4698      &     +a33*gmuji2(4)
4699 c         write(iout,*) "derivative over thataj-1"
4700 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4701 c     &   a33*gmuji2(4)
4702          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4703      &      geel_loc_ji*wel_loc
4704      &    *fac_shield(i)*fac_shield(j)*sss
4705 #endif
4706 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4707
4708           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4709      &            'eelloc',i,j,eel_loc_ij
4710 c           if (eel_loc_ij.ne.0)
4711 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4712 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4713
4714           eel_loc=eel_loc+eel_loc_ij
4715 C Partial derivatives in virtual-bond dihedral angles gamma
4716           if (i.gt.1)
4717      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4718      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4719      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4720      &    *fac_shield(i)*fac_shield(j)*sss
4721
4722           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4723      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4724      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4725      &    *fac_shield(i)*fac_shield(j)*sss
4726 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4727           aux=eel_loc_ij/sss*sssgrad*rmij
4728           ggg(1)=aux*xj
4729           ggg(2)=aux*yj
4730           ggg(3)=aux*zj
4731           do l=1,3
4732             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4733      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4734      &    *fac_shield(i)*fac_shield(j)*sss
4735             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4736             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4737 cgrad            ghalf=0.5d0*ggg(l)
4738 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4739 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4740           enddo
4741 cgrad          do k=i+1,j2
4742 cgrad            do l=1,3
4743 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4744 cgrad            enddo
4745 cgrad          enddo
4746 C Remaining derivatives of eello
4747           do l=1,3
4748             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4749      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4750      &    *fac_shield(i)*fac_shield(j)*sss
4751
4752             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4753      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4754      &    *fac_shield(i)*fac_shield(j)*sss
4755
4756             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4757      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4758      &    *fac_shield(i)*fac_shield(j)*sss
4759
4760             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4761      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4762      &    *fac_shield(i)*fac_shield(j)*sss
4763
4764           enddo
4765           ENDIF
4766 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4767 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4768 #ifdef FOURBODY
4769           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4770      &       .and. num_conti.le.maxconts) then
4771 c            write (iout,*) i,j," entered corr"
4772 C
4773 C Calculate the contact function. The ith column of the array JCONT will
4774 C contain the numbers of atoms that make contacts with the atom I (of numbers
4775 C greater than I). The arrays FACONT and GACONT will contain the values of
4776 C the contact function and its derivative.
4777 c           r0ij=1.02D0*rpp(iteli,itelj)
4778 c           r0ij=1.11D0*rpp(iteli,itelj)
4779             r0ij=2.20D0*rpp(iteli,itelj)
4780 c           r0ij=1.55D0*rpp(iteli,itelj)
4781             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4782             if (fcont.gt.0.0D0) then
4783               num_conti=num_conti+1
4784               if (num_conti.gt.maxconts) then
4785                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4786      &                         ' will skip next contacts for this conf.'
4787               else
4788                 jcont_hb(num_conti,i)=j
4789 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4790 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4791                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4792      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4793 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4794 C  terms.
4795                 d_cont(num_conti,i)=rij
4796 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4797 C     --- Electrostatic-interaction matrix ---
4798                 a_chuj(1,1,num_conti,i)=a22
4799                 a_chuj(1,2,num_conti,i)=a23
4800                 a_chuj(2,1,num_conti,i)=a32
4801                 a_chuj(2,2,num_conti,i)=a33
4802 C     --- Gradient of rij
4803                 do kkk=1,3
4804                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4805                 enddo
4806                 kkll=0
4807                 do k=1,2
4808                   do l=1,2
4809                     kkll=kkll+1
4810                     do m=1,3
4811                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4812                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4813                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4814                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4815                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4816                     enddo
4817                   enddo
4818                 enddo
4819                 ENDIF
4820                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4821 C Calculate contact energies
4822                 cosa4=4.0D0*cosa
4823                 wij=cosa-3.0D0*cosb*cosg
4824                 cosbg1=cosb+cosg
4825                 cosbg2=cosb-cosg
4826 c               fac3=dsqrt(-ael6i)/r0ij**3
4827                 fac3=dsqrt(-ael6i)*r3ij
4828 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4829                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4830                 if (ees0tmp.gt.0) then
4831                   ees0pij=dsqrt(ees0tmp)
4832                 else
4833                   ees0pij=0
4834                 endif
4835 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4836                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4837                 if (ees0tmp.gt.0) then
4838                   ees0mij=dsqrt(ees0tmp)
4839                 else
4840                   ees0mij=0
4841                 endif
4842 c               ees0mij=0.0D0
4843                 if (shield_mode.eq.0) then
4844                 fac_shield(i)=1.0d0
4845                 fac_shield(j)=1.0d0
4846                 else
4847                 ees0plist(num_conti,i)=j
4848 C                fac_shield(i)=0.4d0
4849 C                fac_shield(j)=0.6d0
4850                 endif
4851                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4852      &          *fac_shield(i)*fac_shield(j)*sss
4853                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4854      &          *fac_shield(i)*fac_shield(j)*sss
4855 C Diagnostics. Comment out or remove after debugging!
4856 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4857 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4858 c               ees0m(num_conti,i)=0.0D0
4859 C End diagnostics.
4860 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4861 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4862 C Angular derivatives of the contact function
4863                 ees0pij1=fac3/ees0pij
4864                 ees0mij1=fac3/ees0mij
4865                 fac3p=-3.0D0*fac3*rrmij
4866                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4867                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4868 c               ees0mij1=0.0D0
4869                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4870                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4871                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4872                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4873                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4874                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4875                 ecosap=ecosa1+ecosa2
4876                 ecosbp=ecosb1+ecosb2
4877                 ecosgp=ecosg1+ecosg2
4878                 ecosam=ecosa1-ecosa2
4879                 ecosbm=ecosb1-ecosb2
4880                 ecosgm=ecosg1-ecosg2
4881 C Diagnostics
4882 c               ecosap=ecosa1
4883 c               ecosbp=ecosb1
4884 c               ecosgp=ecosg1
4885 c               ecosam=0.0D0
4886 c               ecosbm=0.0D0
4887 c               ecosgm=0.0D0
4888 C End diagnostics
4889                 facont_hb(num_conti,i)=fcont
4890                 fprimcont=fprimcont/rij
4891 cd              facont_hb(num_conti,i)=1.0D0
4892 C Following line is for diagnostics.
4893 cd              fprimcont=0.0D0
4894                 do k=1,3
4895                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4896                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4897                 enddo
4898                 do k=1,3
4899                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4900                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4901                 enddo
4902                 gggp(1)=gggp(1)+ees0pijp*xj
4903      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4904                 gggp(2)=gggp(2)+ees0pijp*yj
4905      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4906                 gggp(3)=gggp(3)+ees0pijp*zj
4907      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4908                 gggm(1)=gggm(1)+ees0mijp*xj
4909      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4910                 gggm(2)=gggm(2)+ees0mijp*yj
4911      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4912                 gggm(3)=gggm(3)+ees0mijp*zj
4913      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4914 C Derivatives due to the contact function
4915                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4916                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4917                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4918                 do k=1,3
4919 c
4920 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4921 c          following the change of gradient-summation algorithm.
4922 c
4923 cgrad                  ghalfp=0.5D0*gggp(k)
4924 cgrad                  ghalfm=0.5D0*gggm(k)
4925                   gacontp_hb1(k,num_conti,i)=!ghalfp
4926      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4927      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4928      &          *fac_shield(i)*fac_shield(j)*sss
4929
4930                   gacontp_hb2(k,num_conti,i)=!ghalfp
4931      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4932      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4933      &          *fac_shield(i)*fac_shield(j)*sss
4934
4935                   gacontp_hb3(k,num_conti,i)=gggp(k)
4936      &          *fac_shield(i)*fac_shield(j)*sss
4937
4938                   gacontm_hb1(k,num_conti,i)=!ghalfm
4939      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4940      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4941      &          *fac_shield(i)*fac_shield(j)*sss
4942
4943                   gacontm_hb2(k,num_conti,i)=!ghalfm
4944      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4945      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4946      &          *fac_shield(i)*fac_shield(j)*sss
4947
4948                   gacontm_hb3(k,num_conti,i)=gggm(k)
4949      &          *fac_shield(i)*fac_shield(j)*sss
4950
4951                 enddo
4952 C Diagnostics. Comment out or remove after debugging!
4953 cdiag           do k=1,3
4954 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4955 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4956 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4957 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4958 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4959 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4960 cdiag           enddo
4961               ENDIF ! wcorr
4962               endif  ! num_conti.le.maxconts
4963             endif  ! fcont.gt.0
4964           endif    ! j.gt.i+1
4965 #endif
4966           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4967             do k=1,4
4968               do l=1,3
4969                 ghalf=0.5d0*agg(l,k)
4970                 aggi(l,k)=aggi(l,k)+ghalf
4971                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4972                 aggj(l,k)=aggj(l,k)+ghalf
4973               enddo
4974             enddo
4975             if (j.eq.nres-1 .and. i.lt.j-2) then
4976               do k=1,4
4977                 do l=1,3
4978                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4979                 enddo
4980               enddo
4981             endif
4982           endif
4983 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4984       return
4985       end
4986 C-----------------------------------------------------------------------------
4987       subroutine eturn3(i,eello_turn3)
4988 C Third- and fourth-order contributions from turns
4989       implicit real*8 (a-h,o-z)
4990       include 'DIMENSIONS'
4991       include 'COMMON.IOUNITS'
4992       include 'COMMON.GEO'
4993       include 'COMMON.VAR'
4994       include 'COMMON.LOCAL'
4995       include 'COMMON.CHAIN'
4996       include 'COMMON.DERIV'
4997       include 'COMMON.INTERACT'
4998       include 'COMMON.CORRMAT'
4999       include 'COMMON.TORSION'
5000       include 'COMMON.VECTORS'
5001       include 'COMMON.FFIELD'
5002       include 'COMMON.CONTROL'
5003       include 'COMMON.SHIELD'
5004       dimension ggg(3)
5005       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5006      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5007      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
5008      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
5009      &  auxgmat2(2,2),auxgmatt2(2,2)
5010       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5011      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5012       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5013      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5014      &    num_conti,j1,j2
5015       j=i+2
5016 c      write (iout,*) "eturn3",i,j,j1,j2
5017       a_temp(1,1)=a22
5018       a_temp(1,2)=a23
5019       a_temp(2,1)=a32
5020       a_temp(2,2)=a33
5021 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5022 C
5023 C               Third-order contributions
5024 C
5025 C                 (i+2)o----(i+3)
5026 C                      | |
5027 C                      | |
5028 C                 (i+1)o----i
5029 C
5030 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5031 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5032         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5033 c auxalary matices for theta gradient
5034 c auxalary matrix for i+1 and constant i+2
5035         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5036 c auxalary matrix for i+2 and constant i+1
5037         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5038         call transpose2(auxmat(1,1),auxmat1(1,1))
5039         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5040         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5041         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5042         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5043         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5044         if (shield_mode.eq.0) then
5045         fac_shield(i)=1.0
5046         fac_shield(j)=1.0
5047 C        else
5048 C        fac_shield(i)=0.4
5049 C        fac_shield(j)=0.6
5050         endif
5051         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5052      &  *fac_shield(i)*fac_shield(j)
5053         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5054      &  *fac_shield(i)*fac_shield(j)
5055         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5056      &    eello_t3
5057 C#ifdef NEWCORR
5058 C Derivatives in theta
5059         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5060      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5061      &   *fac_shield(i)*fac_shield(j)
5062         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5063      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5064      &   *fac_shield(i)*fac_shield(j)
5065 C#endif
5066
5067 C Derivatives in shield mode
5068           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5069      &  (shield_mode.gt.0)) then
5070 C          print *,i,j
5071
5072           do ilist=1,ishield_list(i)
5073            iresshield=shield_list(ilist,i)
5074            do k=1,3
5075            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5076 C     &      *2.0
5077            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5078      &              rlocshield
5079      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5080             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5081      &      +rlocshield
5082            enddo
5083           enddo
5084           do ilist=1,ishield_list(j)
5085            iresshield=shield_list(ilist,j)
5086            do k=1,3
5087            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5088 C     &     *2.0
5089            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5090      &              rlocshield
5091      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5092            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5093      &             +rlocshield
5094
5095            enddo
5096           enddo
5097
5098           do k=1,3
5099             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5100      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5101             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5102      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5103             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5104      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5105             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5106      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5107            enddo
5108            endif
5109
5110 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5111 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5112 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5113 cd     &    ' eello_turn3_num',4*eello_turn3_num
5114 C Derivatives in gamma(i)
5115         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5116         call transpose2(auxmat2(1,1),auxmat3(1,1))
5117         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5118         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5119      &   *fac_shield(i)*fac_shield(j)
5120 C Derivatives in gamma(i+1)
5121         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5122         call transpose2(auxmat2(1,1),auxmat3(1,1))
5123         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5124         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5125      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5126      &   *fac_shield(i)*fac_shield(j)
5127 C Cartesian derivatives
5128         do l=1,3
5129 c            ghalf1=0.5d0*agg(l,1)
5130 c            ghalf2=0.5d0*agg(l,2)
5131 c            ghalf3=0.5d0*agg(l,3)
5132 c            ghalf4=0.5d0*agg(l,4)
5133           a_temp(1,1)=aggi(l,1)!+ghalf1
5134           a_temp(1,2)=aggi(l,2)!+ghalf2
5135           a_temp(2,1)=aggi(l,3)!+ghalf3
5136           a_temp(2,2)=aggi(l,4)!+ghalf4
5137           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5138           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5139      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5140      &   *fac_shield(i)*fac_shield(j)
5141
5142           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5143           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5144           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5145           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5146           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5147           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5148      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5149      &   *fac_shield(i)*fac_shield(j)
5150           a_temp(1,1)=aggj(l,1)!+ghalf1
5151           a_temp(1,2)=aggj(l,2)!+ghalf2
5152           a_temp(2,1)=aggj(l,3)!+ghalf3
5153           a_temp(2,2)=aggj(l,4)!+ghalf4
5154           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5155           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5156      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5157      &   *fac_shield(i)*fac_shield(j)
5158           a_temp(1,1)=aggj1(l,1)
5159           a_temp(1,2)=aggj1(l,2)
5160           a_temp(2,1)=aggj1(l,3)
5161           a_temp(2,2)=aggj1(l,4)
5162           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5163           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5164      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5165      &   *fac_shield(i)*fac_shield(j)
5166         enddo
5167       return
5168       end
5169 C-------------------------------------------------------------------------------
5170       subroutine eturn4(i,eello_turn4)
5171 C Third- and fourth-order contributions from turns
5172       implicit real*8 (a-h,o-z)
5173       include 'DIMENSIONS'
5174       include 'COMMON.IOUNITS'
5175       include 'COMMON.GEO'
5176       include 'COMMON.VAR'
5177       include 'COMMON.LOCAL'
5178       include 'COMMON.CHAIN'
5179       include 'COMMON.DERIV'
5180       include 'COMMON.INTERACT'
5181       include 'COMMON.CORRMAT'
5182       include 'COMMON.TORSION'
5183       include 'COMMON.VECTORS'
5184       include 'COMMON.FFIELD'
5185       include 'COMMON.CONTROL'
5186       include 'COMMON.SHIELD'
5187       dimension ggg(3)
5188       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5189      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5190      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5191      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5192      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5193      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5194      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5195       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5196      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5197       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5198      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5199      &    num_conti,j1,j2
5200       j=i+3
5201 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5202 C
5203 C               Fourth-order contributions
5204 C
5205 C                 (i+3)o----(i+4)
5206 C                     /  |
5207 C               (i+2)o   |
5208 C                     \  |
5209 C                 (i+1)o----i
5210 C
5211 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5212 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5213 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5214 c        write(iout,*)"WCHODZE W PROGRAM"
5215         a_temp(1,1)=a22
5216         a_temp(1,2)=a23
5217         a_temp(2,1)=a32
5218         a_temp(2,2)=a33
5219         iti1=itype2loc(itype(i+1))
5220         iti2=itype2loc(itype(i+2))
5221         iti3=itype2loc(itype(i+3))
5222 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5223         call transpose2(EUg(1,1,i+1),e1t(1,1))
5224         call transpose2(Eug(1,1,i+2),e2t(1,1))
5225         call transpose2(Eug(1,1,i+3),e3t(1,1))
5226 C Ematrix derivative in theta
5227         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5228         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5229         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5230         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5231 c       eta1 in derivative theta
5232         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5233         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5234 c       auxgvec is derivative of Ub2 so i+3 theta
5235         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5236 c       auxalary matrix of E i+1
5237         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5238 c        s1=0.0
5239 c        gs1=0.0
5240         s1=scalar2(b1(1,i+2),auxvec(1))
5241 c derivative of theta i+2 with constant i+3
5242         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5243 c derivative of theta i+2 with constant i+2
5244         gs32=scalar2(b1(1,i+2),auxgvec(1))
5245 c derivative of E matix in theta of i+1
5246         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5247
5248         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5249 c       ea31 in derivative theta
5250         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5251         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5252 c auxilary matrix auxgvec of Ub2 with constant E matirx
5253         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5254 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5255         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5256
5257 c        s2=0.0
5258 c        gs2=0.0
5259         s2=scalar2(b1(1,i+1),auxvec(1))
5260 c derivative of theta i+1 with constant i+3
5261         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5262 c derivative of theta i+2 with constant i+1
5263         gs21=scalar2(b1(1,i+1),auxgvec(1))
5264 c derivative of theta i+3 with constant i+1
5265         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5266 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5267 c     &  gtb1(1,i+1)
5268         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5269 c two derivatives over diffetent matrices
5270 c gtae3e2 is derivative over i+3
5271         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5272 c ae3gte2 is derivative over i+2
5273         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5274         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5275 c three possible derivative over theta E matices
5276 c i+1
5277         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5278 c i+2
5279         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5280 c i+3
5281         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5282         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5283
5284         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5285         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5286         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5287         if (shield_mode.eq.0) then
5288         fac_shield(i)=1.0
5289         fac_shield(j)=1.0
5290 C        else
5291 C        fac_shield(i)=0.6
5292 C        fac_shield(j)=0.4
5293         endif
5294         eello_turn4=eello_turn4-(s1+s2+s3)
5295      &  *fac_shield(i)*fac_shield(j)
5296         eello_t4=-(s1+s2+s3)
5297      &  *fac_shield(i)*fac_shield(j)
5298 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5299         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5300      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5301 C Now derivative over shield:
5302           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5303      &  (shield_mode.gt.0)) then
5304 C          print *,i,j
5305
5306           do ilist=1,ishield_list(i)
5307            iresshield=shield_list(ilist,i)
5308            do k=1,3
5309            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5310 C     &      *2.0
5311            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5312      &              rlocshield
5313      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5314             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5315      &      +rlocshield
5316            enddo
5317           enddo
5318           do ilist=1,ishield_list(j)
5319            iresshield=shield_list(ilist,j)
5320            do k=1,3
5321            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5322 C     &     *2.0
5323            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5324      &              rlocshield
5325      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5326            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5327      &             +rlocshield
5328
5329            enddo
5330           enddo
5331
5332           do k=1,3
5333             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5334      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5335             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5336      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5337             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5338      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5339             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5340      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5341            enddo
5342            endif
5343
5344
5345
5346
5347
5348
5349 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5350 cd     &    ' eello_turn4_num',8*eello_turn4_num
5351 #ifdef NEWCORR
5352         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5353      &                  -(gs13+gsE13+gsEE1)*wturn4
5354      &  *fac_shield(i)*fac_shield(j)
5355         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5356      &                    -(gs23+gs21+gsEE2)*wturn4
5357      &  *fac_shield(i)*fac_shield(j)
5358
5359         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5360      &                    -(gs32+gsE31+gsEE3)*wturn4
5361      &  *fac_shield(i)*fac_shield(j)
5362
5363 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5364 c     &   gs2
5365 #endif
5366         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5367      &      'eturn4',i,j,-(s1+s2+s3)
5368 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5369 c     &    ' eello_turn4_num',8*eello_turn4_num
5370 C Derivatives in gamma(i)
5371         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5372         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5373         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5374         s1=scalar2(b1(1,i+2),auxvec(1))
5375         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5376         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5377         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5378      &  *fac_shield(i)*fac_shield(j)
5379 C Derivatives in gamma(i+1)
5380         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5381         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5382         s2=scalar2(b1(1,i+1),auxvec(1))
5383         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5384         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5385         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5386         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5387      &  *fac_shield(i)*fac_shield(j)
5388 C Derivatives in gamma(i+2)
5389         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5390         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5391         s1=scalar2(b1(1,i+2),auxvec(1))
5392         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5393         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5394         s2=scalar2(b1(1,i+1),auxvec(1))
5395         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5396         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5397         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5398         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5399      &  *fac_shield(i)*fac_shield(j)
5400 C Cartesian derivatives
5401 C Derivatives of this turn contributions in DC(i+2)
5402         if (j.lt.nres-1) then
5403           do l=1,3
5404             a_temp(1,1)=agg(l,1)
5405             a_temp(1,2)=agg(l,2)
5406             a_temp(2,1)=agg(l,3)
5407             a_temp(2,2)=agg(l,4)
5408             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5409             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5410             s1=scalar2(b1(1,i+2),auxvec(1))
5411             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5412             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5413             s2=scalar2(b1(1,i+1),auxvec(1))
5414             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5415             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5416             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5417             ggg(l)=-(s1+s2+s3)
5418             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5419      &  *fac_shield(i)*fac_shield(j)
5420           enddo
5421         endif
5422 C Remaining derivatives of this turn contribution
5423         do l=1,3
5424           a_temp(1,1)=aggi(l,1)
5425           a_temp(1,2)=aggi(l,2)
5426           a_temp(2,1)=aggi(l,3)
5427           a_temp(2,2)=aggi(l,4)
5428           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5429           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5430           s1=scalar2(b1(1,i+2),auxvec(1))
5431           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5432           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5433           s2=scalar2(b1(1,i+1),auxvec(1))
5434           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5435           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5436           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5437           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5438      &  *fac_shield(i)*fac_shield(j)
5439           a_temp(1,1)=aggi1(l,1)
5440           a_temp(1,2)=aggi1(l,2)
5441           a_temp(2,1)=aggi1(l,3)
5442           a_temp(2,2)=aggi1(l,4)
5443           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5444           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5445           s1=scalar2(b1(1,i+2),auxvec(1))
5446           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5447           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5448           s2=scalar2(b1(1,i+1),auxvec(1))
5449           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5450           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5451           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5452           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5453      &  *fac_shield(i)*fac_shield(j)
5454           a_temp(1,1)=aggj(l,1)
5455           a_temp(1,2)=aggj(l,2)
5456           a_temp(2,1)=aggj(l,3)
5457           a_temp(2,2)=aggj(l,4)
5458           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5459           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5460           s1=scalar2(b1(1,i+2),auxvec(1))
5461           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5462           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5463           s2=scalar2(b1(1,i+1),auxvec(1))
5464           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5465           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5466           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5467           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5468      &  *fac_shield(i)*fac_shield(j)
5469           a_temp(1,1)=aggj1(l,1)
5470           a_temp(1,2)=aggj1(l,2)
5471           a_temp(2,1)=aggj1(l,3)
5472           a_temp(2,2)=aggj1(l,4)
5473           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5474           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5475           s1=scalar2(b1(1,i+2),auxvec(1))
5476           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5477           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5478           s2=scalar2(b1(1,i+1),auxvec(1))
5479           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5480           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5481           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5482 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5483           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5484      &  *fac_shield(i)*fac_shield(j)
5485         enddo
5486       return
5487       end
5488 C-----------------------------------------------------------------------------
5489       subroutine vecpr(u,v,w)
5490       implicit real*8(a-h,o-z)
5491       dimension u(3),v(3),w(3)
5492       w(1)=u(2)*v(3)-u(3)*v(2)
5493       w(2)=-u(1)*v(3)+u(3)*v(1)
5494       w(3)=u(1)*v(2)-u(2)*v(1)
5495       return
5496       end
5497 C-----------------------------------------------------------------------------
5498       subroutine unormderiv(u,ugrad,unorm,ungrad)
5499 C This subroutine computes the derivatives of a normalized vector u, given
5500 C the derivatives computed without normalization conditions, ugrad. Returns
5501 C ungrad.
5502       implicit none
5503       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5504       double precision vec(3)
5505       double precision scalar
5506       integer i,j
5507 c      write (2,*) 'ugrad',ugrad
5508 c      write (2,*) 'u',u
5509       do i=1,3
5510         vec(i)=scalar(ugrad(1,i),u(1))
5511       enddo
5512 c      write (2,*) 'vec',vec
5513       do i=1,3
5514         do j=1,3
5515           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5516         enddo
5517       enddo
5518 c      write (2,*) 'ungrad',ungrad
5519       return
5520       end
5521 C-----------------------------------------------------------------------------
5522       subroutine escp_soft_sphere(evdw2,evdw2_14)
5523 C
5524 C This subroutine calculates the excluded-volume interaction energy between
5525 C peptide-group centers and side chains and its gradient in virtual-bond and
5526 C side-chain vectors.
5527 C
5528       implicit real*8 (a-h,o-z)
5529       include 'DIMENSIONS'
5530       include 'COMMON.GEO'
5531       include 'COMMON.VAR'
5532       include 'COMMON.LOCAL'
5533       include 'COMMON.CHAIN'
5534       include 'COMMON.DERIV'
5535       include 'COMMON.INTERACT'
5536       include 'COMMON.FFIELD'
5537       include 'COMMON.IOUNITS'
5538       include 'COMMON.CONTROL'
5539       dimension ggg(3)
5540       integer xshift,yshift,zshift
5541       evdw2=0.0D0
5542       evdw2_14=0.0d0
5543       r0_scp=4.5d0
5544 cd    print '(a)','Enter ESCP'
5545 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5546 C      do xshift=-1,1
5547 C      do yshift=-1,1
5548 C      do zshift=-1,1
5549       do i=iatscp_s,iatscp_e
5550         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5551         iteli=itel(i)
5552         xi=0.5D0*(c(1,i)+c(1,i+1))
5553         yi=0.5D0*(c(2,i)+c(2,i+1))
5554         zi=0.5D0*(c(3,i)+c(3,i+1))
5555 C Return atom into box, boxxsize is size of box in x dimension
5556 c  134   continue
5557 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5558 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5559 C Condition for being inside the proper box
5560 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5561 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5562 c        go to 134
5563 c        endif
5564 c  135   continue
5565 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5566 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5567 C Condition for being inside the proper box
5568 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5569 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5570 c        go to 135
5571 c c       endif
5572 c  136   continue
5573 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5574 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5575 cC Condition for being inside the proper box
5576 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5577 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5578 c        go to 136
5579 c        endif
5580           xi=mod(xi,boxxsize)
5581           if (xi.lt.0) xi=xi+boxxsize
5582           yi=mod(yi,boxysize)
5583           if (yi.lt.0) yi=yi+boxysize
5584           zi=mod(zi,boxzsize)
5585           if (zi.lt.0) zi=zi+boxzsize
5586 C          xi=xi+xshift*boxxsize
5587 C          yi=yi+yshift*boxysize
5588 C          zi=zi+zshift*boxzsize
5589         do iint=1,nscp_gr(i)
5590
5591         do j=iscpstart(i,iint),iscpend(i,iint)
5592           if (itype(j).eq.ntyp1) cycle
5593           itypj=iabs(itype(j))
5594 C Uncomment following three lines for SC-p interactions
5595 c         xj=c(1,nres+j)-xi
5596 c         yj=c(2,nres+j)-yi
5597 c         zj=c(3,nres+j)-zi
5598 C Uncomment following three lines for Ca-p interactions
5599           xj=c(1,j)
5600           yj=c(2,j)
5601           zj=c(3,j)
5602 c  174   continue
5603 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5604 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5605 C Condition for being inside the proper box
5606 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5607 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5608 c        go to 174
5609 c        endif
5610 c  175   continue
5611 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5612 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5613 cC Condition for being inside the proper box
5614 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5615 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5616 c        go to 175
5617 c        endif
5618 c  176   continue
5619 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5620 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5621 C Condition for being inside the proper box
5622 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5623 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5624 c        go to 176
5625           xj=mod(xj,boxxsize)
5626           if (xj.lt.0) xj=xj+boxxsize
5627           yj=mod(yj,boxysize)
5628           if (yj.lt.0) yj=yj+boxysize
5629           zj=mod(zj,boxzsize)
5630           if (zj.lt.0) zj=zj+boxzsize
5631       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5632       xj_safe=xj
5633       yj_safe=yj
5634       zj_safe=zj
5635       subchap=0
5636       do xshift=-1,1
5637       do yshift=-1,1
5638       do zshift=-1,1
5639           xj=xj_safe+xshift*boxxsize
5640           yj=yj_safe+yshift*boxysize
5641           zj=zj_safe+zshift*boxzsize
5642           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5643           if(dist_temp.lt.dist_init) then
5644             dist_init=dist_temp
5645             xj_temp=xj
5646             yj_temp=yj
5647             zj_temp=zj
5648             subchap=1
5649           endif
5650        enddo
5651        enddo
5652        enddo
5653        if (subchap.eq.1) then
5654           xj=xj_temp-xi
5655           yj=yj_temp-yi
5656           zj=zj_temp-zi
5657        else
5658           xj=xj_safe-xi
5659           yj=yj_safe-yi
5660           zj=zj_safe-zi
5661        endif
5662 c c       endif
5663 C          xj=xj-xi
5664 C          yj=yj-yi
5665 C          zj=zj-zi
5666           rij=xj*xj+yj*yj+zj*zj
5667
5668           r0ij=r0_scp
5669           r0ijsq=r0ij*r0ij
5670           if (rij.lt.r0ijsq) then
5671             evdwij=0.25d0*(rij-r0ijsq)**2
5672             fac=rij-r0ijsq
5673           else
5674             evdwij=0.0d0
5675             fac=0.0d0
5676           endif
5677           evdw2=evdw2+evdwij
5678 C
5679 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5680 C
5681           ggg(1)=xj*fac
5682           ggg(2)=yj*fac
5683           ggg(3)=zj*fac
5684 cgrad          if (j.lt.i) then
5685 cd          write (iout,*) 'j<i'
5686 C Uncomment following three lines for SC-p interactions
5687 c           do k=1,3
5688 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5689 c           enddo
5690 cgrad          else
5691 cd          write (iout,*) 'j>i'
5692 cgrad            do k=1,3
5693 cgrad              ggg(k)=-ggg(k)
5694 C Uncomment following line for SC-p interactions
5695 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5696 cgrad            enddo
5697 cgrad          endif
5698 cgrad          do k=1,3
5699 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5700 cgrad          enddo
5701 cgrad          kstart=min0(i+1,j)
5702 cgrad          kend=max0(i-1,j-1)
5703 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5704 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5705 cgrad          do k=kstart,kend
5706 cgrad            do l=1,3
5707 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5708 cgrad            enddo
5709 cgrad          enddo
5710           do k=1,3
5711             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5712             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5713           enddo
5714         enddo
5715
5716         enddo ! iint
5717       enddo ! i
5718 C      enddo !zshift
5719 C      enddo !yshift
5720 C      enddo !xshift
5721       return
5722       end
5723 C-----------------------------------------------------------------------------
5724       subroutine escp(evdw2,evdw2_14)
5725 C
5726 C This subroutine calculates the excluded-volume interaction energy between
5727 C peptide-group centers and side chains and its gradient in virtual-bond and
5728 C side-chain vectors.
5729 C
5730       implicit none
5731       include 'DIMENSIONS'
5732       include 'COMMON.GEO'
5733       include 'COMMON.VAR'
5734       include 'COMMON.LOCAL'
5735       include 'COMMON.CHAIN'
5736       include 'COMMON.DERIV'
5737       include 'COMMON.INTERACT'
5738       include 'COMMON.FFIELD'
5739       include 'COMMON.IOUNITS'
5740       include 'COMMON.CONTROL'
5741       include 'COMMON.SPLITELE'
5742       integer xshift,yshift,zshift
5743       double precision ggg(3)
5744       integer i,iint,j,k,iteli,itypj,subchap
5745       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5746      & fac,e1,e2,rij
5747       double precision evdw2,evdw2_14,evdwij
5748       double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,
5749      & dist_temp, dist_init
5750       double precision sscale,sscagrad
5751       evdw2=0.0D0
5752       evdw2_14=0.0d0
5753 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5754 cd    print '(a)','Enter ESCP'
5755 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5756 C      do xshift=-1,1
5757 C      do yshift=-1,1
5758 C      do zshift=-1,1
5759       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5760       do i=iatscp_s,iatscp_e
5761         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5762         iteli=itel(i)
5763         xi=0.5D0*(c(1,i)+c(1,i+1))
5764         yi=0.5D0*(c(2,i)+c(2,i+1))
5765         zi=0.5D0*(c(3,i)+c(3,i+1))
5766           xi=mod(xi,boxxsize)
5767           if (xi.lt.0) xi=xi+boxxsize
5768           yi=mod(yi,boxysize)
5769           if (yi.lt.0) yi=yi+boxysize
5770           zi=mod(zi,boxzsize)
5771           if (zi.lt.0) zi=zi+boxzsize
5772 c          xi=xi+xshift*boxxsize
5773 c          yi=yi+yshift*boxysize
5774 c          zi=zi+zshift*boxzsize
5775 c        print *,xi,yi,zi,'polozenie i'
5776 C Return atom into box, boxxsize is size of box in x dimension
5777 c  134   continue
5778 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5779 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5780 C Condition for being inside the proper box
5781 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5782 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5783 c        go to 134
5784 c        endif
5785 c  135   continue
5786 c          print *,xi,boxxsize,"pierwszy"
5787
5788 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5789 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5790 C Condition for being inside the proper box
5791 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5792 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5793 c        go to 135
5794 c        endif
5795 c  136   continue
5796 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5797 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5798 C Condition for being inside the proper box
5799 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5800 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5801 c        go to 136
5802 c        endif
5803         do iint=1,nscp_gr(i)
5804
5805         do j=iscpstart(i,iint),iscpend(i,iint)
5806           itypj=iabs(itype(j))
5807           if (itypj.eq.ntyp1) cycle
5808 C Uncomment following three lines for SC-p interactions
5809 c         xj=c(1,nres+j)-xi
5810 c         yj=c(2,nres+j)-yi
5811 c         zj=c(3,nres+j)-zi
5812 C Uncomment following three lines for Ca-p interactions
5813           xj=c(1,j)
5814           yj=c(2,j)
5815           zj=c(3,j)
5816           xj=mod(xj,boxxsize)
5817           if (xj.lt.0) xj=xj+boxxsize
5818           yj=mod(yj,boxysize)
5819           if (yj.lt.0) yj=yj+boxysize
5820           zj=mod(zj,boxzsize)
5821           if (zj.lt.0) zj=zj+boxzsize
5822 c  174   continue
5823 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5824 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5825 C Condition for being inside the proper box
5826 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5827 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5828 c        go to 174
5829 c        endif
5830 c  175   continue
5831 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5832 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5833 cC Condition for being inside the proper box
5834 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5835 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5836 c        go to 175
5837 c        endif
5838 c  176   continue
5839 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5840 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5841 C Condition for being inside the proper box
5842 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5843 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5844 c        go to 176
5845 c        endif
5846 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5847       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5848       xj_safe=xj
5849       yj_safe=yj
5850       zj_safe=zj
5851       subchap=0
5852       do xshift=-1,1
5853       do yshift=-1,1
5854       do zshift=-1,1
5855           xj=xj_safe+xshift*boxxsize
5856           yj=yj_safe+yshift*boxysize
5857           zj=zj_safe+zshift*boxzsize
5858           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5859           if(dist_temp.lt.dist_init) then
5860             dist_init=dist_temp
5861             xj_temp=xj
5862             yj_temp=yj
5863             zj_temp=zj
5864             subchap=1
5865           endif
5866        enddo
5867        enddo
5868        enddo
5869        if (subchap.eq.1) then
5870           xj=xj_temp-xi
5871           yj=yj_temp-yi
5872           zj=zj_temp-zi
5873        else
5874           xj=xj_safe-xi
5875           yj=yj_safe-yi
5876           zj=zj_safe-zi
5877        endif
5878 c          print *,xj,yj,zj,'polozenie j'
5879           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5880 c          print *,rrij
5881           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5882 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5883 c          if (sss.eq.0) print *,'czasem jest OK'
5884           if (sss.le.0.0d0) cycle
5885           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5886           fac=rrij**expon2
5887           e1=fac*fac*aad(itypj,iteli)
5888           e2=fac*bad(itypj,iteli)
5889           if (iabs(j-i) .le. 2) then
5890             e1=scal14*e1
5891             e2=scal14*e2
5892             evdw2_14=evdw2_14+(e1+e2)*sss
5893           endif
5894           evdwij=e1+e2
5895           evdw2=evdw2+evdwij*sss
5896           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5897      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5898      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5899      &       bad(itypj,iteli)
5900 C
5901 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5902 C
5903           fac=-(evdwij+e1)*rrij*sss
5904           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5905           ggg(1)=xj*fac
5906           ggg(2)=yj*fac
5907           ggg(3)=zj*fac
5908 cgrad          if (j.lt.i) then
5909 cd          write (iout,*) 'j<i'
5910 C Uncomment following three lines for SC-p interactions
5911 c           do k=1,3
5912 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5913 c           enddo
5914 cgrad          else
5915 cd          write (iout,*) 'j>i'
5916 cgrad            do k=1,3
5917 cgrad              ggg(k)=-ggg(k)
5918 C Uncomment following line for SC-p interactions
5919 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5920 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5921 cgrad            enddo
5922 cgrad          endif
5923 cgrad          do k=1,3
5924 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5925 cgrad          enddo
5926 cgrad          kstart=min0(i+1,j)
5927 cgrad          kend=max0(i-1,j-1)
5928 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5929 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5930 cgrad          do k=kstart,kend
5931 cgrad            do l=1,3
5932 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5933 cgrad            enddo
5934 cgrad          enddo
5935           do k=1,3
5936             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5937             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5938           enddo
5939 c        endif !endif for sscale cutoff
5940         enddo ! j
5941
5942         enddo ! iint
5943       enddo ! i
5944 c      enddo !zshift
5945 c      enddo !yshift
5946 c      enddo !xshift
5947       do i=1,nct
5948         do j=1,3
5949           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5950           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5951           gradx_scp(j,i)=expon*gradx_scp(j,i)
5952         enddo
5953       enddo
5954 C******************************************************************************
5955 C
5956 C                              N O T E !!!
5957 C
5958 C To save time the factor EXPON has been extracted from ALL components
5959 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5960 C use!
5961 C
5962 C******************************************************************************
5963       return
5964       end
5965 C--------------------------------------------------------------------------
5966       subroutine edis(ehpb)
5967 C
5968 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5969 C
5970       implicit real*8 (a-h,o-z)
5971       include 'DIMENSIONS'
5972       include 'COMMON.SBRIDGE'
5973       include 'COMMON.CHAIN'
5974       include 'COMMON.DERIV'
5975       include 'COMMON.VAR'
5976       include 'COMMON.INTERACT'
5977       include 'COMMON.IOUNITS'
5978       include 'COMMON.CONTROL'
5979       dimension ggg(3),ggg_peak(3,1000)
5980       ehpb=0.0D0
5981       do i=1,3
5982        ggg(i)=0.0d0
5983       enddo
5984 c 8/21/18 AL: added explicit restraints on reference coords
5985 c      write (iout,*) "restr_on_coord",restr_on_coord
5986       if (restr_on_coord) then
5987
5988       do i=nnt,nct
5989         ecoor=0.0d0
5990         if (itype(i).eq.ntyp1) cycle
5991         do j=1,3
5992           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5993           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5994         enddo
5995         if (itype(i).ne.10) then
5996           do j=1,3
5997             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5998             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5999           enddo
6000         endif
6001         if (energy_dec) write (iout,*)
6002      &     "i",i," bfac",bfac(i)," ecoor",ecoor
6003         ehpb=ehpb+0.5d0*bfac(i)*ecoor
6004       enddo
6005
6006       endif
6007 C      write (iout,*) ,"link_end",link_end,constr_dist
6008 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6009 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
6010 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
6011 c     &  " link_end_peak",link_end_peak
6012       if (link_end.eq.0.and.link_end_peak.eq.0) return
6013       do i=link_start_peak,link_end_peak
6014         ehpb_peak=0.0d0
6015 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
6016 c     &   ipeak(1,i),ipeak(2,i)
6017         do ip=ipeak(1,i),ipeak(2,i)
6018           ii=ihpb_peak(ip)
6019           jj=jhpb_peak(ip)
6020           dd=dist(ii,jj)
6021           iip=ip-ipeak(1,i)+1
6022 C iii and jjj point to the residues for which the distance is assigned.
6023 c          if (ii.gt.nres) then
6024 c            iii=ii-nres
6025 c            jjj=jj-nres
6026 c          else
6027 c            iii=ii
6028 c            jjj=jj
6029 c          endif
6030           if (ii.gt.nres) then
6031             iii=ii-nres
6032           else
6033             iii=ii
6034           endif
6035           if (jj.gt.nres) then
6036             jjj=jj-nres
6037           else
6038             jjj=jj
6039           endif
6040           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
6041           aux=dexp(-scal_peak*aux)
6042           ehpb_peak=ehpb_peak+aux
6043           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
6044      &      forcon_peak(ip))*aux/dd
6045           do j=1,3
6046             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
6047           enddo
6048           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
6049      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
6050      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
6051         enddo
6052 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
6053         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
6054         do ip=ipeak(1,i),ipeak(2,i)
6055           iip=ip-ipeak(1,i)+1
6056           do j=1,3
6057             ggg(j)=ggg_peak(j,iip)/ehpb_peak
6058           enddo
6059           ii=ihpb_peak(ip)
6060           jj=jhpb_peak(ip)
6061 C iii and jjj point to the residues for which the distance is assigned.
6062 c          if (ii.gt.nres) then
6063 c            iii=ii-nres
6064 c            jjj=jj-nres
6065 c          else
6066 c            iii=ii
6067 c            jjj=jj
6068 c          endif
6069           if (ii.gt.nres) then
6070             iii=ii-nres
6071           else
6072             iii=ii
6073           endif
6074           if (jj.gt.nres) then
6075             jjj=jj-nres
6076           else
6077             jjj=jj
6078           endif
6079           if (iii.lt.ii) then
6080             do j=1,3
6081               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6082             enddo
6083           endif
6084           if (jjj.lt.jj) then
6085             do j=1,3
6086               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6087             enddo
6088           endif
6089           do k=1,3
6090             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6091             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6092           enddo
6093         enddo
6094       enddo
6095       do i=link_start,link_end
6096 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6097 C CA-CA distance used in regularization of structure.
6098         ii=ihpb(i)
6099         jj=jhpb(i)
6100 C iii and jjj point to the residues for which the distance is assigned.
6101         if (ii.gt.nres) then
6102           iii=ii-nres
6103         else
6104           iii=ii
6105         endif
6106         if (jj.gt.nres) then
6107           jjj=jj-nres
6108         else
6109           jjj=jj
6110         endif
6111 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6112 c     &    dhpb(i),dhpb1(i),forcon(i)
6113 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6114 C    distance and angle dependent SS bond potential.
6115 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6116 C     & iabs(itype(jjj)).eq.1) then
6117 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6118 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6119         if (.not.dyn_ss .and. i.le.nss) then
6120 C 15/02/13 CC dynamic SSbond - additional check
6121           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6122      &        iabs(itype(jjj)).eq.1) then
6123            call ssbond_ene(iii,jjj,eij)
6124            ehpb=ehpb+2*eij
6125          endif
6126 cd          write (iout,*) "eij",eij
6127 cd   &   ' waga=',waga,' fac=',fac
6128 !        else if (ii.gt.nres .and. jj.gt.nres) then
6129         else
6130 C Calculate the distance between the two points and its difference from the
6131 C target distance.
6132           dd=dist(ii,jj)
6133           if (irestr_type(i).eq.11) then
6134             ehpb=ehpb+fordepth(i)!**4.0d0
6135      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6136             fac=fordepth(i)!**4.0d0
6137      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6138             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6139      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6140      &        ehpb,irestr_type(i)
6141           else if (irestr_type(i).eq.10) then
6142 c AL 6//19/2018 cross-link restraints
6143             xdis = 0.5d0*(dd/forcon(i))**2
6144             expdis = dexp(-xdis)
6145 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6146             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6147 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6148 c     &          " wboltzd",wboltzd
6149             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6150 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6151             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6152      &           *expdis/(aux*forcon(i)**2)
6153             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6154      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6155      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6156           else if (irestr_type(i).eq.2) then
6157 c Quartic restraints
6158             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6159             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6160      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6161      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6162             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6163           else
6164 c Quadratic restraints
6165             rdis=dd-dhpb(i)
6166 C Get the force constant corresponding to this distance.
6167             waga=forcon(i)
6168 C Calculate the contribution to energy.
6169             ehpb=ehpb+0.5d0*waga*rdis*rdis
6170             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6171      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6172      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6173 C
6174 C Evaluate gradient.
6175 C
6176             fac=waga*rdis/dd
6177           endif
6178 c Calculate Cartesian gradient
6179           do j=1,3
6180             ggg(j)=fac*(c(j,jj)-c(j,ii))
6181           enddo
6182 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6183 C If this is a SC-SC distance, we need to calculate the contributions to the
6184 C Cartesian gradient in the SC vectors (ghpbx).
6185           if (iii.lt.ii) then
6186             do j=1,3
6187               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6188             enddo
6189           endif
6190           if (jjj.lt.jj) then
6191             do j=1,3
6192               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6193             enddo
6194           endif
6195           do k=1,3
6196             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6197             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6198           enddo
6199         endif
6200       enddo
6201       return
6202       end
6203 C--------------------------------------------------------------------------
6204       subroutine ssbond_ene(i,j,eij)
6205 C
6206 C Calculate the distance and angle dependent SS-bond potential energy
6207 C using a free-energy function derived based on RHF/6-31G** ab initio
6208 C calculations of diethyl disulfide.
6209 C
6210 C A. Liwo and U. Kozlowska, 11/24/03
6211 C
6212       implicit real*8 (a-h,o-z)
6213       include 'DIMENSIONS'
6214       include 'COMMON.SBRIDGE'
6215       include 'COMMON.CHAIN'
6216       include 'COMMON.DERIV'
6217       include 'COMMON.LOCAL'
6218       include 'COMMON.INTERACT'
6219       include 'COMMON.VAR'
6220       include 'COMMON.IOUNITS'
6221       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6222       itypi=iabs(itype(i))
6223       xi=c(1,nres+i)
6224       yi=c(2,nres+i)
6225       zi=c(3,nres+i)
6226       dxi=dc_norm(1,nres+i)
6227       dyi=dc_norm(2,nres+i)
6228       dzi=dc_norm(3,nres+i)
6229 c      dsci_inv=dsc_inv(itypi)
6230       dsci_inv=vbld_inv(nres+i)
6231       itypj=iabs(itype(j))
6232 c      dscj_inv=dsc_inv(itypj)
6233       dscj_inv=vbld_inv(nres+j)
6234       xj=c(1,nres+j)-xi
6235       yj=c(2,nres+j)-yi
6236       zj=c(3,nres+j)-zi
6237       dxj=dc_norm(1,nres+j)
6238       dyj=dc_norm(2,nres+j)
6239       dzj=dc_norm(3,nres+j)
6240       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6241       rij=dsqrt(rrij)
6242       erij(1)=xj*rij
6243       erij(2)=yj*rij
6244       erij(3)=zj*rij
6245       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6246       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6247       om12=dxi*dxj+dyi*dyj+dzi*dzj
6248       do k=1,3
6249         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6250         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6251       enddo
6252       rij=1.0d0/rij
6253       deltad=rij-d0cm
6254       deltat1=1.0d0-om1
6255       deltat2=1.0d0+om2
6256       deltat12=om2-om1+2.0d0
6257       cosphi=om12-om1*om2
6258       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6259      &  +akct*deltad*deltat12
6260      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6261 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6262 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6263 c     &  " deltat12",deltat12," eij",eij
6264       ed=2*akcm*deltad+akct*deltat12
6265       pom1=akct*deltad
6266       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6267       eom1=-2*akth*deltat1-pom1-om2*pom2
6268       eom2= 2*akth*deltat2+pom1-om1*pom2
6269       eom12=pom2
6270       do k=1,3
6271         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6272         ghpbx(k,i)=ghpbx(k,i)-ggk
6273      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6274      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6275         ghpbx(k,j)=ghpbx(k,j)+ggk
6276      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6277      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6278         ghpbc(k,i)=ghpbc(k,i)-ggk
6279         ghpbc(k,j)=ghpbc(k,j)+ggk
6280       enddo
6281 C
6282 C Calculate the components of the gradient in DC and X
6283 C
6284 cgrad      do k=i,j-1
6285 cgrad        do l=1,3
6286 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6287 cgrad        enddo
6288 cgrad      enddo
6289       return
6290       end
6291 C--------------------------------------------------------------------------
6292       subroutine ebond(estr)
6293 c
6294 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6295 c
6296       implicit real*8 (a-h,o-z)
6297       include 'DIMENSIONS'
6298       include 'COMMON.LOCAL'
6299       include 'COMMON.GEO'
6300       include 'COMMON.INTERACT'
6301       include 'COMMON.DERIV'
6302       include 'COMMON.VAR'
6303       include 'COMMON.CHAIN'
6304       include 'COMMON.IOUNITS'
6305       include 'COMMON.NAMES'
6306       include 'COMMON.FFIELD'
6307       include 'COMMON.CONTROL'
6308       include 'COMMON.SETUP'
6309       double precision u(3),ud(3)
6310       estr=0.0d0
6311       estr1=0.0d0
6312       do i=ibondp_start,ibondp_end
6313 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6314 c      used
6315 #ifdef FIVEDIAG
6316         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6317         diff = vbld(i)-vbldp0
6318 #else
6319         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6320 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6321 c          do j=1,3
6322 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6323 c     &      *dc(j,i-1)/vbld(i)
6324 c          enddo
6325 c          if (energy_dec) write(iout,*)
6326 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6327 c        else
6328 C       Checking if it involves dummy (NH3+ or COO-) group
6329         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6330 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6331           diff = vbld(i)-vbldpDUM
6332           if (energy_dec) write(iout,*) "dum_bond",i,diff
6333         else
6334 C NO    vbldp0 is the equlibrium length of spring for peptide group
6335           diff = vbld(i)-vbldp0
6336         endif
6337 #endif
6338         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6339      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6340         estr=estr+diff*diff
6341         do j=1,3
6342           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6343         enddo
6344 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6345 c        endif
6346       enddo
6347
6348       estr=0.5d0*AKP*estr+estr1
6349 c
6350 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6351 c
6352       do i=ibond_start,ibond_end
6353         iti=iabs(itype(i))
6354         if (iti.ne.10 .and. iti.ne.ntyp1) then
6355           nbi=nbondterm(iti)
6356           if (nbi.eq.1) then
6357             diff=vbld(i+nres)-vbldsc0(1,iti)
6358             if (energy_dec)  write (iout,*)
6359      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6360      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6361             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6362             do j=1,3
6363               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6364             enddo
6365           else
6366             do j=1,nbi
6367               diff=vbld(i+nres)-vbldsc0(j,iti)
6368               ud(j)=aksc(j,iti)*diff
6369               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6370             enddo
6371             uprod=u(1)
6372             do j=2,nbi
6373               uprod=uprod*u(j)
6374             enddo
6375             usum=0.0d0
6376             usumsqder=0.0d0
6377             do j=1,nbi
6378               uprod1=1.0d0
6379               uprod2=1.0d0
6380               do k=1,nbi
6381                 if (k.ne.j) then
6382                   uprod1=uprod1*u(k)
6383                   uprod2=uprod2*u(k)*u(k)
6384                 endif
6385               enddo
6386               usum=usum+uprod1
6387               usumsqder=usumsqder+ud(j)*uprod2
6388             enddo
6389             estr=estr+uprod/usum
6390             do j=1,3
6391              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6392             enddo
6393           endif
6394         endif
6395       enddo
6396       return
6397       end
6398 #ifdef CRYST_THETA
6399 C--------------------------------------------------------------------------
6400       subroutine ebend(etheta)
6401 C
6402 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6403 C angles gamma and its derivatives in consecutive thetas and gammas.
6404 C
6405       implicit real*8 (a-h,o-z)
6406       include 'DIMENSIONS'
6407       include 'COMMON.LOCAL'
6408       include 'COMMON.GEO'
6409       include 'COMMON.INTERACT'
6410       include 'COMMON.DERIV'
6411       include 'COMMON.VAR'
6412       include 'COMMON.CHAIN'
6413       include 'COMMON.IOUNITS'
6414       include 'COMMON.NAMES'
6415       include 'COMMON.FFIELD'
6416       include 'COMMON.CONTROL'
6417       include 'COMMON.TORCNSTR'
6418       common /calcthet/ term1,term2,termm,diffak,ratak,
6419      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6420      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6421       double precision y(2),z(2)
6422       delta=0.02d0*pi
6423 c      time11=dexp(-2*time)
6424 c      time12=1.0d0
6425       etheta=0.0D0
6426 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6427       do i=ithet_start,ithet_end
6428         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6429      &  .or.itype(i).eq.ntyp1) cycle
6430 C Zero the energy function and its derivative at 0 or pi.
6431         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6432         it=itype(i-1)
6433         ichir1=isign(1,itype(i-2))
6434         ichir2=isign(1,itype(i))
6435          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6436          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6437          if (itype(i-1).eq.10) then
6438           itype1=isign(10,itype(i-2))
6439           ichir11=isign(1,itype(i-2))
6440           ichir12=isign(1,itype(i-2))
6441           itype2=isign(10,itype(i))
6442           ichir21=isign(1,itype(i))
6443           ichir22=isign(1,itype(i))
6444          endif
6445
6446         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6447 #ifdef OSF
6448           phii=phi(i)
6449           if (phii.ne.phii) phii=150.0
6450 #else
6451           phii=phi(i)
6452 #endif
6453           y(1)=dcos(phii)
6454           y(2)=dsin(phii)
6455         else
6456           y(1)=0.0D0
6457           y(2)=0.0D0
6458         endif
6459         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6460 #ifdef OSF
6461           phii1=phi(i+1)
6462           if (phii1.ne.phii1) phii1=150.0
6463           phii1=pinorm(phii1)
6464           z(1)=cos(phii1)
6465 #else
6466           phii1=phi(i+1)
6467 #endif
6468           z(1)=dcos(phii1)
6469           z(2)=dsin(phii1)
6470         else
6471           z(1)=0.0D0
6472           z(2)=0.0D0
6473         endif
6474 C Calculate the "mean" value of theta from the part of the distribution
6475 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6476 C In following comments this theta will be referred to as t_c.
6477         thet_pred_mean=0.0d0
6478         do k=1,2
6479             athetk=athet(k,it,ichir1,ichir2)
6480             bthetk=bthet(k,it,ichir1,ichir2)
6481           if (it.eq.10) then
6482              athetk=athet(k,itype1,ichir11,ichir12)
6483              bthetk=bthet(k,itype2,ichir21,ichir22)
6484           endif
6485          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6486 c         write(iout,*) 'chuj tu', y(k),z(k)
6487         enddo
6488         dthett=thet_pred_mean*ssd
6489         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6490 C Derivatives of the "mean" values in gamma1 and gamma2.
6491         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6492      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6493          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6494      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6495          if (it.eq.10) then
6496       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6497      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6498         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6499      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6500          endif
6501         if (theta(i).gt.pi-delta) then
6502           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6503      &         E_tc0)
6504           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6505           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6506           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6507      &        E_theta)
6508           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6509      &        E_tc)
6510         else if (theta(i).lt.delta) then
6511           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6512           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6513           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6514      &        E_theta)
6515           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6516           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6517      &        E_tc)
6518         else
6519           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6520      &        E_theta,E_tc)
6521         endif
6522         etheta=etheta+ethetai
6523         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6524      &      'ebend',i,ethetai,theta(i),itype(i)
6525         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6526         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6527         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6528       enddo
6529
6530 C Ufff.... We've done all this!!!
6531       return
6532       end
6533 C---------------------------------------------------------------------------
6534       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6535      &     E_tc)
6536       implicit real*8 (a-h,o-z)
6537       include 'DIMENSIONS'
6538       include 'COMMON.LOCAL'
6539       include 'COMMON.IOUNITS'
6540       common /calcthet/ term1,term2,termm,diffak,ratak,
6541      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6542      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6543 C Calculate the contributions to both Gaussian lobes.
6544 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6545 C The "polynomial part" of the "standard deviation" of this part of
6546 C the distributioni.
6547 ccc        write (iout,*) thetai,thet_pred_mean
6548         sig=polthet(3,it)
6549         do j=2,0,-1
6550           sig=sig*thet_pred_mean+polthet(j,it)
6551         enddo
6552 C Derivative of the "interior part" of the "standard deviation of the"
6553 C gamma-dependent Gaussian lobe in t_c.
6554         sigtc=3*polthet(3,it)
6555         do j=2,1,-1
6556           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6557         enddo
6558         sigtc=sig*sigtc
6559 C Set the parameters of both Gaussian lobes of the distribution.
6560 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6561         fac=sig*sig+sigc0(it)
6562         sigcsq=fac+fac
6563         sigc=1.0D0/sigcsq
6564 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6565         sigsqtc=-4.0D0*sigcsq*sigtc
6566 c       print *,i,sig,sigtc,sigsqtc
6567 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6568         sigtc=-sigtc/(fac*fac)
6569 C Following variable is sigma(t_c)**(-2)
6570         sigcsq=sigcsq*sigcsq
6571         sig0i=sig0(it)
6572         sig0inv=1.0D0/sig0i**2
6573         delthec=thetai-thet_pred_mean
6574         delthe0=thetai-theta0i
6575         term1=-0.5D0*sigcsq*delthec*delthec
6576         term2=-0.5D0*sig0inv*delthe0*delthe0
6577 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6578 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6579 C NaNs in taking the logarithm. We extract the largest exponent which is added
6580 C to the energy (this being the log of the distribution) at the end of energy
6581 C term evaluation for this virtual-bond angle.
6582         if (term1.gt.term2) then
6583           termm=term1
6584           term2=dexp(term2-termm)
6585           term1=1.0d0
6586         else
6587           termm=term2
6588           term1=dexp(term1-termm)
6589           term2=1.0d0
6590         endif
6591 C The ratio between the gamma-independent and gamma-dependent lobes of
6592 C the distribution is a Gaussian function of thet_pred_mean too.
6593         diffak=gthet(2,it)-thet_pred_mean
6594         ratak=diffak/gthet(3,it)**2
6595         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6596 C Let's differentiate it in thet_pred_mean NOW.
6597         aktc=ak*ratak
6598 C Now put together the distribution terms to make complete distribution.
6599         termexp=term1+ak*term2
6600         termpre=sigc+ak*sig0i
6601 C Contribution of the bending energy from this theta is just the -log of
6602 C the sum of the contributions from the two lobes and the pre-exponential
6603 C factor. Simple enough, isn't it?
6604         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6605 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6606 C NOW the derivatives!!!
6607 C 6/6/97 Take into account the deformation.
6608         E_theta=(delthec*sigcsq*term1
6609      &       +ak*delthe0*sig0inv*term2)/termexp
6610         E_tc=((sigtc+aktc*sig0i)/termpre
6611      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6612      &       aktc*term2)/termexp)
6613       return
6614       end
6615 c-----------------------------------------------------------------------------
6616       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6617       implicit real*8 (a-h,o-z)
6618       include 'DIMENSIONS'
6619       include 'COMMON.LOCAL'
6620       include 'COMMON.IOUNITS'
6621       common /calcthet/ term1,term2,termm,diffak,ratak,
6622      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6623      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6624       delthec=thetai-thet_pred_mean
6625       delthe0=thetai-theta0i
6626 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6627       t3 = thetai-thet_pred_mean
6628       t6 = t3**2
6629       t9 = term1
6630       t12 = t3*sigcsq
6631       t14 = t12+t6*sigsqtc
6632       t16 = 1.0d0
6633       t21 = thetai-theta0i
6634       t23 = t21**2
6635       t26 = term2
6636       t27 = t21*t26
6637       t32 = termexp
6638       t40 = t32**2
6639       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6640      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6641      & *(-t12*t9-ak*sig0inv*t27)
6642       return
6643       end
6644 #else
6645 C--------------------------------------------------------------------------
6646       subroutine ebend(etheta)
6647 C
6648 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6649 C angles gamma and its derivatives in consecutive thetas and gammas.
6650 C ab initio-derived potentials from
6651 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6652 C
6653       implicit real*8 (a-h,o-z)
6654       include 'DIMENSIONS'
6655       include 'COMMON.LOCAL'
6656       include 'COMMON.GEO'
6657       include 'COMMON.INTERACT'
6658       include 'COMMON.DERIV'
6659       include 'COMMON.VAR'
6660       include 'COMMON.CHAIN'
6661       include 'COMMON.IOUNITS'
6662       include 'COMMON.NAMES'
6663       include 'COMMON.FFIELD'
6664       include 'COMMON.CONTROL'
6665       include 'COMMON.TORCNSTR'
6666       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6667      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6668      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6669      & sinph1ph2(maxdouble,maxdouble)
6670       logical lprn /.false./, lprn1 /.false./
6671       etheta=0.0D0
6672       do i=ithet_start,ithet_end
6673 c        print *,i,itype(i-1),itype(i),itype(i-2)
6674         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6675      &  .or.itype(i).eq.ntyp1) cycle
6676 C        print *,i,theta(i)
6677         if (iabs(itype(i+1)).eq.20) iblock=2
6678         if (iabs(itype(i+1)).ne.20) iblock=1
6679         dethetai=0.0d0
6680         dephii=0.0d0
6681         dephii1=0.0d0
6682         theti2=0.5d0*theta(i)
6683         ityp2=ithetyp((itype(i-1)))
6684         do k=1,nntheterm
6685           coskt(k)=dcos(k*theti2)
6686           sinkt(k)=dsin(k*theti2)
6687         enddo
6688 C        print *,ethetai
6689         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6690 #ifdef OSF
6691           phii=phi(i)
6692           if (phii.ne.phii) phii=150.0
6693 #else
6694           phii=phi(i)
6695 #endif
6696           ityp1=ithetyp((itype(i-2)))
6697 C propagation of chirality for glycine type
6698           do k=1,nsingle
6699             cosph1(k)=dcos(k*phii)
6700             sinph1(k)=dsin(k*phii)
6701           enddo
6702         else
6703           phii=0.0d0
6704           do k=1,nsingle
6705           ityp1=ithetyp((itype(i-2)))
6706             cosph1(k)=0.0d0
6707             sinph1(k)=0.0d0
6708           enddo
6709         endif
6710         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6711 #ifdef OSF
6712           phii1=phi(i+1)
6713           if (phii1.ne.phii1) phii1=150.0
6714           phii1=pinorm(phii1)
6715 #else
6716           phii1=phi(i+1)
6717 #endif
6718           ityp3=ithetyp((itype(i)))
6719           do k=1,nsingle
6720             cosph2(k)=dcos(k*phii1)
6721             sinph2(k)=dsin(k*phii1)
6722           enddo
6723         else
6724           phii1=0.0d0
6725           ityp3=ithetyp((itype(i)))
6726           do k=1,nsingle
6727             cosph2(k)=0.0d0
6728             sinph2(k)=0.0d0
6729           enddo
6730         endif
6731         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6732         do k=1,ndouble
6733           do l=1,k-1
6734             ccl=cosph1(l)*cosph2(k-l)
6735             ssl=sinph1(l)*sinph2(k-l)
6736             scl=sinph1(l)*cosph2(k-l)
6737             csl=cosph1(l)*sinph2(k-l)
6738             cosph1ph2(l,k)=ccl-ssl
6739             cosph1ph2(k,l)=ccl+ssl
6740             sinph1ph2(l,k)=scl+csl
6741             sinph1ph2(k,l)=scl-csl
6742           enddo
6743         enddo
6744         if (lprn) then
6745         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6746      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6747         write (iout,*) "coskt and sinkt"
6748         do k=1,nntheterm
6749           write (iout,*) k,coskt(k),sinkt(k)
6750         enddo
6751         endif
6752         do k=1,ntheterm
6753           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6754           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6755      &      *coskt(k)
6756           if (lprn)
6757      &    write (iout,*) "k",k,"
6758      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6759      &     " ethetai",ethetai
6760         enddo
6761         if (lprn) then
6762         write (iout,*) "cosph and sinph"
6763         do k=1,nsingle
6764           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6765         enddo
6766         write (iout,*) "cosph1ph2 and sinph2ph2"
6767         do k=2,ndouble
6768           do l=1,k-1
6769             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6770      &         sinph1ph2(l,k),sinph1ph2(k,l)
6771           enddo
6772         enddo
6773         write(iout,*) "ethetai",ethetai
6774         endif
6775 C       print *,ethetai
6776         do m=1,ntheterm2
6777           do k=1,nsingle
6778             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6779      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6780      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6781      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6782             ethetai=ethetai+sinkt(m)*aux
6783             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6784             dephii=dephii+k*sinkt(m)*(
6785      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6786      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6787             dephii1=dephii1+k*sinkt(m)*(
6788      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6789      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6790             if (lprn)
6791      &      write (iout,*) "m",m," k",k," bbthet",
6792      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6793      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6794      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6795      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6796 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6797           enddo
6798         enddo
6799 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6800 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6801 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6802 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6803         if (lprn)
6804      &  write(iout,*) "ethetai",ethetai
6805 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6806         do m=1,ntheterm3
6807           do k=2,ndouble
6808             do l=1,k-1
6809               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6810      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6811      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6812      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6813               ethetai=ethetai+sinkt(m)*aux
6814               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6815               dephii=dephii+l*sinkt(m)*(
6816      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6817      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6818      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6819      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6820               dephii1=dephii1+(k-l)*sinkt(m)*(
6821      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6822      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6823      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6824      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6825               if (lprn) then
6826               write (iout,*) "m",m," k",k," l",l," ffthet",
6827      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6828      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6829      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6830      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6831      &            " ethetai",ethetai
6832               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6833      &            cosph1ph2(k,l)*sinkt(m),
6834      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6835               endif
6836             enddo
6837           enddo
6838         enddo
6839 10      continue
6840 c        lprn1=.true.
6841 C        print *,ethetai
6842         if (lprn1)
6843      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6844      &   i,theta(i)*rad2deg,phii*rad2deg,
6845      &   phii1*rad2deg,ethetai
6846 c        lprn1=.false.
6847         etheta=etheta+ethetai
6848         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6849         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6850         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6851       enddo
6852
6853       return
6854       end
6855 #endif
6856 #ifdef CRYST_SC
6857 c-----------------------------------------------------------------------------
6858       subroutine esc(escloc)
6859 C Calculate the local energy of a side chain and its derivatives in the
6860 C corresponding virtual-bond valence angles THETA and the spherical angles
6861 C ALPHA and OMEGA.
6862       implicit real*8 (a-h,o-z)
6863       include 'DIMENSIONS'
6864       include 'COMMON.GEO'
6865       include 'COMMON.LOCAL'
6866       include 'COMMON.VAR'
6867       include 'COMMON.INTERACT'
6868       include 'COMMON.DERIV'
6869       include 'COMMON.CHAIN'
6870       include 'COMMON.IOUNITS'
6871       include 'COMMON.NAMES'
6872       include 'COMMON.FFIELD'
6873       include 'COMMON.CONTROL'
6874       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6875      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6876       common /sccalc/ time11,time12,time112,theti,it,nlobit
6877       delta=0.02d0*pi
6878       escloc=0.0D0
6879 c     write (iout,'(a)') 'ESC'
6880       do i=loc_start,loc_end
6881         it=itype(i)
6882         if (it.eq.ntyp1) cycle
6883         if (it.eq.10) goto 1
6884         nlobit=nlob(iabs(it))
6885 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6886 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6887         theti=theta(i+1)-pipol
6888         x(1)=dtan(theti)
6889         x(2)=alph(i)
6890         x(3)=omeg(i)
6891
6892         if (x(2).gt.pi-delta) then
6893           xtemp(1)=x(1)
6894           xtemp(2)=pi-delta
6895           xtemp(3)=x(3)
6896           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6897           xtemp(2)=pi
6898           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6899           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6900      &        escloci,dersc(2))
6901           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6902      &        ddersc0(1),dersc(1))
6903           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6904      &        ddersc0(3),dersc(3))
6905           xtemp(2)=pi-delta
6906           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6907           xtemp(2)=pi
6908           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6909           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6910      &            dersc0(2),esclocbi,dersc02)
6911           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6912      &            dersc12,dersc01)
6913           call splinthet(x(2),0.5d0*delta,ss,ssd)
6914           dersc0(1)=dersc01
6915           dersc0(2)=dersc02
6916           dersc0(3)=0.0d0
6917           do k=1,3
6918             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6919           enddo
6920           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6921 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6922 c    &             esclocbi,ss,ssd
6923           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6924 c         escloci=esclocbi
6925 c         write (iout,*) escloci
6926         else if (x(2).lt.delta) then
6927           xtemp(1)=x(1)
6928           xtemp(2)=delta
6929           xtemp(3)=x(3)
6930           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6931           xtemp(2)=0.0d0
6932           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6933           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6934      &        escloci,dersc(2))
6935           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6936      &        ddersc0(1),dersc(1))
6937           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6938      &        ddersc0(3),dersc(3))
6939           xtemp(2)=delta
6940           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6941           xtemp(2)=0.0d0
6942           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6943           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6944      &            dersc0(2),esclocbi,dersc02)
6945           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6946      &            dersc12,dersc01)
6947           dersc0(1)=dersc01
6948           dersc0(2)=dersc02
6949           dersc0(3)=0.0d0
6950           call splinthet(x(2),0.5d0*delta,ss,ssd)
6951           do k=1,3
6952             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6953           enddo
6954           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6955 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6956 c    &             esclocbi,ss,ssd
6957           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6958 c         write (iout,*) escloci
6959         else
6960           call enesc(x,escloci,dersc,ddummy,.false.)
6961         endif
6962
6963         escloc=escloc+escloci
6964         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6965      &     'escloc',i,escloci
6966 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6967
6968         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6969      &   wscloc*dersc(1)
6970         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6971         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6972     1   continue
6973       enddo
6974       return
6975       end
6976 C---------------------------------------------------------------------------
6977       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6978       implicit real*8 (a-h,o-z)
6979       include 'DIMENSIONS'
6980       include 'COMMON.GEO'
6981       include 'COMMON.LOCAL'
6982       include 'COMMON.IOUNITS'
6983       common /sccalc/ time11,time12,time112,theti,it,nlobit
6984       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6985       double precision contr(maxlob,-1:1)
6986       logical mixed
6987 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6988         escloc_i=0.0D0
6989         do j=1,3
6990           dersc(j)=0.0D0
6991           if (mixed) ddersc(j)=0.0d0
6992         enddo
6993         x3=x(3)
6994
6995 C Because of periodicity of the dependence of the SC energy in omega we have
6996 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6997 C To avoid underflows, first compute & store the exponents.
6998
6999         do iii=-1,1
7000
7001           x(3)=x3+iii*dwapi
7002
7003           do j=1,nlobit
7004             do k=1,3
7005               z(k)=x(k)-censc(k,j,it)
7006             enddo
7007             do k=1,3
7008               Axk=0.0D0
7009               do l=1,3
7010                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7011               enddo
7012               Ax(k,j,iii)=Axk
7013             enddo
7014             expfac=0.0D0
7015             do k=1,3
7016               expfac=expfac+Ax(k,j,iii)*z(k)
7017             enddo
7018             contr(j,iii)=expfac
7019           enddo ! j
7020
7021         enddo ! iii
7022
7023         x(3)=x3
7024 C As in the case of ebend, we want to avoid underflows in exponentiation and
7025 C subsequent NaNs and INFs in energy calculation.
7026 C Find the largest exponent
7027         emin=contr(1,-1)
7028         do iii=-1,1
7029           do j=1,nlobit
7030             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7031           enddo
7032         enddo
7033         emin=0.5D0*emin
7034 cd      print *,'it=',it,' emin=',emin
7035
7036 C Compute the contribution to SC energy and derivatives
7037         do iii=-1,1
7038
7039           do j=1,nlobit
7040 #ifdef OSF
7041             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7042             if(adexp.ne.adexp) adexp=1.0
7043             expfac=dexp(adexp)
7044 #else
7045             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7046 #endif
7047 cd          print *,'j=',j,' expfac=',expfac
7048             escloc_i=escloc_i+expfac
7049             do k=1,3
7050               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7051             enddo
7052             if (mixed) then
7053               do k=1,3,2
7054                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7055      &            +gaussc(k,2,j,it))*expfac
7056               enddo
7057             endif
7058           enddo
7059
7060         enddo ! iii
7061
7062         dersc(1)=dersc(1)/cos(theti)**2
7063         ddersc(1)=ddersc(1)/cos(theti)**2
7064         ddersc(3)=ddersc(3)
7065
7066         escloci=-(dlog(escloc_i)-emin)
7067         do j=1,3
7068           dersc(j)=dersc(j)/escloc_i
7069         enddo
7070         if (mixed) then
7071           do j=1,3,2
7072             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7073           enddo
7074         endif
7075       return
7076       end
7077 C------------------------------------------------------------------------------
7078       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7079       implicit real*8 (a-h,o-z)
7080       include 'DIMENSIONS'
7081       include 'COMMON.GEO'
7082       include 'COMMON.LOCAL'
7083       include 'COMMON.IOUNITS'
7084       common /sccalc/ time11,time12,time112,theti,it,nlobit
7085       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7086       double precision contr(maxlob)
7087       logical mixed
7088
7089       escloc_i=0.0D0
7090
7091       do j=1,3
7092         dersc(j)=0.0D0
7093       enddo
7094
7095       do j=1,nlobit
7096         do k=1,2
7097           z(k)=x(k)-censc(k,j,it)
7098         enddo
7099         z(3)=dwapi
7100         do k=1,3
7101           Axk=0.0D0
7102           do l=1,3
7103             Axk=Axk+gaussc(l,k,j,it)*z(l)
7104           enddo
7105           Ax(k,j)=Axk
7106         enddo
7107         expfac=0.0D0
7108         do k=1,3
7109           expfac=expfac+Ax(k,j)*z(k)
7110         enddo
7111         contr(j)=expfac
7112       enddo ! j
7113
7114 C As in the case of ebend, we want to avoid underflows in exponentiation and
7115 C subsequent NaNs and INFs in energy calculation.
7116 C Find the largest exponent
7117       emin=contr(1)
7118       do j=1,nlobit
7119         if (emin.gt.contr(j)) emin=contr(j)
7120       enddo
7121       emin=0.5D0*emin
7122
7123 C Compute the contribution to SC energy and derivatives
7124
7125       dersc12=0.0d0
7126       do j=1,nlobit
7127         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7128         escloc_i=escloc_i+expfac
7129         do k=1,2
7130           dersc(k)=dersc(k)+Ax(k,j)*expfac
7131         enddo
7132         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7133      &            +gaussc(1,2,j,it))*expfac
7134         dersc(3)=0.0d0
7135       enddo
7136
7137       dersc(1)=dersc(1)/cos(theti)**2
7138       dersc12=dersc12/cos(theti)**2
7139       escloci=-(dlog(escloc_i)-emin)
7140       do j=1,2
7141         dersc(j)=dersc(j)/escloc_i
7142       enddo
7143       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7144       return
7145       end
7146 #else
7147 c----------------------------------------------------------------------------------
7148       subroutine esc(escloc)
7149 C Calculate the local energy of a side chain and its derivatives in the
7150 C corresponding virtual-bond valence angles THETA and the spherical angles
7151 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7152 C added by Urszula Kozlowska. 07/11/2007
7153 C
7154       implicit real*8 (a-h,o-z)
7155       include 'DIMENSIONS'
7156       include 'COMMON.GEO'
7157       include 'COMMON.LOCAL'
7158       include 'COMMON.VAR'
7159       include 'COMMON.SCROT'
7160       include 'COMMON.INTERACT'
7161       include 'COMMON.DERIV'
7162       include 'COMMON.CHAIN'
7163       include 'COMMON.IOUNITS'
7164       include 'COMMON.NAMES'
7165       include 'COMMON.FFIELD'
7166       include 'COMMON.CONTROL'
7167       include 'COMMON.VECTORS'
7168       double precision x_prime(3),y_prime(3),z_prime(3)
7169      &    , sumene,dsc_i,dp2_i,x(65),
7170      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7171      &    de_dxx,de_dyy,de_dzz,de_dt
7172       double precision s1_t,s1_6_t,s2_t,s2_6_t
7173       double precision
7174      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7175      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7176      & dt_dCi(3),dt_dCi1(3)
7177       common /sccalc/ time11,time12,time112,theti,it,nlobit
7178       delta=0.02d0*pi
7179       escloc=0.0D0
7180       do i=loc_start,loc_end
7181         if (itype(i).eq.ntyp1) cycle
7182         costtab(i+1) =dcos(theta(i+1))
7183         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7184         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7185         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7186         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7187         cosfac=dsqrt(cosfac2)
7188         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7189         sinfac=dsqrt(sinfac2)
7190         it=iabs(itype(i))
7191         if (it.eq.10) goto 1
7192 c
7193 C  Compute the axes of tghe local cartesian coordinates system; store in
7194 c   x_prime, y_prime and z_prime
7195 c
7196         do j=1,3
7197           x_prime(j) = 0.00
7198           y_prime(j) = 0.00
7199           z_prime(j) = 0.00
7200         enddo
7201 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7202 C     &   dc_norm(3,i+nres)
7203         do j = 1,3
7204           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7205           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7206         enddo
7207         do j = 1,3
7208           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7209         enddo
7210 c       write (2,*) "i",i
7211 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7212 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7213 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7214 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7215 c      & " xy",scalar(x_prime(1),y_prime(1)),
7216 c      & " xz",scalar(x_prime(1),z_prime(1)),
7217 c      & " yy",scalar(y_prime(1),y_prime(1)),
7218 c      & " yz",scalar(y_prime(1),z_prime(1)),
7219 c      & " zz",scalar(z_prime(1),z_prime(1))
7220 c
7221 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7222 C to local coordinate system. Store in xx, yy, zz.
7223 c
7224         xx=0.0d0
7225         yy=0.0d0
7226         zz=0.0d0
7227         do j = 1,3
7228           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7229           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7230           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7231         enddo
7232
7233         xxtab(i)=xx
7234         yytab(i)=yy
7235         zztab(i)=zz
7236 C
7237 C Compute the energy of the ith side cbain
7238 C
7239 c        write (2,*) "xx",xx," yy",yy," zz",zz
7240         it=iabs(itype(i))
7241         do j = 1,65
7242           x(j) = sc_parmin(j,it)
7243         enddo
7244 #ifdef CHECK_COORD
7245 Cc diagnostics - remove later
7246         xx1 = dcos(alph(2))
7247         yy1 = dsin(alph(2))*dcos(omeg(2))
7248         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7249         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7250      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7251      &    xx1,yy1,zz1
7252 C,"  --- ", xx_w,yy_w,zz_w
7253 c end diagnostics
7254 #endif
7255         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7256      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7257      &   + x(10)*yy*zz
7258         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7259      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7260      & + x(20)*yy*zz
7261         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7262      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7263      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7264      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7265      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7266      &  +x(40)*xx*yy*zz
7267         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7268      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7269      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7270      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7271      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7272      &  +x(60)*xx*yy*zz
7273         dsc_i   = 0.743d0+x(61)
7274         dp2_i   = 1.9d0+x(62)
7275         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7276      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7277         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7278      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7279         s1=(1+x(63))/(0.1d0 + dscp1)
7280         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7281         s2=(1+x(65))/(0.1d0 + dscp2)
7282         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7283         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7284      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7285 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7286 c     &   sumene4,
7287 c     &   dscp1,dscp2,sumene
7288 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7289         escloc = escloc + sumene
7290         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7291      &   " escloc",sumene,escloc,it,itype(i)
7292 c     & ,zz,xx,yy
7293 c#define DEBUG
7294 #ifdef DEBUG
7295 C
7296 C This section to check the numerical derivatives of the energy of ith side
7297 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7298 C #define DEBUG in the code to turn it on.
7299 C
7300         write (2,*) "sumene               =",sumene
7301         aincr=1.0d-7
7302         xxsave=xx
7303         xx=xx+aincr
7304         write (2,*) xx,yy,zz
7305         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7306         de_dxx_num=(sumenep-sumene)/aincr
7307         xx=xxsave
7308         write (2,*) "xx+ sumene from enesc=",sumenep
7309         yysave=yy
7310         yy=yy+aincr
7311         write (2,*) xx,yy,zz
7312         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7313         de_dyy_num=(sumenep-sumene)/aincr
7314         yy=yysave
7315         write (2,*) "yy+ sumene from enesc=",sumenep
7316         zzsave=zz
7317         zz=zz+aincr
7318         write (2,*) xx,yy,zz
7319         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7320         de_dzz_num=(sumenep-sumene)/aincr
7321         zz=zzsave
7322         write (2,*) "zz+ sumene from enesc=",sumenep
7323         costsave=cost2tab(i+1)
7324         sintsave=sint2tab(i+1)
7325         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7326         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7327         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7328         de_dt_num=(sumenep-sumene)/aincr
7329         write (2,*) " t+ sumene from enesc=",sumenep
7330         cost2tab(i+1)=costsave
7331         sint2tab(i+1)=sintsave
7332 C End of diagnostics section.
7333 #endif
7334 C
7335 C Compute the gradient of esc
7336 C
7337 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7338         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7339         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7340         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7341         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7342         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7343         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7344         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7345         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7346         pom1=(sumene3*sint2tab(i+1)+sumene1)
7347      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7348         pom2=(sumene4*cost2tab(i+1)+sumene2)
7349      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7350         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7351         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7352      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7353      &  +x(40)*yy*zz
7354         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7355         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7356      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7357      &  +x(60)*yy*zz
7358         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7359      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7360      &        +(pom1+pom2)*pom_dx
7361 #ifdef DEBUG
7362         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7363 #endif
7364 C
7365         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7366         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7367      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7368      &  +x(40)*xx*zz
7369         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7370         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7371      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7372      &  +x(59)*zz**2 +x(60)*xx*zz
7373         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7374      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7375      &        +(pom1-pom2)*pom_dy
7376 #ifdef DEBUG
7377         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7378 #endif
7379 C
7380         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7381      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7382      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7383      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7384      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7385      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7386      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7387      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7388 #ifdef DEBUG
7389         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7390 #endif
7391 C
7392         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7393      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7394      &  +pom1*pom_dt1+pom2*pom_dt2
7395 #ifdef DEBUG
7396         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7397 #endif
7398 c#undef DEBUG
7399 c
7400 C
7401        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7402        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7403        cosfac2xx=cosfac2*xx
7404        sinfac2yy=sinfac2*yy
7405        do k = 1,3
7406          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7407      &      vbld_inv(i+1)
7408          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7409      &      vbld_inv(i)
7410          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7411          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7412 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7413 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7414 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7415 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7416          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7417          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7418          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7419          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7420          dZZ_Ci1(k)=0.0d0
7421          dZZ_Ci(k)=0.0d0
7422          do j=1,3
7423            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7424      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7425            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7426      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7427          enddo
7428
7429          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7430          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7431          dZZ_XYZ(k)=vbld_inv(i+nres)*
7432      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7433 c
7434          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7435          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7436        enddo
7437
7438        do k=1,3
7439          dXX_Ctab(k,i)=dXX_Ci(k)
7440          dXX_C1tab(k,i)=dXX_Ci1(k)
7441          dYY_Ctab(k,i)=dYY_Ci(k)
7442          dYY_C1tab(k,i)=dYY_Ci1(k)
7443          dZZ_Ctab(k,i)=dZZ_Ci(k)
7444          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7445          dXX_XYZtab(k,i)=dXX_XYZ(k)
7446          dYY_XYZtab(k,i)=dYY_XYZ(k)
7447          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7448        enddo
7449
7450        do k = 1,3
7451 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7452 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7453 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7454 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7455 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7456 c     &    dt_dci(k)
7457 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7458 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7459          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7460      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7461          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7462      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7463          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7464      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7465        enddo
7466 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7467 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7468
7469 C to check gradient call subroutine check_grad
7470
7471     1 continue
7472       enddo
7473       return
7474       end
7475 c------------------------------------------------------------------------------
7476       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7477       implicit none
7478       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7479      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7480       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7481      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7482      &   + x(10)*yy*zz
7483       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7484      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7485      & + x(20)*yy*zz
7486       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7487      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7488      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7489      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7490      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7491      &  +x(40)*xx*yy*zz
7492       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7493      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7494      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7495      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7496      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7497      &  +x(60)*xx*yy*zz
7498       dsc_i   = 0.743d0+x(61)
7499       dp2_i   = 1.9d0+x(62)
7500       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7501      &          *(xx*cost2+yy*sint2))
7502       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7503      &          *(xx*cost2-yy*sint2))
7504       s1=(1+x(63))/(0.1d0 + dscp1)
7505       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7506       s2=(1+x(65))/(0.1d0 + dscp2)
7507       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7508       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7509      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7510       enesc=sumene
7511       return
7512       end
7513 #endif
7514 c------------------------------------------------------------------------------
7515       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7516 C
7517 C This procedure calculates two-body contact function g(rij) and its derivative:
7518 C
7519 C           eps0ij                                     !       x < -1
7520 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7521 C            0                                         !       x > 1
7522 C
7523 C where x=(rij-r0ij)/delta
7524 C
7525 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7526 C
7527       implicit none
7528       double precision rij,r0ij,eps0ij,fcont,fprimcont
7529       double precision x,x2,x4,delta
7530 c     delta=0.02D0*r0ij
7531 c      delta=0.2D0*r0ij
7532       x=(rij-r0ij)/delta
7533       if (x.lt.-1.0D0) then
7534         fcont=eps0ij
7535         fprimcont=0.0D0
7536       else if (x.le.1.0D0) then
7537         x2=x*x
7538         x4=x2*x2
7539         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7540         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7541       else
7542         fcont=0.0D0
7543         fprimcont=0.0D0
7544       endif
7545       return
7546       end
7547 c------------------------------------------------------------------------------
7548       subroutine splinthet(theti,delta,ss,ssder)
7549       implicit real*8 (a-h,o-z)
7550       include 'DIMENSIONS'
7551       include 'COMMON.VAR'
7552       include 'COMMON.GEO'
7553       thetup=pi-delta
7554       thetlow=delta
7555       if (theti.gt.pipol) then
7556         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7557       else
7558         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7559         ssder=-ssder
7560       endif
7561       return
7562       end
7563 c------------------------------------------------------------------------------
7564       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7565       implicit none
7566       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7567       double precision ksi,ksi2,ksi3,a1,a2,a3
7568       a1=fprim0*delta/(f1-f0)
7569       a2=3.0d0-2.0d0*a1
7570       a3=a1-2.0d0
7571       ksi=(x-x0)/delta
7572       ksi2=ksi*ksi
7573       ksi3=ksi2*ksi
7574       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7575       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7576       return
7577       end
7578 c------------------------------------------------------------------------------
7579       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7580       implicit none
7581       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7582       double precision ksi,ksi2,ksi3,a1,a2,a3
7583       ksi=(x-x0)/delta
7584       ksi2=ksi*ksi
7585       ksi3=ksi2*ksi
7586       a1=fprim0x*delta
7587       a2=3*(f1x-f0x)-2*fprim0x*delta
7588       a3=fprim0x*delta-2*(f1x-f0x)
7589       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7590       return
7591       end
7592 C-----------------------------------------------------------------------------
7593 #ifdef CRYST_TOR
7594 C-----------------------------------------------------------------------------
7595       subroutine etor(etors)
7596       implicit real*8 (a-h,o-z)
7597       include 'DIMENSIONS'
7598       include 'COMMON.VAR'
7599       include 'COMMON.GEO'
7600       include 'COMMON.LOCAL'
7601       include 'COMMON.TORSION'
7602       include 'COMMON.INTERACT'
7603       include 'COMMON.DERIV'
7604       include 'COMMON.CHAIN'
7605       include 'COMMON.NAMES'
7606       include 'COMMON.IOUNITS'
7607       include 'COMMON.FFIELD'
7608       include 'COMMON.TORCNSTR'
7609       include 'COMMON.CONTROL'
7610       logical lprn
7611 C Set lprn=.true. for debugging
7612       lprn=.false.
7613 c      lprn=.true.
7614       etors=0.0D0
7615       do i=iphi_start,iphi_end
7616       etors_ii=0.0D0
7617         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7618      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7619         itori=itortyp(itype(i-2))
7620         itori1=itortyp(itype(i-1))
7621         phii=phi(i)
7622         gloci=0.0D0
7623 C Proline-Proline pair is a special case...
7624         if (itori.eq.3 .and. itori1.eq.3) then
7625           if (phii.gt.-dwapi3) then
7626             cosphi=dcos(3*phii)
7627             fac=1.0D0/(1.0D0-cosphi)
7628             etorsi=v1(1,3,3)*fac
7629             etorsi=etorsi+etorsi
7630             etors=etors+etorsi-v1(1,3,3)
7631             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7632             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7633           endif
7634           do j=1,3
7635             v1ij=v1(j+1,itori,itori1)
7636             v2ij=v2(j+1,itori,itori1)
7637             cosphi=dcos(j*phii)
7638             sinphi=dsin(j*phii)
7639             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7640             if (energy_dec) etors_ii=etors_ii+
7641      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7642             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7643           enddo
7644         else
7645           do j=1,nterm_old
7646             v1ij=v1(j,itori,itori1)
7647             v2ij=v2(j,itori,itori1)
7648             cosphi=dcos(j*phii)
7649             sinphi=dsin(j*phii)
7650             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7651             if (energy_dec) etors_ii=etors_ii+
7652      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7653             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7654           enddo
7655         endif
7656         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7657              'etor',i,etors_ii
7658         if (lprn)
7659      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7660      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7661      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7662         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7663 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7664       enddo
7665       return
7666       end
7667 c------------------------------------------------------------------------------
7668       subroutine etor_d(etors_d)
7669       etors_d=0.0d0
7670       return
7671       end
7672 c----------------------------------------------------------------------------
7673 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7674       subroutine e_modeller(ehomology_constr)
7675       ehomology_constr=0.0d0
7676       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7677       return
7678       end
7679 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7680
7681 c------------------------------------------------------------------------------
7682       subroutine etor_d(etors_d)
7683       etors_d=0.0d0
7684       return
7685       end
7686 c----------------------------------------------------------------------------
7687 #else
7688       subroutine etor(etors)
7689       implicit real*8 (a-h,o-z)
7690       include 'DIMENSIONS'
7691       include 'COMMON.VAR'
7692       include 'COMMON.GEO'
7693       include 'COMMON.LOCAL'
7694       include 'COMMON.TORSION'
7695       include 'COMMON.INTERACT'
7696       include 'COMMON.DERIV'
7697       include 'COMMON.CHAIN'
7698       include 'COMMON.NAMES'
7699       include 'COMMON.IOUNITS'
7700       include 'COMMON.FFIELD'
7701       include 'COMMON.TORCNSTR'
7702       include 'COMMON.CONTROL'
7703       logical lprn
7704 C Set lprn=.true. for debugging
7705       lprn=.false.
7706 c     lprn=.true.
7707       etors=0.0D0
7708       do i=iphi_start,iphi_end
7709 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7710 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7711 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7712 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7713         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7714      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7715 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7716 C For introducing the NH3+ and COO- group please check the etor_d for reference
7717 C and guidance
7718         etors_ii=0.0D0
7719          if (iabs(itype(i)).eq.20) then
7720          iblock=2
7721          else
7722          iblock=1
7723          endif
7724         itori=itortyp(itype(i-2))
7725         itori1=itortyp(itype(i-1))
7726         phii=phi(i)
7727         gloci=0.0D0
7728 C Regular cosine and sine terms
7729         do j=1,nterm(itori,itori1,iblock)
7730           v1ij=v1(j,itori,itori1,iblock)
7731           v2ij=v2(j,itori,itori1,iblock)
7732           cosphi=dcos(j*phii)
7733           sinphi=dsin(j*phii)
7734           etors=etors+v1ij*cosphi+v2ij*sinphi
7735           if (energy_dec) etors_ii=etors_ii+
7736      &                v1ij*cosphi+v2ij*sinphi
7737           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7738         enddo
7739 C Lorentz terms
7740 C                         v1
7741 C  E = SUM ----------------------------------- - v1
7742 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7743 C
7744         cosphi=dcos(0.5d0*phii)
7745         sinphi=dsin(0.5d0*phii)
7746         do j=1,nlor(itori,itori1,iblock)
7747           vl1ij=vlor1(j,itori,itori1)
7748           vl2ij=vlor2(j,itori,itori1)
7749           vl3ij=vlor3(j,itori,itori1)
7750           pom=vl2ij*cosphi+vl3ij*sinphi
7751           pom1=1.0d0/(pom*pom+1.0d0)
7752           etors=etors+vl1ij*pom1
7753           if (energy_dec) etors_ii=etors_ii+
7754      &                vl1ij*pom1
7755           pom=-pom*pom1*pom1
7756           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7757         enddo
7758 C Subtract the constant term
7759         etors=etors-v0(itori,itori1,iblock)
7760           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7761      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7762         if (lprn)
7763      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7764      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7765      &  (v1(j,itori,itori1,iblock),j=1,6),
7766      &  (v2(j,itori,itori1,iblock),j=1,6)
7767         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7768 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7769       enddo
7770       return
7771       end
7772 c----------------------------------------------------------------------------
7773       subroutine etor_d(etors_d)
7774 C 6/23/01 Compute double torsional energy
7775       implicit real*8 (a-h,o-z)
7776       include 'DIMENSIONS'
7777       include 'COMMON.VAR'
7778       include 'COMMON.GEO'
7779       include 'COMMON.LOCAL'
7780       include 'COMMON.TORSION'
7781       include 'COMMON.INTERACT'
7782       include 'COMMON.DERIV'
7783       include 'COMMON.CHAIN'
7784       include 'COMMON.NAMES'
7785       include 'COMMON.IOUNITS'
7786       include 'COMMON.FFIELD'
7787       include 'COMMON.TORCNSTR'
7788       logical lprn
7789 C Set lprn=.true. for debugging
7790       lprn=.false.
7791 c     lprn=.true.
7792       etors_d=0.0D0
7793 c      write(iout,*) "a tu??"
7794       do i=iphid_start,iphid_end
7795 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7796 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7797 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7798 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7799 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7800          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7801      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7802      &  (itype(i+1).eq.ntyp1)) cycle
7803 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7804         itori=itortyp(itype(i-2))
7805         itori1=itortyp(itype(i-1))
7806         itori2=itortyp(itype(i))
7807         phii=phi(i)
7808         phii1=phi(i+1)
7809         gloci1=0.0D0
7810         gloci2=0.0D0
7811         iblock=1
7812         if (iabs(itype(i+1)).eq.20) iblock=2
7813 C Iblock=2 Proline type
7814 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7815 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7816 C        if (itype(i+1).eq.ntyp1) iblock=3
7817 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7818 C IS or IS NOT need for this
7819 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7820 C        is (itype(i-3).eq.ntyp1) ntblock=2
7821 C        ntblock is N-terminal blocking group
7822
7823 C Regular cosine and sine terms
7824         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7825 C Example of changes for NH3+ blocking group
7826 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7827 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7828           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7829           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7830           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7831           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7832           cosphi1=dcos(j*phii)
7833           sinphi1=dsin(j*phii)
7834           cosphi2=dcos(j*phii1)
7835           sinphi2=dsin(j*phii1)
7836           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7837      &     v2cij*cosphi2+v2sij*sinphi2
7838           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7839           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7840         enddo
7841         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7842           do l=1,k-1
7843             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7844             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7845             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7846             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7847             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7848             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7849             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7850             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7851             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7852      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7853             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7854      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7855             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7856      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7857           enddo
7858         enddo
7859         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7860         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7861       enddo
7862       return
7863       end
7864 #endif
7865 C----------------------------------------------------------------------------------
7866 C The rigorous attempt to derive energy function
7867       subroutine etor_kcc(etors)
7868       implicit real*8 (a-h,o-z)
7869       include 'DIMENSIONS'
7870       include 'COMMON.VAR'
7871       include 'COMMON.GEO'
7872       include 'COMMON.LOCAL'
7873       include 'COMMON.TORSION'
7874       include 'COMMON.INTERACT'
7875       include 'COMMON.DERIV'
7876       include 'COMMON.CHAIN'
7877       include 'COMMON.NAMES'
7878       include 'COMMON.IOUNITS'
7879       include 'COMMON.FFIELD'
7880       include 'COMMON.TORCNSTR'
7881       include 'COMMON.CONTROL'
7882       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7883       logical lprn
7884 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7885 C Set lprn=.true. for debugging
7886       lprn=energy_dec
7887 c     lprn=.true.
7888 C      print *,"wchodze kcc"
7889       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7890       etors=0.0D0
7891       do i=iphi_start,iphi_end
7892 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7893 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7894 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7895 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7896         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7897      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7898         itori=itortyp(itype(i-2))
7899         itori1=itortyp(itype(i-1))
7900         phii=phi(i)
7901         glocig=0.0D0
7902         glocit1=0.0d0
7903         glocit2=0.0d0
7904 C to avoid multiple devision by 2
7905 c        theti22=0.5d0*theta(i)
7906 C theta 12 is the theta_1 /2
7907 C theta 22 is theta_2 /2
7908 c        theti12=0.5d0*theta(i-1)
7909 C and appropriate sinus function
7910         sinthet1=dsin(theta(i-1))
7911         sinthet2=dsin(theta(i))
7912         costhet1=dcos(theta(i-1))
7913         costhet2=dcos(theta(i))
7914 C to speed up lets store its mutliplication
7915         sint1t2=sinthet2*sinthet1
7916         sint1t2n=1.0d0
7917 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7918 C +d_n*sin(n*gamma)) *
7919 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7920 C we have two sum 1) Non-Chebyshev which is with n and gamma
7921         nval=nterm_kcc_Tb(itori,itori1)
7922         c1(0)=0.0d0
7923         c2(0)=0.0d0
7924         c1(1)=1.0d0
7925         c2(1)=1.0d0
7926         do j=2,nval
7927           c1(j)=c1(j-1)*costhet1
7928           c2(j)=c2(j-1)*costhet2
7929         enddo
7930         etori=0.0d0
7931         do j=1,nterm_kcc(itori,itori1)
7932           cosphi=dcos(j*phii)
7933           sinphi=dsin(j*phii)
7934           sint1t2n1=sint1t2n
7935           sint1t2n=sint1t2n*sint1t2
7936           sumvalc=0.0d0
7937           gradvalct1=0.0d0
7938           gradvalct2=0.0d0
7939           do k=1,nval
7940             do l=1,nval
7941               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7942               gradvalct1=gradvalct1+
7943      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7944               gradvalct2=gradvalct2+
7945      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7946             enddo
7947           enddo
7948           gradvalct1=-gradvalct1*sinthet1
7949           gradvalct2=-gradvalct2*sinthet2
7950           sumvals=0.0d0
7951           gradvalst1=0.0d0
7952           gradvalst2=0.0d0
7953           do k=1,nval
7954             do l=1,nval
7955               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7956               gradvalst1=gradvalst1+
7957      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7958               gradvalst2=gradvalst2+
7959      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7960             enddo
7961           enddo
7962           gradvalst1=-gradvalst1*sinthet1
7963           gradvalst2=-gradvalst2*sinthet2
7964           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7965           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7966 C glocig is the gradient local i site in gamma
7967           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7968 C now gradient over theta_1
7969           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7970      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7971           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7972      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7973         enddo ! j
7974         etors=etors+etori
7975 C derivative over gamma
7976         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7977 C derivative over theta1
7978         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7979 C now derivative over theta2
7980         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7981         if (lprn) then
7982           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7983      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7984           write (iout,*) "c1",(c1(k),k=0,nval),
7985      &    " c2",(c2(k),k=0,nval)
7986         endif
7987       enddo
7988       return
7989       end
7990 c---------------------------------------------------------------------------------------------
7991       subroutine etor_constr(edihcnstr)
7992       implicit real*8 (a-h,o-z)
7993       include 'DIMENSIONS'
7994       include 'COMMON.VAR'
7995       include 'COMMON.GEO'
7996       include 'COMMON.LOCAL'
7997       include 'COMMON.TORSION'
7998       include 'COMMON.INTERACT'
7999       include 'COMMON.DERIV'
8000       include 'COMMON.CHAIN'
8001       include 'COMMON.NAMES'
8002       include 'COMMON.IOUNITS'
8003       include 'COMMON.FFIELD'
8004       include 'COMMON.TORCNSTR'
8005       include 'COMMON.BOUNDS'
8006       include 'COMMON.CONTROL'
8007 ! 6/20/98 - dihedral angle constraints
8008       edihcnstr=0.0d0
8009 c      do i=1,ndih_constr
8010       if (raw_psipred) then
8011         do i=idihconstr_start,idihconstr_end
8012           itori=idih_constr(i)
8013           phii=phi(itori)
8014           gaudih_i=vpsipred(1,i)
8015           gauder_i=0.0d0
8016           do j=1,2
8017             s = sdihed(j,i)
8018             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
8019             dexpcos_i=dexp(-cos_i*cos_i)
8020             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
8021             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
8022      &            *cos_i*dexpcos_i/s**2
8023           enddo
8024           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
8025           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
8026           if (energy_dec)
8027      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
8028      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
8029      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
8030      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
8031      &     -wdihc*dlog(gaudih_i)
8032         enddo
8033       else
8034
8035       do i=idihconstr_start,idihconstr_end
8036         itori=idih_constr(i)
8037         phii=phi(itori)
8038         difi=pinorm(phii-phi0(i))
8039         if (difi.gt.drange(i)) then
8040           difi=difi-drange(i)
8041           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8042           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8043         else if (difi.lt.-drange(i)) then
8044           difi=difi+drange(i)
8045           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8046           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8047         else
8048           difi=0.0
8049         endif
8050       enddo
8051
8052       endif
8053
8054       return
8055       end
8056 c----------------------------------------------------------------------------
8057 c MODELLER restraint function
8058       subroutine e_modeller(ehomology_constr)
8059       implicit none
8060       include 'DIMENSIONS'
8061
8062       double precision ehomology_constr
8063       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8064       integer katy, odleglosci, test7
8065       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8066       real*8 Eval,Erot
8067       real*8 distance(max_template),distancek(max_template),
8068      &    min_odl,godl(max_template),dih_diff(max_template)
8069
8070 c
8071 c     FP - 30/10/2014 Temporary specifications for homology restraints
8072 c
8073       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8074      &                 sgtheta
8075       double precision, dimension (maxres) :: guscdiff,usc_diff
8076       double precision, dimension (max_template) ::
8077      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8078      &           theta_diff
8079       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8080      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8081      & betai,sum_sgodl,dij
8082       double precision dist,pinorm
8083 c
8084       include 'COMMON.SBRIDGE'
8085       include 'COMMON.CHAIN'
8086       include 'COMMON.GEO'
8087       include 'COMMON.DERIV'
8088       include 'COMMON.LOCAL'
8089       include 'COMMON.INTERACT'
8090       include 'COMMON.VAR'
8091       include 'COMMON.IOUNITS'
8092 c      include 'COMMON.MD'
8093       include 'COMMON.CONTROL'
8094       include 'COMMON.HOMOLOGY'
8095       include 'COMMON.QRESTR'
8096 c
8097 c     From subroutine Econstr_back
8098 c
8099       include 'COMMON.NAMES'
8100       include 'COMMON.TIME1'
8101 c
8102
8103
8104       do i=1,max_template
8105         distancek(i)=9999999.9
8106       enddo
8107
8108
8109       odleg=0.0d0
8110
8111 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8112 c function)
8113 C AL 5/2/14 - Introduce list of restraints
8114 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8115 #ifdef DEBUG
8116       write(iout,*) "------- dist restrs start -------"
8117 #endif
8118       do ii = link_start_homo,link_end_homo
8119          i = ires_homo(ii)
8120          j = jres_homo(ii)
8121          dij=dist(i,j)
8122 c        write (iout,*) "dij(",i,j,") =",dij
8123          nexl=0
8124          do k=1,constr_homology
8125 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8126            if(.not.l_homo(k,ii)) then
8127              nexl=nexl+1
8128              cycle
8129            endif
8130            distance(k)=odl(k,ii)-dij
8131 c          write (iout,*) "distance(",k,") =",distance(k)
8132 c
8133 c          For Gaussian-type Urestr
8134 c
8135            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8136 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8137 c          write (iout,*) "distancek(",k,") =",distancek(k)
8138 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8139 c
8140 c          For Lorentzian-type Urestr
8141 c
8142            if (waga_dist.lt.0.0d0) then
8143               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8144               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8145      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8146            endif
8147          enddo
8148
8149 c         min_odl=minval(distancek)
8150          do kk=1,constr_homology
8151           if(l_homo(kk,ii)) then
8152             min_odl=distancek(kk)
8153             exit
8154           endif
8155          enddo
8156          do kk=1,constr_homology
8157           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8158      &              min_odl=distancek(kk)
8159          enddo
8160
8161 c        write (iout,* )"min_odl",min_odl
8162 #ifdef DEBUG
8163          write (iout,*) "ij dij",i,j,dij
8164          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8165          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8166          write (iout,* )"min_odl",min_odl
8167 #endif
8168 #ifdef OLDRESTR
8169          odleg2=0.0d0
8170 #else
8171          if (waga_dist.ge.0.0d0) then
8172            odleg2=nexl
8173          else
8174            odleg2=0.0d0
8175          endif
8176 #endif
8177          do k=1,constr_homology
8178 c Nie wiem po co to liczycie jeszcze raz!
8179 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8180 c     &              (2*(sigma_odl(i,j,k))**2))
8181            if(.not.l_homo(k,ii)) cycle
8182            if (waga_dist.ge.0.0d0) then
8183 c
8184 c          For Gaussian-type Urestr
8185 c
8186             godl(k)=dexp(-distancek(k)+min_odl)
8187             odleg2=odleg2+godl(k)
8188 c
8189 c          For Lorentzian-type Urestr
8190 c
8191            else
8192             odleg2=odleg2+distancek(k)
8193            endif
8194
8195 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8196 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8197 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8198 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8199
8200          enddo
8201 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8202 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8203 #ifdef DEBUG
8204          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8205          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8206 #endif
8207            if (waga_dist.ge.0.0d0) then
8208 c
8209 c          For Gaussian-type Urestr
8210 c
8211               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8212 c
8213 c          For Lorentzian-type Urestr
8214 c
8215            else
8216               odleg=odleg+odleg2/constr_homology
8217            endif
8218 c
8219 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8220 c Gradient
8221 c
8222 c          For Gaussian-type Urestr
8223 c
8224          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8225          sum_sgodl=0.0d0
8226          do k=1,constr_homology
8227 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8228 c     &           *waga_dist)+min_odl
8229 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8230 c
8231          if(.not.l_homo(k,ii)) cycle
8232          if (waga_dist.ge.0.0d0) then
8233 c          For Gaussian-type Urestr
8234 c
8235            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8236 c
8237 c          For Lorentzian-type Urestr
8238 c
8239          else
8240            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8241      &           sigma_odlir(k,ii)**2)**2)
8242          endif
8243            sum_sgodl=sum_sgodl+sgodl
8244
8245 c            sgodl2=sgodl2+sgodl
8246 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8247 c      write(iout,*) "constr_homology=",constr_homology
8248 c      write(iout,*) i, j, k, "TEST K"
8249          enddo
8250          if (waga_dist.ge.0.0d0) then
8251 c
8252 c          For Gaussian-type Urestr
8253 c
8254             grad_odl3=waga_homology(iset)*waga_dist
8255      &                *sum_sgodl/(sum_godl*dij)
8256 c
8257 c          For Lorentzian-type Urestr
8258 c
8259          else
8260 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8261 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8262             grad_odl3=-waga_homology(iset)*waga_dist*
8263      &                sum_sgodl/(constr_homology*dij)
8264          endif
8265 c
8266 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8267
8268
8269 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8270 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8271 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8272
8273 ccc      write(iout,*) godl, sgodl, grad_odl3
8274
8275 c          grad_odl=grad_odl+grad_odl3
8276
8277          do jik=1,3
8278             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8279 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8280 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8281 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8282             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8283             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8284 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8285 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8286 c         if (i.eq.25.and.j.eq.27) then
8287 c         write(iout,*) "jik",jik,"i",i,"j",j
8288 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8289 c         write(iout,*) "grad_odl3",grad_odl3
8290 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8291 c         write(iout,*) "ggodl",ggodl
8292 c         write(iout,*) "ghpbc(",jik,i,")",
8293 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8294 c     &                 ghpbc(jik,j)
8295 c         endif
8296          enddo
8297 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8298 ccc     & dLOG(odleg2),"-odleg=", -odleg
8299
8300       enddo ! ii-loop for dist
8301 #ifdef DEBUG
8302       write(iout,*) "------- dist restrs end -------"
8303 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8304 c    &     waga_d.eq.1.0d0) call sum_gradient
8305 #endif
8306 c Pseudo-energy and gradient from dihedral-angle restraints from
8307 c homology templates
8308 c      write (iout,*) "End of distance loop"
8309 c      call flush(iout)
8310       kat=0.0d0
8311 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8312 #ifdef DEBUG
8313       write(iout,*) "------- dih restrs start -------"
8314       do i=idihconstr_start_homo,idihconstr_end_homo
8315         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8316       enddo
8317 #endif
8318       do i=idihconstr_start_homo,idihconstr_end_homo
8319         kat2=0.0d0
8320 c        betai=beta(i,i+1,i+2,i+3)
8321         betai = phi(i)
8322 c       write (iout,*) "betai =",betai
8323         do k=1,constr_homology
8324           dih_diff(k)=pinorm(dih(k,i)-betai)
8325 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8326 cd     &                  ,sigma_dih(k,i)
8327 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8328 c     &                                   -(6.28318-dih_diff(i,k))
8329 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8330 c     &                                   6.28318+dih_diff(i,k)
8331 #ifdef OLD_DIHED
8332           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8333 #else
8334           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8335 #endif
8336 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8337           gdih(k)=dexp(kat3)
8338           kat2=kat2+gdih(k)
8339 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8340 c          write(*,*)""
8341         enddo
8342 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8343 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8344 #ifdef DEBUG
8345         write (iout,*) "i",i," betai",betai," kat2",kat2
8346         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8347 #endif
8348         if (kat2.le.1.0d-14) cycle
8349         kat=kat-dLOG(kat2/constr_homology)
8350 c       write (iout,*) "kat",kat ! sum of -ln-s
8351
8352 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8353 ccc     & dLOG(kat2), "-kat=", -kat
8354
8355 c ----------------------------------------------------------------------
8356 c Gradient
8357 c ----------------------------------------------------------------------
8358
8359         sum_gdih=kat2
8360         sum_sgdih=0.0d0
8361         do k=1,constr_homology
8362 #ifdef OLD_DIHED
8363           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8364 #else
8365           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8366 #endif
8367 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8368           sum_sgdih=sum_sgdih+sgdih
8369         enddo
8370 c       grad_dih3=sum_sgdih/sum_gdih
8371         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8372
8373 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8374 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8375 ccc     & gloc(nphi+i-3,icg)
8376         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8377 c        if (i.eq.25) then
8378 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8379 c        endif
8380 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8381 ccc     & gloc(nphi+i-3,icg)
8382
8383       enddo ! i-loop for dih
8384 #ifdef DEBUG
8385       write(iout,*) "------- dih restrs end -------"
8386 #endif
8387
8388 c Pseudo-energy and gradient for theta angle restraints from
8389 c homology templates
8390 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8391 c adapted
8392
8393 c
8394 c     For constr_homology reference structures (FP)
8395 c
8396 c     Uconst_back_tot=0.0d0
8397       Eval=0.0d0
8398       Erot=0.0d0
8399 c     Econstr_back legacy
8400       do i=1,nres
8401 c     do i=ithet_start,ithet_end
8402        dutheta(i)=0.0d0
8403 c     enddo
8404 c     do i=loc_start,loc_end
8405         do j=1,3
8406           duscdiff(j,i)=0.0d0
8407           duscdiffx(j,i)=0.0d0
8408         enddo
8409       enddo
8410 c
8411 c     do iref=1,nref
8412 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8413 c     write (iout,*) "waga_theta",waga_theta
8414       if (waga_theta.gt.0.0d0) then
8415 #ifdef DEBUG
8416       write (iout,*) "usampl",usampl
8417       write(iout,*) "------- theta restrs start -------"
8418 c     do i=ithet_start,ithet_end
8419 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8420 c     enddo
8421 #endif
8422 c     write (iout,*) "maxres",maxres,"nres",nres
8423
8424       do i=ithet_start,ithet_end
8425 c
8426 c     do i=1,nfrag_back
8427 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8428 c
8429 c Deviation of theta angles wrt constr_homology ref structures
8430 c
8431         utheta_i=0.0d0 ! argument of Gaussian for single k
8432         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8433 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8434 c       over residues in a fragment
8435 c       write (iout,*) "theta(",i,")=",theta(i)
8436         do k=1,constr_homology
8437 c
8438 c         dtheta_i=theta(j)-thetaref(j,iref)
8439 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8440           theta_diff(k)=thetatpl(k,i)-theta(i)
8441 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8442 cd     &                  ,sigma_theta(k,i)
8443
8444 c
8445           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8446 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8447           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8448           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8449 c         Gradient for single Gaussian restraint in subr Econstr_back
8450 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8451 c
8452         enddo
8453 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8454 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8455
8456 c
8457 c         Gradient for multiple Gaussian restraint
8458         sum_gtheta=gutheta_i
8459         sum_sgtheta=0.0d0
8460         do k=1,constr_homology
8461 c        New generalized expr for multiple Gaussian from Econstr_back
8462          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8463 c
8464 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8465           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8466         enddo
8467 c       Final value of gradient using same var as in Econstr_back
8468         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8469      &      +sum_sgtheta/sum_gtheta*waga_theta
8470      &               *waga_homology(iset)
8471 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8472 c     &               *waga_homology(iset)
8473 c       dutheta(i)=sum_sgtheta/sum_gtheta
8474 c
8475 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8476         Eval=Eval-dLOG(gutheta_i/constr_homology)
8477 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8478 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8479 c       Uconst_back=Uconst_back+utheta(i)
8480       enddo ! (i-loop for theta)
8481 #ifdef DEBUG
8482       write(iout,*) "------- theta restrs end -------"
8483 #endif
8484       endif
8485 c
8486 c Deviation of local SC geometry
8487 c
8488 c Separation of two i-loops (instructed by AL - 11/3/2014)
8489 c
8490 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8491 c     write (iout,*) "waga_d",waga_d
8492
8493 #ifdef DEBUG
8494       write(iout,*) "------- SC restrs start -------"
8495       write (iout,*) "Initial duscdiff,duscdiffx"
8496       do i=loc_start,loc_end
8497         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8498      &                 (duscdiffx(jik,i),jik=1,3)
8499       enddo
8500 #endif
8501       do i=loc_start,loc_end
8502         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8503         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8504 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8505 c       write(iout,*) "xxtab, yytab, zztab"
8506 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8507         do k=1,constr_homology
8508 c
8509           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8510 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8511           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8512           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8513 c         write(iout,*) "dxx, dyy, dzz"
8514 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8515 c
8516           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8517 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8518 c         uscdiffk(k)=usc_diff(i)
8519           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8520 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8521 c     &       " guscdiff2",guscdiff2(k)
8522           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8523 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8524 c     &      xxref(j),yyref(j),zzref(j)
8525         enddo
8526 c
8527 c       Gradient
8528 c
8529 c       Generalized expression for multiple Gaussian acc to that for a single
8530 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8531 c
8532 c       Original implementation
8533 c       sum_guscdiff=guscdiff(i)
8534 c
8535 c       sum_sguscdiff=0.0d0
8536 c       do k=1,constr_homology
8537 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8538 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8539 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8540 c       enddo
8541 c
8542 c       Implementation of new expressions for gradient (Jan. 2015)
8543 c
8544 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8545         do k=1,constr_homology
8546 c
8547 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8548 c       before. Now the drivatives should be correct
8549 c
8550           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8551 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8552           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8553           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8554 c
8555 c         New implementation
8556 c
8557           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8558      &                 sigma_d(k,i) ! for the grad wrt r'
8559 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8560 c
8561 c
8562 c        New implementation
8563          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8564          do jik=1,3
8565             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8566      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8567      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8568             duscdiff(jik,i)=duscdiff(jik,i)+
8569      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8570      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8571             duscdiffx(jik,i)=duscdiffx(jik,i)+
8572      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8573      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8574 c
8575 #ifdef DEBUG
8576              write(iout,*) "jik",jik,"i",i
8577              write(iout,*) "dxx, dyy, dzz"
8578              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8579              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8580 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8581 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8582 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8583 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8584 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8585 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8586 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8587 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8588 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8589 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8590 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8591 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8592 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8593 c            endif
8594 #endif
8595          enddo
8596         enddo
8597 c
8598 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8599 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8600 c
8601 c        write (iout,*) i," uscdiff",uscdiff(i)
8602 c
8603 c Put together deviations from local geometry
8604
8605 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8606 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8607         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8608 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8609 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8610 c       Uconst_back=Uconst_back+usc_diff(i)
8611 c
8612 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8613 c
8614 c     New implment: multiplied by sum_sguscdiff
8615 c
8616
8617       enddo ! (i-loop for dscdiff)
8618
8619 c      endif
8620
8621 #ifdef DEBUG
8622       write(iout,*) "------- SC restrs end -------"
8623         write (iout,*) "------ After SC loop in e_modeller ------"
8624         do i=loc_start,loc_end
8625          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8626          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8627         enddo
8628       if (waga_theta.eq.1.0d0) then
8629       write (iout,*) "in e_modeller after SC restr end: dutheta"
8630       do i=ithet_start,ithet_end
8631         write (iout,*) i,dutheta(i)
8632       enddo
8633       endif
8634       if (waga_d.eq.1.0d0) then
8635       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8636       do i=1,nres
8637         write (iout,*) i,(duscdiff(j,i),j=1,3)
8638         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8639       enddo
8640       endif
8641 #endif
8642
8643 c Total energy from homology restraints
8644 #ifdef DEBUG
8645       write (iout,*) "odleg",odleg," kat",kat
8646 #endif
8647 c
8648 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8649 c
8650 c     ehomology_constr=odleg+kat
8651 c
8652 c     For Lorentzian-type Urestr
8653 c
8654
8655       if (waga_dist.ge.0.0d0) then
8656 c
8657 c          For Gaussian-type Urestr
8658 c
8659         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8660      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8661 c     write (iout,*) "ehomology_constr=",ehomology_constr
8662       else
8663 c
8664 c          For Lorentzian-type Urestr
8665 c
8666         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8667      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8668 c     write (iout,*) "ehomology_constr=",ehomology_constr
8669       endif
8670 #ifdef DEBUG
8671       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8672      & "Eval",waga_theta,eval,
8673      &   "Erot",waga_d,Erot
8674       write (iout,*) "ehomology_constr",ehomology_constr
8675 #endif
8676       return
8677 c
8678 c FP 01/15 end
8679 c
8680   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8681   747 format(a12,i4,i4,i4,f8.3,f8.3)
8682   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8683   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8684   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8685      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8686       end
8687 c----------------------------------------------------------------------------
8688 C The rigorous attempt to derive energy function
8689       subroutine ebend_kcc(etheta)
8690
8691       implicit real*8 (a-h,o-z)
8692       include 'DIMENSIONS'
8693       include 'COMMON.VAR'
8694       include 'COMMON.GEO'
8695       include 'COMMON.LOCAL'
8696       include 'COMMON.TORSION'
8697       include 'COMMON.INTERACT'
8698       include 'COMMON.DERIV'
8699       include 'COMMON.CHAIN'
8700       include 'COMMON.NAMES'
8701       include 'COMMON.IOUNITS'
8702       include 'COMMON.FFIELD'
8703       include 'COMMON.TORCNSTR'
8704       include 'COMMON.CONTROL'
8705       logical lprn
8706       double precision thybt1(maxang_kcc)
8707 C Set lprn=.true. for debugging
8708       lprn=energy_dec
8709 c     lprn=.true.
8710 C      print *,"wchodze kcc"
8711       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8712       etheta=0.0D0
8713       do i=ithet_start,ithet_end
8714 c        print *,i,itype(i-1),itype(i),itype(i-2)
8715         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8716      &  .or.itype(i).eq.ntyp1) cycle
8717         iti=iabs(itortyp(itype(i-1)))
8718         sinthet=dsin(theta(i))
8719         costhet=dcos(theta(i))
8720         do j=1,nbend_kcc_Tb(iti)
8721           thybt1(j)=v1bend_chyb(j,iti)
8722         enddo
8723         sumth1thyb=v1bend_chyb(0,iti)+
8724      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8725         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8726      &    sumth1thyb
8727         ihelp=nbend_kcc_Tb(iti)-1
8728         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8729         etheta=etheta+sumth1thyb
8730 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8731         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8732       enddo
8733       return
8734       end
8735 c-------------------------------------------------------------------------------------
8736       subroutine etheta_constr(ethetacnstr)
8737
8738       implicit real*8 (a-h,o-z)
8739       include 'DIMENSIONS'
8740       include 'COMMON.VAR'
8741       include 'COMMON.GEO'
8742       include 'COMMON.LOCAL'
8743       include 'COMMON.TORSION'
8744       include 'COMMON.INTERACT'
8745       include 'COMMON.DERIV'
8746       include 'COMMON.CHAIN'
8747       include 'COMMON.NAMES'
8748       include 'COMMON.IOUNITS'
8749       include 'COMMON.FFIELD'
8750       include 'COMMON.TORCNSTR'
8751       include 'COMMON.CONTROL'
8752       ethetacnstr=0.0d0
8753 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8754       do i=ithetaconstr_start,ithetaconstr_end
8755         itheta=itheta_constr(i)
8756         thetiii=theta(itheta)
8757         difi=pinorm(thetiii-theta_constr0(i))
8758         if (difi.gt.theta_drange(i)) then
8759           difi=difi-theta_drange(i)
8760           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8761           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8762      &    +for_thet_constr(i)*difi**3
8763         else if (difi.lt.-drange(i)) then
8764           difi=difi+drange(i)
8765           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8766           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8767      &    +for_thet_constr(i)*difi**3
8768         else
8769           difi=0.0
8770         endif
8771        if (energy_dec) then
8772         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8773      &    i,itheta,rad2deg*thetiii,
8774      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8775      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8776      &    gloc(itheta+nphi-2,icg)
8777         endif
8778       enddo
8779       return
8780       end
8781 c------------------------------------------------------------------------------
8782       subroutine eback_sc_corr(esccor)
8783 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8784 c        conformational states; temporarily implemented as differences
8785 c        between UNRES torsional potentials (dependent on three types of
8786 c        residues) and the torsional potentials dependent on all 20 types
8787 c        of residues computed from AM1  energy surfaces of terminally-blocked
8788 c        amino-acid residues.
8789       implicit real*8 (a-h,o-z)
8790       include 'DIMENSIONS'
8791       include 'COMMON.VAR'
8792       include 'COMMON.GEO'
8793       include 'COMMON.LOCAL'
8794       include 'COMMON.TORSION'
8795       include 'COMMON.SCCOR'
8796       include 'COMMON.INTERACT'
8797       include 'COMMON.DERIV'
8798       include 'COMMON.CHAIN'
8799       include 'COMMON.NAMES'
8800       include 'COMMON.IOUNITS'
8801       include 'COMMON.FFIELD'
8802       include 'COMMON.CONTROL'
8803       logical lprn
8804 C Set lprn=.true. for debugging
8805       lprn=.false.
8806 c      lprn=.true.
8807 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8808       esccor=0.0D0
8809       do i=itau_start,itau_end
8810         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8811         esccor_ii=0.0D0
8812         isccori=isccortyp(itype(i-2))
8813         isccori1=isccortyp(itype(i-1))
8814 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8815         phii=phi(i)
8816         do intertyp=1,3 !intertyp
8817 cc Added 09 May 2012 (Adasko)
8818 cc  Intertyp means interaction type of backbone mainchain correlation:
8819 c   1 = SC...Ca...Ca...Ca
8820 c   2 = Ca...Ca...Ca...SC
8821 c   3 = SC...Ca...Ca...SCi
8822         gloci=0.0D0
8823         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8824      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8825      &      (itype(i-1).eq.ntyp1)))
8826      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8827      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8828      &     .or.(itype(i).eq.ntyp1)))
8829      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8830      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8831      &      (itype(i-3).eq.ntyp1)))) cycle
8832         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8833         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8834      & cycle
8835        do j=1,nterm_sccor(isccori,isccori1)
8836           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8837           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8838           cosphi=dcos(j*tauangle(intertyp,i))
8839           sinphi=dsin(j*tauangle(intertyp,i))
8840           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8841           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8842         enddo
8843 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8844         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8845         if (lprn)
8846      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8847      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8848      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8849      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8850         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8851        enddo !intertyp
8852       enddo
8853
8854       return
8855       end
8856 #ifdef FOURBODY
8857 c----------------------------------------------------------------------------
8858       subroutine multibody(ecorr)
8859 C This subroutine calculates multi-body contributions to energy following
8860 C the idea of Skolnick et al. If side chains I and J make a contact and
8861 C at the same time side chains I+1 and J+1 make a contact, an extra
8862 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8863       implicit real*8 (a-h,o-z)
8864       include 'DIMENSIONS'
8865       include 'COMMON.IOUNITS'
8866       include 'COMMON.DERIV'
8867       include 'COMMON.INTERACT'
8868       include 'COMMON.CONTACTS'
8869       include 'COMMON.CONTMAT'
8870       include 'COMMON.CORRMAT'
8871       double precision gx(3),gx1(3)
8872       logical lprn
8873
8874 C Set lprn=.true. for debugging
8875       lprn=.false.
8876
8877       if (lprn) then
8878         write (iout,'(a)') 'Contact function values:'
8879         do i=nnt,nct-2
8880           write (iout,'(i2,20(1x,i2,f10.5))')
8881      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8882         enddo
8883       endif
8884       ecorr=0.0D0
8885       do i=nnt,nct
8886         do j=1,3
8887           gradcorr(j,i)=0.0D0
8888           gradxorr(j,i)=0.0D0
8889         enddo
8890       enddo
8891       do i=nnt,nct-2
8892
8893         DO ISHIFT = 3,4
8894
8895         i1=i+ishift
8896         num_conti=num_cont(i)
8897         num_conti1=num_cont(i1)
8898         do jj=1,num_conti
8899           j=jcont(jj,i)
8900           do kk=1,num_conti1
8901             j1=jcont(kk,i1)
8902             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8903 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8904 cd   &                   ' ishift=',ishift
8905 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8906 C The system gains extra energy.
8907               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8908             endif   ! j1==j+-ishift
8909           enddo     ! kk
8910         enddo       ! jj
8911
8912         ENDDO ! ISHIFT
8913
8914       enddo         ! i
8915       return
8916       end
8917 c------------------------------------------------------------------------------
8918       double precision function esccorr(i,j,k,l,jj,kk)
8919       implicit real*8 (a-h,o-z)
8920       include 'DIMENSIONS'
8921       include 'COMMON.IOUNITS'
8922       include 'COMMON.DERIV'
8923       include 'COMMON.INTERACT'
8924       include 'COMMON.CONTACTS'
8925       include 'COMMON.CONTMAT'
8926       include 'COMMON.CORRMAT'
8927       include 'COMMON.SHIELD'
8928       double precision gx(3),gx1(3)
8929       logical lprn
8930       lprn=.false.
8931       eij=facont(jj,i)
8932       ekl=facont(kk,k)
8933 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8934 C Calculate the multi-body contribution to energy.
8935 C Calculate multi-body contributions to the gradient.
8936 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8937 cd   & k,l,(gacont(m,kk,k),m=1,3)
8938       do m=1,3
8939         gx(m) =ekl*gacont(m,jj,i)
8940         gx1(m)=eij*gacont(m,kk,k)
8941         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8942         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8943         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8944         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8945       enddo
8946       do m=i,j-1
8947         do ll=1,3
8948           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8949         enddo
8950       enddo
8951       do m=k,l-1
8952         do ll=1,3
8953           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8954         enddo
8955       enddo
8956       esccorr=-eij*ekl
8957       return
8958       end
8959 c------------------------------------------------------------------------------
8960       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8961 C This subroutine calculates multi-body contributions to hydrogen-bonding
8962       implicit real*8 (a-h,o-z)
8963       include 'DIMENSIONS'
8964       include 'COMMON.IOUNITS'
8965 #ifdef MPI
8966       include "mpif.h"
8967       parameter (max_cont=maxconts)
8968       parameter (max_dim=26)
8969       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8970       double precision zapas(max_dim,maxconts,max_fg_procs),
8971      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8972       common /przechowalnia/ zapas
8973       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8974      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8975 #endif
8976       include 'COMMON.SETUP'
8977       include 'COMMON.FFIELD'
8978       include 'COMMON.DERIV'
8979       include 'COMMON.INTERACT'
8980       include 'COMMON.CONTACTS'
8981       include 'COMMON.CONTMAT'
8982       include 'COMMON.CORRMAT'
8983       include 'COMMON.CONTROL'
8984       include 'COMMON.LOCAL'
8985       double precision gx(3),gx1(3),time00
8986       logical lprn,ldone
8987
8988 C Set lprn=.true. for debugging
8989       lprn=.false.
8990 #ifdef MPI
8991       n_corr=0
8992       n_corr1=0
8993       if (nfgtasks.le.1) goto 30
8994       if (lprn) then
8995         write (iout,'(a)') 'Contact function values before RECEIVE:'
8996         do i=nnt,nct-2
8997           write (iout,'(2i3,50(1x,i2,f5.2))')
8998      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8999      &    j=1,num_cont_hb(i))
9000         enddo
9001         call flush(iout)
9002       endif
9003       do i=1,ntask_cont_from
9004         ncont_recv(i)=0
9005       enddo
9006       do i=1,ntask_cont_to
9007         ncont_sent(i)=0
9008       enddo
9009 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9010 c     & ntask_cont_to
9011 C Make the list of contacts to send to send to other procesors
9012 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
9013 c      call flush(iout)
9014       do i=iturn3_start,iturn3_end
9015 c        write (iout,*) "make contact list turn3",i," num_cont",
9016 c     &    num_cont_hb(i)
9017         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
9018       enddo
9019       do i=iturn4_start,iturn4_end
9020 c        write (iout,*) "make contact list turn4",i," num_cont",
9021 c     &   num_cont_hb(i)
9022         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
9023       enddo
9024       do ii=1,nat_sent
9025         i=iat_sent(ii)
9026 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9027 c     &    num_cont_hb(i)
9028         do j=1,num_cont_hb(i)
9029         do k=1,4
9030           jjc=jcont_hb(j,i)
9031           iproc=iint_sent_local(k,jjc,ii)
9032 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9033           if (iproc.gt.0) then
9034             ncont_sent(iproc)=ncont_sent(iproc)+1
9035             nn=ncont_sent(iproc)
9036             zapas(1,nn,iproc)=i
9037             zapas(2,nn,iproc)=jjc
9038             zapas(3,nn,iproc)=facont_hb(j,i)
9039             zapas(4,nn,iproc)=ees0p(j,i)
9040             zapas(5,nn,iproc)=ees0m(j,i)
9041             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
9042             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
9043             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
9044             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
9045             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
9046             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
9047             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
9048             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
9049             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
9050             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
9051             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
9052             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
9053             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
9054             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
9055             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
9056             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
9057             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
9058             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
9059             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
9060             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
9061             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
9062           endif
9063         enddo
9064         enddo
9065       enddo
9066       if (lprn) then
9067       write (iout,*)
9068      &  "Numbers of contacts to be sent to other processors",
9069      &  (ncont_sent(i),i=1,ntask_cont_to)
9070       write (iout,*) "Contacts sent"
9071       do ii=1,ntask_cont_to
9072         nn=ncont_sent(ii)
9073         iproc=itask_cont_to(ii)
9074         write (iout,*) nn," contacts to processor",iproc,
9075      &   " of CONT_TO_COMM group"
9076         do i=1,nn
9077           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9078         enddo
9079       enddo
9080       call flush(iout)
9081       endif
9082       CorrelType=477
9083       CorrelID=fg_rank+1
9084       CorrelType1=478
9085       CorrelID1=nfgtasks+fg_rank+1
9086       ireq=0
9087 C Receive the numbers of needed contacts from other processors
9088       do ii=1,ntask_cont_from
9089         iproc=itask_cont_from(ii)
9090         ireq=ireq+1
9091         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9092      &    FG_COMM,req(ireq),IERR)
9093       enddo
9094 c      write (iout,*) "IRECV ended"
9095 c      call flush(iout)
9096 C Send the number of contacts needed by other processors
9097       do ii=1,ntask_cont_to
9098         iproc=itask_cont_to(ii)
9099         ireq=ireq+1
9100         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9101      &    FG_COMM,req(ireq),IERR)
9102       enddo
9103 c      write (iout,*) "ISEND ended"
9104 c      write (iout,*) "number of requests (nn)",ireq
9105 c      call flush(iout)
9106       if (ireq.gt.0)
9107      &  call MPI_Waitall(ireq,req,status_array,ierr)
9108 c      write (iout,*)
9109 c     &  "Numbers of contacts to be received from other processors",
9110 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9111 c      call flush(iout)
9112 C Receive contacts
9113       ireq=0
9114       do ii=1,ntask_cont_from
9115         iproc=itask_cont_from(ii)
9116         nn=ncont_recv(ii)
9117 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9118 c     &   " of CONT_TO_COMM group"
9119 c        call flush(iout)
9120         if (nn.gt.0) then
9121           ireq=ireq+1
9122           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9123      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9124 c          write (iout,*) "ireq,req",ireq,req(ireq)
9125         endif
9126       enddo
9127 C Send the contacts to processors that need them
9128       do ii=1,ntask_cont_to
9129         iproc=itask_cont_to(ii)
9130         nn=ncont_sent(ii)
9131 c        write (iout,*) nn," contacts to processor",iproc,
9132 c     &   " of CONT_TO_COMM group"
9133         if (nn.gt.0) then
9134           ireq=ireq+1
9135           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9136      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9137 c          write (iout,*) "ireq,req",ireq,req(ireq)
9138 c          do i=1,nn
9139 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9140 c          enddo
9141         endif
9142       enddo
9143 c      write (iout,*) "number of requests (contacts)",ireq
9144 c      write (iout,*) "req",(req(i),i=1,4)
9145 c      call flush(iout)
9146       if (ireq.gt.0)
9147      & call MPI_Waitall(ireq,req,status_array,ierr)
9148       do iii=1,ntask_cont_from
9149         iproc=itask_cont_from(iii)
9150         nn=ncont_recv(iii)
9151         if (lprn) then
9152         write (iout,*) "Received",nn," contacts from processor",iproc,
9153      &   " of CONT_FROM_COMM group"
9154         call flush(iout)
9155         do i=1,nn
9156           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9157         enddo
9158         call flush(iout)
9159         endif
9160         do i=1,nn
9161           ii=zapas_recv(1,i,iii)
9162 c Flag the received contacts to prevent double-counting
9163           jj=-zapas_recv(2,i,iii)
9164 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9165 c          call flush(iout)
9166           nnn=num_cont_hb(ii)+1
9167           num_cont_hb(ii)=nnn
9168           jcont_hb(nnn,ii)=jj
9169           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9170           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9171           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9172           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9173           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9174           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9175           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9176           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9177           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9178           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9179           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9180           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9181           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9182           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9183           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9184           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9185           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9186           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9187           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9188           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9189           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9190           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9191           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9192           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9193         enddo
9194       enddo
9195       if (lprn) then
9196         write (iout,'(a)') 'Contact function values after receive:'
9197         do i=nnt,nct-2
9198           write (iout,'(2i3,50(1x,i3,f5.2))')
9199      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9200      &    j=1,num_cont_hb(i))
9201         enddo
9202         call flush(iout)
9203       endif
9204    30 continue
9205 #endif
9206       if (lprn) then
9207         write (iout,'(a)') 'Contact function values:'
9208         do i=nnt,nct-2
9209           write (iout,'(2i3,50(1x,i3,f5.2))')
9210      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9211      &    j=1,num_cont_hb(i))
9212         enddo
9213         call flush(iout)
9214       endif
9215       ecorr=0.0D0
9216 C Remove the loop below after debugging !!!
9217       do i=nnt,nct
9218         do j=1,3
9219           gradcorr(j,i)=0.0D0
9220           gradxorr(j,i)=0.0D0
9221         enddo
9222       enddo
9223 C Calculate the local-electrostatic correlation terms
9224       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9225         i1=i+1
9226         num_conti=num_cont_hb(i)
9227         num_conti1=num_cont_hb(i+1)
9228         do jj=1,num_conti
9229           j=jcont_hb(jj,i)
9230           jp=iabs(j)
9231           do kk=1,num_conti1
9232             j1=jcont_hb(kk,i1)
9233             jp1=iabs(j1)
9234 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9235 c     &         ' jj=',jj,' kk=',kk
9236 c            call flush(iout)
9237             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9238      &          .or. j.lt.0 .and. j1.gt.0) .and.
9239      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9240 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9241 C The system gains extra energy.
9242               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9243               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9244      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9245               n_corr=n_corr+1
9246             else if (j1.eq.j) then
9247 C Contacts I-J and I-(J+1) occur simultaneously.
9248 C The system loses extra energy.
9249 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9250             endif
9251           enddo ! kk
9252           do kk=1,num_conti
9253             j1=jcont_hb(kk,i)
9254 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9255 c    &         ' jj=',jj,' kk=',kk
9256             if (j1.eq.j+1) then
9257 C Contacts I-J and (I+1)-J occur simultaneously.
9258 C The system loses extra energy.
9259 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9260             endif ! j1==j+1
9261           enddo ! kk
9262         enddo ! jj
9263       enddo ! i
9264       return
9265       end
9266 c------------------------------------------------------------------------------
9267       subroutine add_hb_contact(ii,jj,itask)
9268       implicit real*8 (a-h,o-z)
9269       include "DIMENSIONS"
9270       include "COMMON.IOUNITS"
9271       integer max_cont
9272       integer max_dim
9273       parameter (max_cont=maxconts)
9274       parameter (max_dim=26)
9275       include "COMMON.CONTACTS"
9276       include 'COMMON.CONTMAT'
9277       include 'COMMON.CORRMAT'
9278       double precision zapas(max_dim,maxconts,max_fg_procs),
9279      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9280       common /przechowalnia/ zapas
9281       integer i,j,ii,jj,iproc,itask(4),nn
9282 c      write (iout,*) "itask",itask
9283       do i=1,2
9284         iproc=itask(i)
9285         if (iproc.gt.0) then
9286           do j=1,num_cont_hb(ii)
9287             jjc=jcont_hb(j,ii)
9288 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9289             if (jjc.eq.jj) then
9290               ncont_sent(iproc)=ncont_sent(iproc)+1
9291               nn=ncont_sent(iproc)
9292               zapas(1,nn,iproc)=ii
9293               zapas(2,nn,iproc)=jjc
9294               zapas(3,nn,iproc)=facont_hb(j,ii)
9295               zapas(4,nn,iproc)=ees0p(j,ii)
9296               zapas(5,nn,iproc)=ees0m(j,ii)
9297               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9298               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9299               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9300               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9301               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9302               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9303               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9304               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9305               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9306               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9307               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9308               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9309               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9310               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9311               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9312               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9313               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9314               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9315               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9316               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9317               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9318               exit
9319             endif
9320           enddo
9321         endif
9322       enddo
9323       return
9324       end
9325 c------------------------------------------------------------------------------
9326       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9327      &  n_corr1)
9328 C This subroutine calculates multi-body contributions to hydrogen-bonding
9329       implicit real*8 (a-h,o-z)
9330       include 'DIMENSIONS'
9331       include 'COMMON.IOUNITS'
9332 #ifdef MPI
9333       include "mpif.h"
9334       parameter (max_cont=maxconts)
9335       parameter (max_dim=70)
9336       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9337       double precision zapas(max_dim,maxconts,max_fg_procs),
9338      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9339       common /przechowalnia/ zapas
9340       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9341      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9342 #endif
9343       include 'COMMON.SETUP'
9344       include 'COMMON.FFIELD'
9345       include 'COMMON.DERIV'
9346       include 'COMMON.LOCAL'
9347       include 'COMMON.INTERACT'
9348       include 'COMMON.CONTACTS'
9349       include 'COMMON.CONTMAT'
9350       include 'COMMON.CORRMAT'
9351       include 'COMMON.CHAIN'
9352       include 'COMMON.CONTROL'
9353       include 'COMMON.SHIELD'
9354       double precision gx(3),gx1(3)
9355       integer num_cont_hb_old(maxres)
9356       logical lprn,ldone
9357       double precision eello4,eello5,eelo6,eello_turn6
9358       external eello4,eello5,eello6,eello_turn6
9359 C Set lprn=.true. for debugging
9360       lprn=.false.
9361       eturn6=0.0d0
9362 #ifdef MPI
9363       do i=1,nres
9364         num_cont_hb_old(i)=num_cont_hb(i)
9365       enddo
9366       n_corr=0
9367       n_corr1=0
9368       if (nfgtasks.le.1) goto 30
9369       if (lprn) then
9370         write (iout,'(a)') 'Contact function values before RECEIVE:'
9371         do i=nnt,nct-2
9372           write (iout,'(2i3,50(1x,i2,f5.2))')
9373      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9374      &    j=1,num_cont_hb(i))
9375         enddo
9376       endif
9377       do i=1,ntask_cont_from
9378         ncont_recv(i)=0
9379       enddo
9380       do i=1,ntask_cont_to
9381         ncont_sent(i)=0
9382       enddo
9383 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9384 c     & ntask_cont_to
9385 C Make the list of contacts to send to send to other procesors
9386       do i=iturn3_start,iturn3_end
9387 c        write (iout,*) "make contact list turn3",i," num_cont",
9388 c     &    num_cont_hb(i)
9389         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9390       enddo
9391       do i=iturn4_start,iturn4_end
9392 c        write (iout,*) "make contact list turn4",i," num_cont",
9393 c     &   num_cont_hb(i)
9394         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9395       enddo
9396       do ii=1,nat_sent
9397         i=iat_sent(ii)
9398 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9399 c     &    num_cont_hb(i)
9400         do j=1,num_cont_hb(i)
9401         do k=1,4
9402           jjc=jcont_hb(j,i)
9403           iproc=iint_sent_local(k,jjc,ii)
9404 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9405           if (iproc.ne.0) then
9406             ncont_sent(iproc)=ncont_sent(iproc)+1
9407             nn=ncont_sent(iproc)
9408             zapas(1,nn,iproc)=i
9409             zapas(2,nn,iproc)=jjc
9410             zapas(3,nn,iproc)=d_cont(j,i)
9411             ind=3
9412             do kk=1,3
9413               ind=ind+1
9414               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9415             enddo
9416             do kk=1,2
9417               do ll=1,2
9418                 ind=ind+1
9419                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9420               enddo
9421             enddo
9422             do jj=1,5
9423               do kk=1,3
9424                 do ll=1,2
9425                   do mm=1,2
9426                     ind=ind+1
9427                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9428                   enddo
9429                 enddo
9430               enddo
9431             enddo
9432           endif
9433         enddo
9434         enddo
9435       enddo
9436       if (lprn) then
9437       write (iout,*)
9438      &  "Numbers of contacts to be sent to other processors",
9439      &  (ncont_sent(i),i=1,ntask_cont_to)
9440       write (iout,*) "Contacts sent"
9441       do ii=1,ntask_cont_to
9442         nn=ncont_sent(ii)
9443         iproc=itask_cont_to(ii)
9444         write (iout,*) nn," contacts to processor",iproc,
9445      &   " of CONT_TO_COMM group"
9446         do i=1,nn
9447           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9448         enddo
9449       enddo
9450       call flush(iout)
9451       endif
9452       CorrelType=477
9453       CorrelID=fg_rank+1
9454       CorrelType1=478
9455       CorrelID1=nfgtasks+fg_rank+1
9456       ireq=0
9457 C Receive the numbers of needed contacts from other processors
9458       do ii=1,ntask_cont_from
9459         iproc=itask_cont_from(ii)
9460         ireq=ireq+1
9461         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9462      &    FG_COMM,req(ireq),IERR)
9463       enddo
9464 c      write (iout,*) "IRECV ended"
9465 c      call flush(iout)
9466 C Send the number of contacts needed by other processors
9467       do ii=1,ntask_cont_to
9468         iproc=itask_cont_to(ii)
9469         ireq=ireq+1
9470         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9471      &    FG_COMM,req(ireq),IERR)
9472       enddo
9473 c      write (iout,*) "ISEND ended"
9474 c      write (iout,*) "number of requests (nn)",ireq
9475 c      call flush(iout)
9476       if (ireq.gt.0)
9477      &  call MPI_Waitall(ireq,req,status_array,ierr)
9478 c      write (iout,*)
9479 c     &  "Numbers of contacts to be received from other processors",
9480 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9481 c      call flush(iout)
9482 C Receive contacts
9483       ireq=0
9484       do ii=1,ntask_cont_from
9485         iproc=itask_cont_from(ii)
9486         nn=ncont_recv(ii)
9487 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9488 c     &   " of CONT_TO_COMM group"
9489 c        call flush(iout)
9490         if (nn.gt.0) then
9491           ireq=ireq+1
9492           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9493      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9494 c          write (iout,*) "ireq,req",ireq,req(ireq)
9495         endif
9496       enddo
9497 C Send the contacts to processors that need them
9498       do ii=1,ntask_cont_to
9499         iproc=itask_cont_to(ii)
9500         nn=ncont_sent(ii)
9501 c        write (iout,*) nn," contacts to processor",iproc,
9502 c     &   " of CONT_TO_COMM group"
9503         if (nn.gt.0) then
9504           ireq=ireq+1
9505           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9506      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9507 c          write (iout,*) "ireq,req",ireq,req(ireq)
9508 c          do i=1,nn
9509 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9510 c          enddo
9511         endif
9512       enddo
9513 c      write (iout,*) "number of requests (contacts)",ireq
9514 c      write (iout,*) "req",(req(i),i=1,4)
9515 c      call flush(iout)
9516       if (ireq.gt.0)
9517      & call MPI_Waitall(ireq,req,status_array,ierr)
9518       do iii=1,ntask_cont_from
9519         iproc=itask_cont_from(iii)
9520         nn=ncont_recv(iii)
9521         if (lprn) then
9522         write (iout,*) "Received",nn," contacts from processor",iproc,
9523      &   " of CONT_FROM_COMM group"
9524         call flush(iout)
9525         do i=1,nn
9526           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9527         enddo
9528         call flush(iout)
9529         endif
9530         do i=1,nn
9531           ii=zapas_recv(1,i,iii)
9532 c Flag the received contacts to prevent double-counting
9533           jj=-zapas_recv(2,i,iii)
9534 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9535 c          call flush(iout)
9536           nnn=num_cont_hb(ii)+1
9537           num_cont_hb(ii)=nnn
9538           jcont_hb(nnn,ii)=jj
9539           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9540           ind=3
9541           do kk=1,3
9542             ind=ind+1
9543             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9544           enddo
9545           do kk=1,2
9546             do ll=1,2
9547               ind=ind+1
9548               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9549             enddo
9550           enddo
9551           do jj=1,5
9552             do kk=1,3
9553               do ll=1,2
9554                 do mm=1,2
9555                   ind=ind+1
9556                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9557                 enddo
9558               enddo
9559             enddo
9560           enddo
9561         enddo
9562       enddo
9563       if (lprn) then
9564         write (iout,'(a)') 'Contact function values after receive:'
9565         do i=nnt,nct-2
9566           write (iout,'(2i3,50(1x,i3,5f6.3))')
9567      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9568      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9569         enddo
9570         call flush(iout)
9571       endif
9572    30 continue
9573 #endif
9574       if (lprn) then
9575         write (iout,'(a)') 'Contact function values:'
9576         do i=nnt,nct-2
9577           write (iout,'(2i3,50(1x,i2,5f6.3))')
9578      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9579      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9580         enddo
9581       endif
9582       ecorr=0.0D0
9583       ecorr5=0.0d0
9584       ecorr6=0.0d0
9585 C Remove the loop below after debugging !!!
9586       do i=nnt,nct
9587         do j=1,3
9588           gradcorr(j,i)=0.0D0
9589           gradxorr(j,i)=0.0D0
9590         enddo
9591       enddo
9592 C Calculate the dipole-dipole interaction energies
9593       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9594       do i=iatel_s,iatel_e+1
9595         num_conti=num_cont_hb(i)
9596         do jj=1,num_conti
9597           j=jcont_hb(jj,i)
9598 #ifdef MOMENT
9599           call dipole(i,j,jj)
9600 #endif
9601         enddo
9602       enddo
9603       endif
9604 C Calculate the local-electrostatic correlation terms
9605 c                write (iout,*) "gradcorr5 in eello5 before loop"
9606 c                do iii=1,nres
9607 c                  write (iout,'(i5,3f10.5)')
9608 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9609 c                enddo
9610       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9611 c        write (iout,*) "corr loop i",i
9612         i1=i+1
9613         num_conti=num_cont_hb(i)
9614         num_conti1=num_cont_hb(i+1)
9615         do jj=1,num_conti
9616           j=jcont_hb(jj,i)
9617           jp=iabs(j)
9618           do kk=1,num_conti1
9619             j1=jcont_hb(kk,i1)
9620             jp1=iabs(j1)
9621 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9622 c     &         ' jj=',jj,' kk=',kk
9623 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9624             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9625      &          .or. j.lt.0 .and. j1.gt.0) .and.
9626      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9627 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9628 C The system gains extra energy.
9629               n_corr=n_corr+1
9630               sqd1=dsqrt(d_cont(jj,i))
9631               sqd2=dsqrt(d_cont(kk,i1))
9632               sred_geom = sqd1*sqd2
9633               IF (sred_geom.lt.cutoff_corr) THEN
9634                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9635      &            ekont,fprimcont)
9636 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9637 cd     &         ' jj=',jj,' kk=',kk
9638                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9639                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9640                 do l=1,3
9641                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9642                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9643                 enddo
9644                 n_corr1=n_corr1+1
9645 cd               write (iout,*) 'sred_geom=',sred_geom,
9646 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9647 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9648 cd               write (iout,*) "g_contij",g_contij
9649 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9650 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9651                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9652                 if (wcorr4.gt.0.0d0)
9653      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9654 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9655                   if (energy_dec.and.wcorr4.gt.0.0d0)
9656      1                 write (iout,'(a6,4i5,0pf7.3)')
9657      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9658 c                write (iout,*) "gradcorr5 before eello5"
9659 c                do iii=1,nres
9660 c                  write (iout,'(i5,3f10.5)')
9661 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9662 c                enddo
9663                 if (wcorr5.gt.0.0d0)
9664      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9665 c                write (iout,*) "gradcorr5 after eello5"
9666 c                do iii=1,nres
9667 c                  write (iout,'(i5,3f10.5)')
9668 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9669 c                enddo
9670                   if (energy_dec.and.wcorr5.gt.0.0d0)
9671      1                 write (iout,'(a6,4i5,0pf7.3)')
9672      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9673 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9674 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9675                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9676      &               .or. wturn6.eq.0.0d0))then
9677 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9678                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9679                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9680      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9681 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9682 cd     &            'ecorr6=',ecorr6
9683 cd                write (iout,'(4e15.5)') sred_geom,
9684 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9685 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9686 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9687                 else if (wturn6.gt.0.0d0
9688      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9689 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9690                   eturn6=eturn6+eello_turn6(i,jj,kk)
9691                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9692      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9693 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9694                 endif
9695               ENDIF
9696 1111          continue
9697             endif
9698           enddo ! kk
9699         enddo ! jj
9700       enddo ! i
9701       do i=1,nres
9702         num_cont_hb(i)=num_cont_hb_old(i)
9703       enddo
9704 c                write (iout,*) "gradcorr5 in eello5"
9705 c                do iii=1,nres
9706 c                  write (iout,'(i5,3f10.5)')
9707 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9708 c                enddo
9709       return
9710       end
9711 c------------------------------------------------------------------------------
9712       subroutine add_hb_contact_eello(ii,jj,itask)
9713       implicit real*8 (a-h,o-z)
9714       include "DIMENSIONS"
9715       include "COMMON.IOUNITS"
9716       integer max_cont
9717       integer max_dim
9718       parameter (max_cont=maxconts)
9719       parameter (max_dim=70)
9720       include "COMMON.CONTACTS"
9721       include 'COMMON.CONTMAT'
9722       include 'COMMON.CORRMAT'
9723       double precision zapas(max_dim,maxconts,max_fg_procs),
9724      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9725       common /przechowalnia/ zapas
9726       integer i,j,ii,jj,iproc,itask(4),nn
9727 c      write (iout,*) "itask",itask
9728       do i=1,2
9729         iproc=itask(i)
9730         if (iproc.gt.0) then
9731           do j=1,num_cont_hb(ii)
9732             jjc=jcont_hb(j,ii)
9733 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9734             if (jjc.eq.jj) then
9735               ncont_sent(iproc)=ncont_sent(iproc)+1
9736               nn=ncont_sent(iproc)
9737               zapas(1,nn,iproc)=ii
9738               zapas(2,nn,iproc)=jjc
9739               zapas(3,nn,iproc)=d_cont(j,ii)
9740               ind=3
9741               do kk=1,3
9742                 ind=ind+1
9743                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9744               enddo
9745               do kk=1,2
9746                 do ll=1,2
9747                   ind=ind+1
9748                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9749                 enddo
9750               enddo
9751               do jj=1,5
9752                 do kk=1,3
9753                   do ll=1,2
9754                     do mm=1,2
9755                       ind=ind+1
9756                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9757                     enddo
9758                   enddo
9759                 enddo
9760               enddo
9761               exit
9762             endif
9763           enddo
9764         endif
9765       enddo
9766       return
9767       end
9768 c------------------------------------------------------------------------------
9769       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9770       implicit real*8 (a-h,o-z)
9771       include 'DIMENSIONS'
9772       include 'COMMON.IOUNITS'
9773       include 'COMMON.DERIV'
9774       include 'COMMON.INTERACT'
9775       include 'COMMON.CONTACTS'
9776       include 'COMMON.CONTMAT'
9777       include 'COMMON.CORRMAT'
9778       include 'COMMON.SHIELD'
9779       include 'COMMON.CONTROL'
9780       double precision gx(3),gx1(3)
9781       logical lprn
9782       lprn=.false.
9783 C      print *,"wchodze",fac_shield(i),shield_mode
9784       eij=facont_hb(jj,i)
9785       ekl=facont_hb(kk,k)
9786       ees0pij=ees0p(jj,i)
9787       ees0pkl=ees0p(kk,k)
9788       ees0mij=ees0m(jj,i)
9789       ees0mkl=ees0m(kk,k)
9790       ekont=eij*ekl
9791       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9792 C*
9793 C     & fac_shield(i)**2*fac_shield(j)**2
9794 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9795 C Following 4 lines for diagnostics.
9796 cd    ees0pkl=0.0D0
9797 cd    ees0pij=1.0D0
9798 cd    ees0mkl=0.0D0
9799 cd    ees0mij=1.0D0
9800 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9801 c     & 'Contacts ',i,j,
9802 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9803 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9804 c     & 'gradcorr_long'
9805 C Calculate the multi-body contribution to energy.
9806 C      ecorr=ecorr+ekont*ees
9807 C Calculate multi-body contributions to the gradient.
9808       coeffpees0pij=coeffp*ees0pij
9809       coeffmees0mij=coeffm*ees0mij
9810       coeffpees0pkl=coeffp*ees0pkl
9811       coeffmees0mkl=coeffm*ees0mkl
9812       do ll=1,3
9813 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9814         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9815      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9816      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9817         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9818      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9819      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9820 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9821         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9822      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9823      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9824         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9825      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9826      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9827         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9828      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9829      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9830         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9831         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9832         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9833      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9834      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9835         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9836         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9837 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9838       enddo
9839 c      write (iout,*)
9840 cgrad      do m=i+1,j-1
9841 cgrad        do ll=1,3
9842 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9843 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9844 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9845 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9846 cgrad        enddo
9847 cgrad      enddo
9848 cgrad      do m=k+1,l-1
9849 cgrad        do ll=1,3
9850 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9851 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9852 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9853 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9854 cgrad        enddo
9855 cgrad      enddo
9856 c      write (iout,*) "ehbcorr",ekont*ees
9857 C      print *,ekont,ees,i,k
9858       ehbcorr=ekont*ees
9859 C now gradient over shielding
9860 C      return
9861       if (shield_mode.gt.0) then
9862        j=ees0plist(jj,i)
9863        l=ees0plist(kk,k)
9864 C        print *,i,j,fac_shield(i),fac_shield(j),
9865 C     &fac_shield(k),fac_shield(l)
9866         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9867      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9868           do ilist=1,ishield_list(i)
9869            iresshield=shield_list(ilist,i)
9870            do m=1,3
9871            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9872 C     &      *2.0
9873            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9874      &              rlocshield
9875      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9876             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9877      &+rlocshield
9878            enddo
9879           enddo
9880           do ilist=1,ishield_list(j)
9881            iresshield=shield_list(ilist,j)
9882            do m=1,3
9883            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9884 C     &     *2.0
9885            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9886      &              rlocshield
9887      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9888            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9889      &     +rlocshield
9890            enddo
9891           enddo
9892
9893           do ilist=1,ishield_list(k)
9894            iresshield=shield_list(ilist,k)
9895            do m=1,3
9896            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9897 C     &     *2.0
9898            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9899      &              rlocshield
9900      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9901            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9902      &     +rlocshield
9903            enddo
9904           enddo
9905           do ilist=1,ishield_list(l)
9906            iresshield=shield_list(ilist,l)
9907            do m=1,3
9908            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9909 C     &     *2.0
9910            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9911      &              rlocshield
9912      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9913            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9914      &     +rlocshield
9915            enddo
9916           enddo
9917 C          print *,gshieldx(m,iresshield)
9918           do m=1,3
9919             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9920      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9921             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9922      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9923             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9924      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9925             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9926      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9927
9928             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9929      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9930             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9931      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9932             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9933      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9934             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9935      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9936
9937            enddo
9938       endif
9939       endif
9940       return
9941       end
9942 #ifdef MOMENT
9943 C---------------------------------------------------------------------------
9944       subroutine dipole(i,j,jj)
9945       implicit real*8 (a-h,o-z)
9946       include 'DIMENSIONS'
9947       include 'COMMON.IOUNITS'
9948       include 'COMMON.CHAIN'
9949       include 'COMMON.FFIELD'
9950       include 'COMMON.DERIV'
9951       include 'COMMON.INTERACT'
9952       include 'COMMON.CONTACTS'
9953       include 'COMMON.CONTMAT'
9954       include 'COMMON.CORRMAT'
9955       include 'COMMON.TORSION'
9956       include 'COMMON.VAR'
9957       include 'COMMON.GEO'
9958       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9959      &  auxmat(2,2)
9960       iti1 = itortyp(itype(i+1))
9961       if (j.lt.nres-1) then
9962         itj1 = itype2loc(itype(j+1))
9963       else
9964         itj1=nloctyp
9965       endif
9966       do iii=1,2
9967         dipi(iii,1)=Ub2(iii,i)
9968         dipderi(iii)=Ub2der(iii,i)
9969         dipi(iii,2)=b1(iii,i+1)
9970         dipj(iii,1)=Ub2(iii,j)
9971         dipderj(iii)=Ub2der(iii,j)
9972         dipj(iii,2)=b1(iii,j+1)
9973       enddo
9974       kkk=0
9975       do iii=1,2
9976         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9977         do jjj=1,2
9978           kkk=kkk+1
9979           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9980         enddo
9981       enddo
9982       do kkk=1,5
9983         do lll=1,3
9984           mmm=0
9985           do iii=1,2
9986             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9987      &        auxvec(1))
9988             do jjj=1,2
9989               mmm=mmm+1
9990               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9991             enddo
9992           enddo
9993         enddo
9994       enddo
9995       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9996       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9997       do iii=1,2
9998         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9999       enddo
10000       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
10001       do iii=1,2
10002         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
10003       enddo
10004       return
10005       end
10006 #endif
10007 C---------------------------------------------------------------------------
10008       subroutine calc_eello(i,j,k,l,jj,kk)
10009 C
10010 C This subroutine computes matrices and vectors needed to calculate
10011 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
10012 C
10013       implicit real*8 (a-h,o-z)
10014       include 'DIMENSIONS'
10015       include 'COMMON.IOUNITS'
10016       include 'COMMON.CHAIN'
10017       include 'COMMON.DERIV'
10018       include 'COMMON.INTERACT'
10019       include 'COMMON.CONTACTS'
10020       include 'COMMON.CONTMAT'
10021       include 'COMMON.CORRMAT'
10022       include 'COMMON.TORSION'
10023       include 'COMMON.VAR'
10024       include 'COMMON.GEO'
10025       include 'COMMON.FFIELD'
10026       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
10027      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
10028       logical lprn
10029       common /kutas/ lprn
10030 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
10031 cd     & ' jj=',jj,' kk=',kk
10032 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
10033 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
10034 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
10035       do iii=1,2
10036         do jjj=1,2
10037           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
10038           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
10039         enddo
10040       enddo
10041       call transpose2(aa1(1,1),aa1t(1,1))
10042       call transpose2(aa2(1,1),aa2t(1,1))
10043       do kkk=1,5
10044         do lll=1,3
10045           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
10046      &      aa1tder(1,1,lll,kkk))
10047           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
10048      &      aa2tder(1,1,lll,kkk))
10049         enddo
10050       enddo
10051       if (l.eq.j+1) then
10052 C parallel orientation of the two CA-CA-CA frames.
10053         if (i.gt.1) then
10054           iti=itype2loc(itype(i))
10055         else
10056           iti=nloctyp
10057         endif
10058         itk1=itype2loc(itype(k+1))
10059         itj=itype2loc(itype(j))
10060         if (l.lt.nres-1) then
10061           itl1=itype2loc(itype(l+1))
10062         else
10063           itl1=nloctyp
10064         endif
10065 C A1 kernel(j+1) A2T
10066 cd        do iii=1,2
10067 cd          write (iout,'(3f10.5,5x,3f10.5)')
10068 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10069 cd        enddo
10070         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10071      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10072      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10073 C Following matrices are needed only for 6-th order cumulants
10074         IF (wcorr6.gt.0.0d0) THEN
10075         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10076      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10077      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10078         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10079      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10080      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10081      &   ADtEAderx(1,1,1,1,1,1))
10082         lprn=.false.
10083         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10084      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10085      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10086      &   ADtEA1derx(1,1,1,1,1,1))
10087         ENDIF
10088 C End 6-th order cumulants
10089 cd        lprn=.false.
10090 cd        if (lprn) then
10091 cd        write (2,*) 'In calc_eello6'
10092 cd        do iii=1,2
10093 cd          write (2,*) 'iii=',iii
10094 cd          do kkk=1,5
10095 cd            write (2,*) 'kkk=',kkk
10096 cd            do jjj=1,2
10097 cd              write (2,'(3(2f10.5),5x)')
10098 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10099 cd            enddo
10100 cd          enddo
10101 cd        enddo
10102 cd        endif
10103         call transpose2(EUgder(1,1,k),auxmat(1,1))
10104         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10105         call transpose2(EUg(1,1,k),auxmat(1,1))
10106         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10107         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10108 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10109 c    in theta; to be sriten later.
10110 c#ifdef NEWCORR
10111 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
10112 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10113 c        call transpose2(EUg(1,1,k),auxmat(1,1))
10114 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10115 c#endif
10116         do iii=1,2
10117           do kkk=1,5
10118             do lll=1,3
10119               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10120      &          EAEAderx(1,1,lll,kkk,iii,1))
10121             enddo
10122           enddo
10123         enddo
10124 C A1T kernel(i+1) A2
10125         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10126      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10127      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10128 C Following matrices are needed only for 6-th order cumulants
10129         IF (wcorr6.gt.0.0d0) THEN
10130         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10131      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10132      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10133         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10134      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10135      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10136      &   ADtEAderx(1,1,1,1,1,2))
10137         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10138      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10139      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10140      &   ADtEA1derx(1,1,1,1,1,2))
10141         ENDIF
10142 C End 6-th order cumulants
10143         call transpose2(EUgder(1,1,l),auxmat(1,1))
10144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10145         call transpose2(EUg(1,1,l),auxmat(1,1))
10146         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10147         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10148         do iii=1,2
10149           do kkk=1,5
10150             do lll=1,3
10151               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10152      &          EAEAderx(1,1,lll,kkk,iii,2))
10153             enddo
10154           enddo
10155         enddo
10156 C AEAb1 and AEAb2
10157 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10158 C They are needed only when the fifth- or the sixth-order cumulants are
10159 C indluded.
10160         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10161         call transpose2(AEA(1,1,1),auxmat(1,1))
10162         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10163         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10164         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10165         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10166         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10167         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10168         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10169         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10170         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10171         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10172         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10173         call transpose2(AEA(1,1,2),auxmat(1,1))
10174         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10175         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10176         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10177         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10178         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10179         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10180         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10181         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10182         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10183         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10184         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10185 C Calculate the Cartesian derivatives of the vectors.
10186         do iii=1,2
10187           do kkk=1,5
10188             do lll=1,3
10189               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10190               call matvec2(auxmat(1,1),b1(1,i),
10191      &          AEAb1derx(1,lll,kkk,iii,1,1))
10192               call matvec2(auxmat(1,1),Ub2(1,i),
10193      &          AEAb2derx(1,lll,kkk,iii,1,1))
10194               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10195      &          AEAb1derx(1,lll,kkk,iii,2,1))
10196               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10197      &          AEAb2derx(1,lll,kkk,iii,2,1))
10198               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10199               call matvec2(auxmat(1,1),b1(1,j),
10200      &          AEAb1derx(1,lll,kkk,iii,1,2))
10201               call matvec2(auxmat(1,1),Ub2(1,j),
10202      &          AEAb2derx(1,lll,kkk,iii,1,2))
10203               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10204      &          AEAb1derx(1,lll,kkk,iii,2,2))
10205               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10206      &          AEAb2derx(1,lll,kkk,iii,2,2))
10207             enddo
10208           enddo
10209         enddo
10210         ENDIF
10211 C End vectors
10212       else
10213 C Antiparallel orientation of the two CA-CA-CA frames.
10214         if (i.gt.1) then
10215           iti=itype2loc(itype(i))
10216         else
10217           iti=nloctyp
10218         endif
10219         itk1=itype2loc(itype(k+1))
10220         itl=itype2loc(itype(l))
10221         itj=itype2loc(itype(j))
10222         if (j.lt.nres-1) then
10223           itj1=itype2loc(itype(j+1))
10224         else
10225           itj1=nloctyp
10226         endif
10227 C A2 kernel(j-1)T A1T
10228         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10229      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10230      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10231 C Following matrices are needed only for 6-th order cumulants
10232         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10233      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10234         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10235      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10236      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10237         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10238      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10239      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10240      &   ADtEAderx(1,1,1,1,1,1))
10241         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10242      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10243      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10244      &   ADtEA1derx(1,1,1,1,1,1))
10245         ENDIF
10246 C End 6-th order cumulants
10247         call transpose2(EUgder(1,1,k),auxmat(1,1))
10248         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10249         call transpose2(EUg(1,1,k),auxmat(1,1))
10250         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10251         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10252         do iii=1,2
10253           do kkk=1,5
10254             do lll=1,3
10255               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10256      &          EAEAderx(1,1,lll,kkk,iii,1))
10257             enddo
10258           enddo
10259         enddo
10260 C A2T kernel(i+1)T A1
10261         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10262      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10263      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10264 C Following matrices are needed only for 6-th order cumulants
10265         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10266      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10267         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10268      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10269      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10270         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10271      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10272      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10273      &   ADtEAderx(1,1,1,1,1,2))
10274         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10275      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10276      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10277      &   ADtEA1derx(1,1,1,1,1,2))
10278         ENDIF
10279 C End 6-th order cumulants
10280         call transpose2(EUgder(1,1,j),auxmat(1,1))
10281         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10282         call transpose2(EUg(1,1,j),auxmat(1,1))
10283         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10284         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10285         do iii=1,2
10286           do kkk=1,5
10287             do lll=1,3
10288               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10289      &          EAEAderx(1,1,lll,kkk,iii,2))
10290             enddo
10291           enddo
10292         enddo
10293 C AEAb1 and AEAb2
10294 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10295 C They are needed only when the fifth- or the sixth-order cumulants are
10296 C indluded.
10297         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10298      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10299         call transpose2(AEA(1,1,1),auxmat(1,1))
10300         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10301         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10302         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10303         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10304         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10305         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10306         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10307         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10308         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10309         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10310         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10311         call transpose2(AEA(1,1,2),auxmat(1,1))
10312         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10313         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10314         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10315         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10316         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10317         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10318         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10319         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10320         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10321         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10322         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10323 C Calculate the Cartesian derivatives of the vectors.
10324         do iii=1,2
10325           do kkk=1,5
10326             do lll=1,3
10327               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10328               call matvec2(auxmat(1,1),b1(1,i),
10329      &          AEAb1derx(1,lll,kkk,iii,1,1))
10330               call matvec2(auxmat(1,1),Ub2(1,i),
10331      &          AEAb2derx(1,lll,kkk,iii,1,1))
10332               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10333      &          AEAb1derx(1,lll,kkk,iii,2,1))
10334               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10335      &          AEAb2derx(1,lll,kkk,iii,2,1))
10336               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10337               call matvec2(auxmat(1,1),b1(1,l),
10338      &          AEAb1derx(1,lll,kkk,iii,1,2))
10339               call matvec2(auxmat(1,1),Ub2(1,l),
10340      &          AEAb2derx(1,lll,kkk,iii,1,2))
10341               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10342      &          AEAb1derx(1,lll,kkk,iii,2,2))
10343               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10344      &          AEAb2derx(1,lll,kkk,iii,2,2))
10345             enddo
10346           enddo
10347         enddo
10348         ENDIF
10349 C End vectors
10350       endif
10351       return
10352       end
10353 C---------------------------------------------------------------------------
10354       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10355      &  KK,KKderg,AKA,AKAderg,AKAderx)
10356       implicit none
10357       integer nderg
10358       logical transp
10359       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10360      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10361      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10362       integer iii,kkk,lll
10363       integer jjj,mmm
10364       logical lprn
10365       common /kutas/ lprn
10366       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10367       do iii=1,nderg
10368         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10369      &    AKAderg(1,1,iii))
10370       enddo
10371 cd      if (lprn) write (2,*) 'In kernel'
10372       do kkk=1,5
10373 cd        if (lprn) write (2,*) 'kkk=',kkk
10374         do lll=1,3
10375           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10376      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10377 cd          if (lprn) then
10378 cd            write (2,*) 'lll=',lll
10379 cd            write (2,*) 'iii=1'
10380 cd            do jjj=1,2
10381 cd              write (2,'(3(2f10.5),5x)')
10382 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10383 cd            enddo
10384 cd          endif
10385           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10386      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10387 cd          if (lprn) then
10388 cd            write (2,*) 'lll=',lll
10389 cd            write (2,*) 'iii=2'
10390 cd            do jjj=1,2
10391 cd              write (2,'(3(2f10.5),5x)')
10392 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10393 cd            enddo
10394 cd          endif
10395         enddo
10396       enddo
10397       return
10398       end
10399 C---------------------------------------------------------------------------
10400       double precision function eello4(i,j,k,l,jj,kk)
10401       implicit real*8 (a-h,o-z)
10402       include 'DIMENSIONS'
10403       include 'COMMON.IOUNITS'
10404       include 'COMMON.CHAIN'
10405       include 'COMMON.DERIV'
10406       include 'COMMON.INTERACT'
10407       include 'COMMON.CONTACTS'
10408       include 'COMMON.CONTMAT'
10409       include 'COMMON.CORRMAT'
10410       include 'COMMON.TORSION'
10411       include 'COMMON.VAR'
10412       include 'COMMON.GEO'
10413       double precision pizda(2,2),ggg1(3),ggg2(3)
10414 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10415 cd        eello4=0.0d0
10416 cd        return
10417 cd      endif
10418 cd      print *,'eello4:',i,j,k,l,jj,kk
10419 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10420 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10421 cold      eij=facont_hb(jj,i)
10422 cold      ekl=facont_hb(kk,k)
10423 cold      ekont=eij*ekl
10424       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10425 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10426       gcorr_loc(k-1)=gcorr_loc(k-1)
10427      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10428       if (l.eq.j+1) then
10429         gcorr_loc(l-1)=gcorr_loc(l-1)
10430      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10431 C Al 4/16/16: Derivatives in theta, to be added later.
10432 c#ifdef NEWCORR
10433 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10434 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10435 c#endif
10436       else
10437         gcorr_loc(j-1)=gcorr_loc(j-1)
10438      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10439 c#ifdef NEWCORR
10440 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10441 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10442 c#endif
10443       endif
10444       do iii=1,2
10445         do kkk=1,5
10446           do lll=1,3
10447             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10448      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10449 cd            derx(lll,kkk,iii)=0.0d0
10450           enddo
10451         enddo
10452       enddo
10453 cd      gcorr_loc(l-1)=0.0d0
10454 cd      gcorr_loc(j-1)=0.0d0
10455 cd      gcorr_loc(k-1)=0.0d0
10456 cd      eel4=1.0d0
10457 cd      write (iout,*)'Contacts have occurred for peptide groups',
10458 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10459 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10460       if (j.lt.nres-1) then
10461         j1=j+1
10462         j2=j-1
10463       else
10464         j1=j-1
10465         j2=j-2
10466       endif
10467       if (l.lt.nres-1) then
10468         l1=l+1
10469         l2=l-1
10470       else
10471         l1=l-1
10472         l2=l-2
10473       endif
10474       do ll=1,3
10475 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10476 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10477         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10478         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10479 cgrad        ghalf=0.5d0*ggg1(ll)
10480         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10481         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10482         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10483         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10484         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10485         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10486 cgrad        ghalf=0.5d0*ggg2(ll)
10487         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10488         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10489         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10490         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10491         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10492         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10493       enddo
10494 cgrad      do m=i+1,j-1
10495 cgrad        do ll=1,3
10496 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10497 cgrad        enddo
10498 cgrad      enddo
10499 cgrad      do m=k+1,l-1
10500 cgrad        do ll=1,3
10501 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10502 cgrad        enddo
10503 cgrad      enddo
10504 cgrad      do m=i+2,j2
10505 cgrad        do ll=1,3
10506 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10507 cgrad        enddo
10508 cgrad      enddo
10509 cgrad      do m=k+2,l2
10510 cgrad        do ll=1,3
10511 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10512 cgrad        enddo
10513 cgrad      enddo
10514 cd      do iii=1,nres-3
10515 cd        write (2,*) iii,gcorr_loc(iii)
10516 cd      enddo
10517       eello4=ekont*eel4
10518 cd      write (2,*) 'ekont',ekont
10519 cd      write (iout,*) 'eello4',ekont*eel4
10520       return
10521       end
10522 C---------------------------------------------------------------------------
10523       double precision function eello5(i,j,k,l,jj,kk)
10524       implicit real*8 (a-h,o-z)
10525       include 'DIMENSIONS'
10526       include 'COMMON.IOUNITS'
10527       include 'COMMON.CHAIN'
10528       include 'COMMON.DERIV'
10529       include 'COMMON.INTERACT'
10530       include 'COMMON.CONTACTS'
10531       include 'COMMON.CONTMAT'
10532       include 'COMMON.CORRMAT'
10533       include 'COMMON.TORSION'
10534       include 'COMMON.VAR'
10535       include 'COMMON.GEO'
10536       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10537       double precision ggg1(3),ggg2(3)
10538 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10539 C                                                                              C
10540 C                            Parallel chains                                   C
10541 C                                                                              C
10542 C          o             o                   o             o                   C
10543 C         /l\           / \             \   / \           / \   /              C
10544 C        /   \         /   \             \ /   \         /   \ /               C
10545 C       j| o |l1       | o |              o| o |         | o |o                C
10546 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10547 C      \i/   \         /   \ /             /   \         /   \                 C
10548 C       o    k1             o                                                  C
10549 C         (I)          (II)                (III)          (IV)                 C
10550 C                                                                              C
10551 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10552 C                                                                              C
10553 C                            Antiparallel chains                               C
10554 C                                                                              C
10555 C          o             o                   o             o                   C
10556 C         /j\           / \             \   / \           / \   /              C
10557 C        /   \         /   \             \ /   \         /   \ /               C
10558 C      j1| o |l        | o |              o| o |         | o |o                C
10559 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10560 C      \i/   \         /   \ /             /   \         /   \                 C
10561 C       o     k1            o                                                  C
10562 C         (I)          (II)                (III)          (IV)                 C
10563 C                                                                              C
10564 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10565 C                                                                              C
10566 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10567 C                                                                              C
10568 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10569 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10570 cd        eello5=0.0d0
10571 cd        return
10572 cd      endif
10573 cd      write (iout,*)
10574 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10575 cd     &   ' and',k,l
10576       itk=itype2loc(itype(k))
10577       itl=itype2loc(itype(l))
10578       itj=itype2loc(itype(j))
10579       eello5_1=0.0d0
10580       eello5_2=0.0d0
10581       eello5_3=0.0d0
10582       eello5_4=0.0d0
10583 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10584 cd     &   eel5_3_num,eel5_4_num)
10585       do iii=1,2
10586         do kkk=1,5
10587           do lll=1,3
10588             derx(lll,kkk,iii)=0.0d0
10589           enddo
10590         enddo
10591       enddo
10592 cd      eij=facont_hb(jj,i)
10593 cd      ekl=facont_hb(kk,k)
10594 cd      ekont=eij*ekl
10595 cd      write (iout,*)'Contacts have occurred for peptide groups',
10596 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10597 cd      goto 1111
10598 C Contribution from the graph I.
10599 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10600 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10601       call transpose2(EUg(1,1,k),auxmat(1,1))
10602       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10603       vv(1)=pizda(1,1)-pizda(2,2)
10604       vv(2)=pizda(1,2)+pizda(2,1)
10605       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10606      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10607 C Explicit gradient in virtual-dihedral angles.
10608       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10609      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10610      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10611       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10612       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10613       vv(1)=pizda(1,1)-pizda(2,2)
10614       vv(2)=pizda(1,2)+pizda(2,1)
10615       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10616      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10617      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10618       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10619       vv(1)=pizda(1,1)-pizda(2,2)
10620       vv(2)=pizda(1,2)+pizda(2,1)
10621       if (l.eq.j+1) then
10622         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10623      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10624      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10625       else
10626         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10627      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10628      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10629       endif
10630 C Cartesian gradient
10631       do iii=1,2
10632         do kkk=1,5
10633           do lll=1,3
10634             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10635      &        pizda(1,1))
10636             vv(1)=pizda(1,1)-pizda(2,2)
10637             vv(2)=pizda(1,2)+pizda(2,1)
10638             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10639      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10640      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10641           enddo
10642         enddo
10643       enddo
10644 c      goto 1112
10645 c1111  continue
10646 C Contribution from graph II
10647       call transpose2(EE(1,1,k),auxmat(1,1))
10648       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10649       vv(1)=pizda(1,1)+pizda(2,2)
10650       vv(2)=pizda(2,1)-pizda(1,2)
10651       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10652      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10653 C Explicit gradient in virtual-dihedral angles.
10654       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10655      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10656       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10657       vv(1)=pizda(1,1)+pizda(2,2)
10658       vv(2)=pizda(2,1)-pizda(1,2)
10659       if (l.eq.j+1) then
10660         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10661      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10662      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10663       else
10664         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10665      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10666      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10667       endif
10668 C Cartesian gradient
10669       do iii=1,2
10670         do kkk=1,5
10671           do lll=1,3
10672             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10673      &        pizda(1,1))
10674             vv(1)=pizda(1,1)+pizda(2,2)
10675             vv(2)=pizda(2,1)-pizda(1,2)
10676             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10677      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10678      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10679           enddo
10680         enddo
10681       enddo
10682 cd      goto 1112
10683 cd1111  continue
10684       if (l.eq.j+1) then
10685 cd        goto 1110
10686 C Parallel orientation
10687 C Contribution from graph III
10688         call transpose2(EUg(1,1,l),auxmat(1,1))
10689         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10690         vv(1)=pizda(1,1)-pizda(2,2)
10691         vv(2)=pizda(1,2)+pizda(2,1)
10692         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10693      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10694 C Explicit gradient in virtual-dihedral angles.
10695         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10696      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10697      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10698         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10699         vv(1)=pizda(1,1)-pizda(2,2)
10700         vv(2)=pizda(1,2)+pizda(2,1)
10701         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10702      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10703      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10704         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10705         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10706         vv(1)=pizda(1,1)-pizda(2,2)
10707         vv(2)=pizda(1,2)+pizda(2,1)
10708         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10709      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10710      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10711 C Cartesian gradient
10712         do iii=1,2
10713           do kkk=1,5
10714             do lll=1,3
10715               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10716      &          pizda(1,1))
10717               vv(1)=pizda(1,1)-pizda(2,2)
10718               vv(2)=pizda(1,2)+pizda(2,1)
10719               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10720      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10721      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10722             enddo
10723           enddo
10724         enddo
10725 cd        goto 1112
10726 C Contribution from graph IV
10727 cd1110    continue
10728         call transpose2(EE(1,1,l),auxmat(1,1))
10729         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10730         vv(1)=pizda(1,1)+pizda(2,2)
10731         vv(2)=pizda(2,1)-pizda(1,2)
10732         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10733      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10734 C Explicit gradient in virtual-dihedral angles.
10735         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10736      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10737         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10738         vv(1)=pizda(1,1)+pizda(2,2)
10739         vv(2)=pizda(2,1)-pizda(1,2)
10740         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10741      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10742      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10743 C Cartesian gradient
10744         do iii=1,2
10745           do kkk=1,5
10746             do lll=1,3
10747               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10748      &          pizda(1,1))
10749               vv(1)=pizda(1,1)+pizda(2,2)
10750               vv(2)=pizda(2,1)-pizda(1,2)
10751               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10752      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10753      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10754             enddo
10755           enddo
10756         enddo
10757       else
10758 C Antiparallel orientation
10759 C Contribution from graph III
10760 c        goto 1110
10761         call transpose2(EUg(1,1,j),auxmat(1,1))
10762         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10763         vv(1)=pizda(1,1)-pizda(2,2)
10764         vv(2)=pizda(1,2)+pizda(2,1)
10765         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10766      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10767 C Explicit gradient in virtual-dihedral angles.
10768         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10769      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10770      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10771         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10772         vv(1)=pizda(1,1)-pizda(2,2)
10773         vv(2)=pizda(1,2)+pizda(2,1)
10774         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10775      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10776      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10777         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10778         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10779         vv(1)=pizda(1,1)-pizda(2,2)
10780         vv(2)=pizda(1,2)+pizda(2,1)
10781         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10782      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10783      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10784 C Cartesian gradient
10785         do iii=1,2
10786           do kkk=1,5
10787             do lll=1,3
10788               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10789      &          pizda(1,1))
10790               vv(1)=pizda(1,1)-pizda(2,2)
10791               vv(2)=pizda(1,2)+pizda(2,1)
10792               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10793      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10794      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10795             enddo
10796           enddo
10797         enddo
10798 cd        goto 1112
10799 C Contribution from graph IV
10800 1110    continue
10801         call transpose2(EE(1,1,j),auxmat(1,1))
10802         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10803         vv(1)=pizda(1,1)+pizda(2,2)
10804         vv(2)=pizda(2,1)-pizda(1,2)
10805         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10806      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10807 C Explicit gradient in virtual-dihedral angles.
10808         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10809      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10810         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10811         vv(1)=pizda(1,1)+pizda(2,2)
10812         vv(2)=pizda(2,1)-pizda(1,2)
10813         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10814      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10815      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10816 C Cartesian gradient
10817         do iii=1,2
10818           do kkk=1,5
10819             do lll=1,3
10820               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10821      &          pizda(1,1))
10822               vv(1)=pizda(1,1)+pizda(2,2)
10823               vv(2)=pizda(2,1)-pizda(1,2)
10824               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10825      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10826      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10827             enddo
10828           enddo
10829         enddo
10830       endif
10831 1112  continue
10832       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10833 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10834 cd        write (2,*) 'ijkl',i,j,k,l
10835 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10836 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10837 cd      endif
10838 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10839 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10840 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10841 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10842       if (j.lt.nres-1) then
10843         j1=j+1
10844         j2=j-1
10845       else
10846         j1=j-1
10847         j2=j-2
10848       endif
10849       if (l.lt.nres-1) then
10850         l1=l+1
10851         l2=l-1
10852       else
10853         l1=l-1
10854         l2=l-2
10855       endif
10856 cd      eij=1.0d0
10857 cd      ekl=1.0d0
10858 cd      ekont=1.0d0
10859 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10860 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10861 C        summed up outside the subrouine as for the other subroutines
10862 C        handling long-range interactions. The old code is commented out
10863 C        with "cgrad" to keep track of changes.
10864       do ll=1,3
10865 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10866 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10867         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10868         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10869 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10870 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10871 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10872 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10873 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10874 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10875 c     &   gradcorr5ij,
10876 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10877 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10878 cgrad        ghalf=0.5d0*ggg1(ll)
10879 cd        ghalf=0.0d0
10880         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10881         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10882         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10883         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10884         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10885         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10886 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10887 cgrad        ghalf=0.5d0*ggg2(ll)
10888 cd        ghalf=0.0d0
10889         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10890         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10891         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10892         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10893         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10894         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10895       enddo
10896 cd      goto 1112
10897 cgrad      do m=i+1,j-1
10898 cgrad        do ll=1,3
10899 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10900 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10901 cgrad        enddo
10902 cgrad      enddo
10903 cgrad      do m=k+1,l-1
10904 cgrad        do ll=1,3
10905 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10906 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10907 cgrad        enddo
10908 cgrad      enddo
10909 c1112  continue
10910 cgrad      do m=i+2,j2
10911 cgrad        do ll=1,3
10912 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10913 cgrad        enddo
10914 cgrad      enddo
10915 cgrad      do m=k+2,l2
10916 cgrad        do ll=1,3
10917 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10918 cgrad        enddo
10919 cgrad      enddo
10920 cd      do iii=1,nres-3
10921 cd        write (2,*) iii,g_corr5_loc(iii)
10922 cd      enddo
10923       eello5=ekont*eel5
10924 cd      write (2,*) 'ekont',ekont
10925 cd      write (iout,*) 'eello5',ekont*eel5
10926       return
10927       end
10928 c--------------------------------------------------------------------------
10929       double precision function eello6(i,j,k,l,jj,kk)
10930       implicit real*8 (a-h,o-z)
10931       include 'DIMENSIONS'
10932       include 'COMMON.IOUNITS'
10933       include 'COMMON.CHAIN'
10934       include 'COMMON.DERIV'
10935       include 'COMMON.INTERACT'
10936       include 'COMMON.CONTACTS'
10937       include 'COMMON.CONTMAT'
10938       include 'COMMON.CORRMAT'
10939       include 'COMMON.TORSION'
10940       include 'COMMON.VAR'
10941       include 'COMMON.GEO'
10942       include 'COMMON.FFIELD'
10943       double precision ggg1(3),ggg2(3)
10944 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10945 cd        eello6=0.0d0
10946 cd        return
10947 cd      endif
10948 cd      write (iout,*)
10949 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10950 cd     &   ' and',k,l
10951       eello6_1=0.0d0
10952       eello6_2=0.0d0
10953       eello6_3=0.0d0
10954       eello6_4=0.0d0
10955       eello6_5=0.0d0
10956       eello6_6=0.0d0
10957 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10958 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10959       do iii=1,2
10960         do kkk=1,5
10961           do lll=1,3
10962             derx(lll,kkk,iii)=0.0d0
10963           enddo
10964         enddo
10965       enddo
10966 cd      eij=facont_hb(jj,i)
10967 cd      ekl=facont_hb(kk,k)
10968 cd      ekont=eij*ekl
10969 cd      eij=1.0d0
10970 cd      ekl=1.0d0
10971 cd      ekont=1.0d0
10972       if (l.eq.j+1) then
10973         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10974         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10975         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10976         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10977         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10978         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10979       else
10980         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10981         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10982         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10983         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10984         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10985           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10986         else
10987           eello6_5=0.0d0
10988         endif
10989         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10990       endif
10991 C If turn contributions are considered, they will be handled separately.
10992       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10993 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10994 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10995 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10996 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10997 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10998 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10999 cd      goto 1112
11000       if (j.lt.nres-1) then
11001         j1=j+1
11002         j2=j-1
11003       else
11004         j1=j-1
11005         j2=j-2
11006       endif
11007       if (l.lt.nres-1) then
11008         l1=l+1
11009         l2=l-1
11010       else
11011         l1=l-1
11012         l2=l-2
11013       endif
11014       do ll=1,3
11015 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
11016 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
11017 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
11018 cgrad        ghalf=0.5d0*ggg1(ll)
11019 cd        ghalf=0.0d0
11020         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
11021         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
11022         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
11023         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
11024         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
11025         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
11026         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
11027         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
11028 cgrad        ghalf=0.5d0*ggg2(ll)
11029 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
11030 cd        ghalf=0.0d0
11031         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
11032         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
11033         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
11034         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
11035         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
11036         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
11037       enddo
11038 cd      goto 1112
11039 cgrad      do m=i+1,j-1
11040 cgrad        do ll=1,3
11041 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
11042 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
11043 cgrad        enddo
11044 cgrad      enddo
11045 cgrad      do m=k+1,l-1
11046 cgrad        do ll=1,3
11047 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
11048 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
11049 cgrad        enddo
11050 cgrad      enddo
11051 cgrad1112  continue
11052 cgrad      do m=i+2,j2
11053 cgrad        do ll=1,3
11054 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
11055 cgrad        enddo
11056 cgrad      enddo
11057 cgrad      do m=k+2,l2
11058 cgrad        do ll=1,3
11059 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
11060 cgrad        enddo
11061 cgrad      enddo
11062 cd      do iii=1,nres-3
11063 cd        write (2,*) iii,g_corr6_loc(iii)
11064 cd      enddo
11065       eello6=ekont*eel6
11066 cd      write (2,*) 'ekont',ekont
11067 cd      write (iout,*) 'eello6',ekont*eel6
11068       return
11069       end
11070 c--------------------------------------------------------------------------
11071       double precision function eello6_graph1(i,j,k,l,imat,swap)
11072       implicit real*8 (a-h,o-z)
11073       include 'DIMENSIONS'
11074       include 'COMMON.IOUNITS'
11075       include 'COMMON.CHAIN'
11076       include 'COMMON.DERIV'
11077       include 'COMMON.INTERACT'
11078       include 'COMMON.CONTACTS'
11079       include 'COMMON.CONTMAT'
11080       include 'COMMON.CORRMAT'
11081       include 'COMMON.TORSION'
11082       include 'COMMON.VAR'
11083       include 'COMMON.GEO'
11084       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11085       logical swap
11086       logical lprn
11087       common /kutas/ lprn
11088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11089 C                                                                              C
11090 C      Parallel       Antiparallel                                             C
11091 C                                                                              C
11092 C          o             o                                                     C
11093 C         /l\           /j\                                                    C
11094 C        /   \         /   \                                                   C
11095 C       /| o |         | o |\                                                  C
11096 C     \ j|/k\|  /   \  |/k\|l /                                                C
11097 C      \ /   \ /     \ /   \ /                                                 C
11098 C       o     o       o     o                                                  C
11099 C       i             i                                                        C
11100 C                                                                              C
11101 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11102       itk=itype2loc(itype(k))
11103       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11104       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11105       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11106       call transpose2(EUgC(1,1,k),auxmat(1,1))
11107       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11108       vv1(1)=pizda1(1,1)-pizda1(2,2)
11109       vv1(2)=pizda1(1,2)+pizda1(2,1)
11110       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11111       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11112       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11113       s5=scalar2(vv(1),Dtobr2(1,i))
11114 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11115       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11116       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11117      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11118      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11119      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11120      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11121      & +scalar2(vv(1),Dtobr2der(1,i)))
11122       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11123       vv1(1)=pizda1(1,1)-pizda1(2,2)
11124       vv1(2)=pizda1(1,2)+pizda1(2,1)
11125       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11126       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11127       if (l.eq.j+1) then
11128         g_corr6_loc(l-1)=g_corr6_loc(l-1)
11129      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11130      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11131      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11132      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11133       else
11134         g_corr6_loc(j-1)=g_corr6_loc(j-1)
11135      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11136      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11137      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11138      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11139       endif
11140       call transpose2(EUgCder(1,1,k),auxmat(1,1))
11141       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11142       vv1(1)=pizda1(1,1)-pizda1(2,2)
11143       vv1(2)=pizda1(1,2)+pizda1(2,1)
11144       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11145      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11146      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11147      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11148       do iii=1,2
11149         if (swap) then
11150           ind=3-iii
11151         else
11152           ind=iii
11153         endif
11154         do kkk=1,5
11155           do lll=1,3
11156             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11157             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11158             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11159             call transpose2(EUgC(1,1,k),auxmat(1,1))
11160             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11161      &        pizda1(1,1))
11162             vv1(1)=pizda1(1,1)-pizda1(2,2)
11163             vv1(2)=pizda1(1,2)+pizda1(2,1)
11164             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11165             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11166      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11167             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11168      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11169             s5=scalar2(vv(1),Dtobr2(1,i))
11170             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11171           enddo
11172         enddo
11173       enddo
11174       return
11175       end
11176 c----------------------------------------------------------------------------
11177       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11178       implicit real*8 (a-h,o-z)
11179       include 'DIMENSIONS'
11180       include 'COMMON.IOUNITS'
11181       include 'COMMON.CHAIN'
11182       include 'COMMON.DERIV'
11183       include 'COMMON.INTERACT'
11184       include 'COMMON.CONTACTS'
11185       include 'COMMON.CONTMAT'
11186       include 'COMMON.CORRMAT'
11187       include 'COMMON.TORSION'
11188       include 'COMMON.VAR'
11189       include 'COMMON.GEO'
11190       logical swap
11191       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11192      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11193       logical lprn
11194       common /kutas/ lprn
11195 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11196 C                                                                              C
11197 C      Parallel       Antiparallel                                             C
11198 C                                                                              C
11199 C          o             o                                                     C
11200 C     \   /l\           /j\   /                                                C
11201 C      \ /   \         /   \ /                                                 C
11202 C       o| o |         | o |o                                                  C
11203 C     \ j|/k\|      \  |/k\|l                                                  C
11204 C      \ /   \       \ /   \                                                   C
11205 C       o             o                                                        C
11206 C       i             i                                                        C
11207 C                                                                              C
11208 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11209 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11210 C AL 7/4/01 s1 would occur in the sixth-order moment,
11211 C           but not in a cluster cumulant
11212 #ifdef MOMENT
11213       s1=dip(1,jj,i)*dip(1,kk,k)
11214 #endif
11215       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11216       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11217       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11218       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11219       call transpose2(EUg(1,1,k),auxmat(1,1))
11220       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11221       vv(1)=pizda(1,1)-pizda(2,2)
11222       vv(2)=pizda(1,2)+pizda(2,1)
11223       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11224 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11225 #ifdef MOMENT
11226       eello6_graph2=-(s1+s2+s3+s4)
11227 #else
11228       eello6_graph2=-(s2+s3+s4)
11229 #endif
11230 c      eello6_graph2=-s3
11231 C Derivatives in gamma(i-1)
11232       if (i.gt.1) then
11233 #ifdef MOMENT
11234         s1=dipderg(1,jj,i)*dip(1,kk,k)
11235 #endif
11236         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11237         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11238         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11239         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11240 #ifdef MOMENT
11241         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11242 #else
11243         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11244 #endif
11245 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11246       endif
11247 C Derivatives in gamma(k-1)
11248 #ifdef MOMENT
11249       s1=dip(1,jj,i)*dipderg(1,kk,k)
11250 #endif
11251       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11252       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11253       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11254       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11255       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11256       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11257       vv(1)=pizda(1,1)-pizda(2,2)
11258       vv(2)=pizda(1,2)+pizda(2,1)
11259       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11260 #ifdef MOMENT
11261       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11262 #else
11263       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11264 #endif
11265 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11266 C Derivatives in gamma(j-1) or gamma(l-1)
11267       if (j.gt.1) then
11268 #ifdef MOMENT
11269         s1=dipderg(3,jj,i)*dip(1,kk,k)
11270 #endif
11271         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11272         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11273         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11274         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11275         vv(1)=pizda(1,1)-pizda(2,2)
11276         vv(2)=pizda(1,2)+pizda(2,1)
11277         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11278 #ifdef MOMENT
11279         if (swap) then
11280           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11281         else
11282           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11283         endif
11284 #endif
11285         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11286 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11287       endif
11288 C Derivatives in gamma(l-1) or gamma(j-1)
11289       if (l.gt.1) then
11290 #ifdef MOMENT
11291         s1=dip(1,jj,i)*dipderg(3,kk,k)
11292 #endif
11293         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11294         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11295         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11296         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11297         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11298         vv(1)=pizda(1,1)-pizda(2,2)
11299         vv(2)=pizda(1,2)+pizda(2,1)
11300         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11301 #ifdef MOMENT
11302         if (swap) then
11303           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11304         else
11305           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11306         endif
11307 #endif
11308         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11309 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11310       endif
11311 C Cartesian derivatives.
11312       if (lprn) then
11313         write (2,*) 'In eello6_graph2'
11314         do iii=1,2
11315           write (2,*) 'iii=',iii
11316           do kkk=1,5
11317             write (2,*) 'kkk=',kkk
11318             do jjj=1,2
11319               write (2,'(3(2f10.5),5x)')
11320      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11321             enddo
11322           enddo
11323         enddo
11324       endif
11325       do iii=1,2
11326         do kkk=1,5
11327           do lll=1,3
11328 #ifdef MOMENT
11329             if (iii.eq.1) then
11330               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11331             else
11332               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11333             endif
11334 #endif
11335             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11336      &        auxvec(1))
11337             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11338             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11339      &        auxvec(1))
11340             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11341             call transpose2(EUg(1,1,k),auxmat(1,1))
11342             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11343      &        pizda(1,1))
11344             vv(1)=pizda(1,1)-pizda(2,2)
11345             vv(2)=pizda(1,2)+pizda(2,1)
11346             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11347 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11348 #ifdef MOMENT
11349             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11350 #else
11351             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11352 #endif
11353             if (swap) then
11354               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11355             else
11356               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11357             endif
11358           enddo
11359         enddo
11360       enddo
11361       return
11362       end
11363 c----------------------------------------------------------------------------
11364       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11365       implicit real*8 (a-h,o-z)
11366       include 'DIMENSIONS'
11367       include 'COMMON.IOUNITS'
11368       include 'COMMON.CHAIN'
11369       include 'COMMON.DERIV'
11370       include 'COMMON.INTERACT'
11371       include 'COMMON.CONTACTS'
11372       include 'COMMON.CONTMAT'
11373       include 'COMMON.CORRMAT'
11374       include 'COMMON.TORSION'
11375       include 'COMMON.VAR'
11376       include 'COMMON.GEO'
11377       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11378       logical swap
11379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11380 C                                                                              C
11381 C      Parallel       Antiparallel                                             C
11382 C                                                                              C
11383 C          o             o                                                     C
11384 C         /l\   /   \   /j\                                                    C
11385 C        /   \ /     \ /   \                                                   C
11386 C       /| o |o       o| o |\                                                  C
11387 C       j|/k\|  /      |/k\|l /                                                C
11388 C        /   \ /       /   \ /                                                 C
11389 C       /     o       /     o                                                  C
11390 C       i             i                                                        C
11391 C                                                                              C
11392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11393 C
11394 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11395 C           energy moment and not to the cluster cumulant.
11396       iti=itortyp(itype(i))
11397       if (j.lt.nres-1) then
11398         itj1=itype2loc(itype(j+1))
11399       else
11400         itj1=nloctyp
11401       endif
11402       itk=itype2loc(itype(k))
11403       itk1=itype2loc(itype(k+1))
11404       if (l.lt.nres-1) then
11405         itl1=itype2loc(itype(l+1))
11406       else
11407         itl1=nloctyp
11408       endif
11409 #ifdef MOMENT
11410       s1=dip(4,jj,i)*dip(4,kk,k)
11411 #endif
11412       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11413       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11414       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11415       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11416       call transpose2(EE(1,1,k),auxmat(1,1))
11417       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11418       vv(1)=pizda(1,1)+pizda(2,2)
11419       vv(2)=pizda(2,1)-pizda(1,2)
11420       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11421 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11422 cd     & "sum",-(s2+s3+s4)
11423 #ifdef MOMENT
11424       eello6_graph3=-(s1+s2+s3+s4)
11425 #else
11426       eello6_graph3=-(s2+s3+s4)
11427 #endif
11428 c      eello6_graph3=-s4
11429 C Derivatives in gamma(k-1)
11430       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11431       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11432       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11433       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11434 C Derivatives in gamma(l-1)
11435       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11436       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11437       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11438       vv(1)=pizda(1,1)+pizda(2,2)
11439       vv(2)=pizda(2,1)-pizda(1,2)
11440       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11441       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11442 C Cartesian derivatives.
11443       do iii=1,2
11444         do kkk=1,5
11445           do lll=1,3
11446 #ifdef MOMENT
11447             if (iii.eq.1) then
11448               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11449             else
11450               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11451             endif
11452 #endif
11453             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11454      &        auxvec(1))
11455             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11456             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11457      &        auxvec(1))
11458             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11459             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11460      &        pizda(1,1))
11461             vv(1)=pizda(1,1)+pizda(2,2)
11462             vv(2)=pizda(2,1)-pizda(1,2)
11463             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11464 #ifdef MOMENT
11465             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11466 #else
11467             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11468 #endif
11469             if (swap) then
11470               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11471             else
11472               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11473             endif
11474 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11475           enddo
11476         enddo
11477       enddo
11478       return
11479       end
11480 c----------------------------------------------------------------------------
11481       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11482       implicit real*8 (a-h,o-z)
11483       include 'DIMENSIONS'
11484       include 'COMMON.IOUNITS'
11485       include 'COMMON.CHAIN'
11486       include 'COMMON.DERIV'
11487       include 'COMMON.INTERACT'
11488       include 'COMMON.CONTACTS'
11489       include 'COMMON.CONTMAT'
11490       include 'COMMON.CORRMAT'
11491       include 'COMMON.TORSION'
11492       include 'COMMON.VAR'
11493       include 'COMMON.GEO'
11494       include 'COMMON.FFIELD'
11495       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11496      & auxvec1(2),auxmat1(2,2)
11497       logical swap
11498 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11499 C                                                                              C
11500 C      Parallel       Antiparallel                                             C
11501 C                                                                              C
11502 C          o             o                                                     C
11503 C         /l\   /   \   /j\                                                    C
11504 C        /   \ /     \ /   \                                                   C
11505 C       /| o |o       o| o |\                                                  C
11506 C     \ j|/k\|      \  |/k\|l                                                  C
11507 C      \ /   \       \ /   \                                                   C
11508 C       o     \       o     \                                                  C
11509 C       i             i                                                        C
11510 C                                                                              C
11511 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11512 C
11513 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11514 C           energy moment and not to the cluster cumulant.
11515 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11516       iti=itype2loc(itype(i))
11517       itj=itype2loc(itype(j))
11518       if (j.lt.nres-1) then
11519         itj1=itype2loc(itype(j+1))
11520       else
11521         itj1=nloctyp
11522       endif
11523       itk=itype2loc(itype(k))
11524       if (k.lt.nres-1) then
11525         itk1=itype2loc(itype(k+1))
11526       else
11527         itk1=nloctyp
11528       endif
11529       itl=itype2loc(itype(l))
11530       if (l.lt.nres-1) then
11531         itl1=itype2loc(itype(l+1))
11532       else
11533         itl1=nloctyp
11534       endif
11535 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11536 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11537 cd     & ' itl',itl,' itl1',itl1
11538 #ifdef MOMENT
11539       if (imat.eq.1) then
11540         s1=dip(3,jj,i)*dip(3,kk,k)
11541       else
11542         s1=dip(2,jj,j)*dip(2,kk,l)
11543       endif
11544 #endif
11545       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11546       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11547       if (j.eq.l+1) then
11548         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11549         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11550       else
11551         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11552         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11553       endif
11554       call transpose2(EUg(1,1,k),auxmat(1,1))
11555       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11556       vv(1)=pizda(1,1)-pizda(2,2)
11557       vv(2)=pizda(2,1)+pizda(1,2)
11558       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11559 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11560 #ifdef MOMENT
11561       eello6_graph4=-(s1+s2+s3+s4)
11562 #else
11563       eello6_graph4=-(s2+s3+s4)
11564 #endif
11565 C Derivatives in gamma(i-1)
11566       if (i.gt.1) then
11567 #ifdef MOMENT
11568         if (imat.eq.1) then
11569           s1=dipderg(2,jj,i)*dip(3,kk,k)
11570         else
11571           s1=dipderg(4,jj,j)*dip(2,kk,l)
11572         endif
11573 #endif
11574         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11575         if (j.eq.l+1) then
11576           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11577           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11578         else
11579           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11580           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11581         endif
11582         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11583         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11584 cd          write (2,*) 'turn6 derivatives'
11585 #ifdef MOMENT
11586           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11587 #else
11588           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11589 #endif
11590         else
11591 #ifdef MOMENT
11592           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11593 #else
11594           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11595 #endif
11596         endif
11597       endif
11598 C Derivatives in gamma(k-1)
11599 #ifdef MOMENT
11600       if (imat.eq.1) then
11601         s1=dip(3,jj,i)*dipderg(2,kk,k)
11602       else
11603         s1=dip(2,jj,j)*dipderg(4,kk,l)
11604       endif
11605 #endif
11606       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11607       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11608       if (j.eq.l+1) then
11609         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11610         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11611       else
11612         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11613         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11614       endif
11615       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11616       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11617       vv(1)=pizda(1,1)-pizda(2,2)
11618       vv(2)=pizda(2,1)+pizda(1,2)
11619       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11620       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11621 #ifdef MOMENT
11622         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11623 #else
11624         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11625 #endif
11626       else
11627 #ifdef MOMENT
11628         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11629 #else
11630         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11631 #endif
11632       endif
11633 C Derivatives in gamma(j-1) or gamma(l-1)
11634       if (l.eq.j+1 .and. l.gt.1) then
11635         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11636         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11637         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11638         vv(1)=pizda(1,1)-pizda(2,2)
11639         vv(2)=pizda(2,1)+pizda(1,2)
11640         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11641         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11642       else if (j.gt.1) then
11643         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11644         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11645         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11646         vv(1)=pizda(1,1)-pizda(2,2)
11647         vv(2)=pizda(2,1)+pizda(1,2)
11648         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11649         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11650           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11651         else
11652           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11653         endif
11654       endif
11655 C Cartesian derivatives.
11656       do iii=1,2
11657         do kkk=1,5
11658           do lll=1,3
11659 #ifdef MOMENT
11660             if (iii.eq.1) then
11661               if (imat.eq.1) then
11662                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11663               else
11664                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11665               endif
11666             else
11667               if (imat.eq.1) then
11668                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11669               else
11670                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11671               endif
11672             endif
11673 #endif
11674             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11675      &        auxvec(1))
11676             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11677             if (j.eq.l+1) then
11678               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11679      &          b1(1,j+1),auxvec(1))
11680               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11681             else
11682               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11683      &          b1(1,l+1),auxvec(1))
11684               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11685             endif
11686             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11687      &        pizda(1,1))
11688             vv(1)=pizda(1,1)-pizda(2,2)
11689             vv(2)=pizda(2,1)+pizda(1,2)
11690             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11691             if (swap) then
11692               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11693 #ifdef MOMENT
11694                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11695      &             -(s1+s2+s4)
11696 #else
11697                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11698      &             -(s2+s4)
11699 #endif
11700                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11701               else
11702 #ifdef MOMENT
11703                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11704 #else
11705                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11706 #endif
11707                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11708               endif
11709             else
11710 #ifdef MOMENT
11711               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11712 #else
11713               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11714 #endif
11715               if (l.eq.j+1) then
11716                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11717               else
11718                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11719               endif
11720             endif
11721           enddo
11722         enddo
11723       enddo
11724       return
11725       end
11726 c----------------------------------------------------------------------------
11727       double precision function eello_turn6(i,jj,kk)
11728       implicit real*8 (a-h,o-z)
11729       include 'DIMENSIONS'
11730       include 'COMMON.IOUNITS'
11731       include 'COMMON.CHAIN'
11732       include 'COMMON.DERIV'
11733       include 'COMMON.INTERACT'
11734       include 'COMMON.CONTACTS'
11735       include 'COMMON.CONTMAT'
11736       include 'COMMON.CORRMAT'
11737       include 'COMMON.TORSION'
11738       include 'COMMON.VAR'
11739       include 'COMMON.GEO'
11740       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11741      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11742      &  ggg1(3),ggg2(3)
11743       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11744      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11745 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11746 C           the respective energy moment and not to the cluster cumulant.
11747       s1=0.0d0
11748       s8=0.0d0
11749       s13=0.0d0
11750 c
11751       eello_turn6=0.0d0
11752       j=i+4
11753       k=i+1
11754       l=i+3
11755       iti=itype2loc(itype(i))
11756       itk=itype2loc(itype(k))
11757       itk1=itype2loc(itype(k+1))
11758       itl=itype2loc(itype(l))
11759       itj=itype2loc(itype(j))
11760 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11761 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11762 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11763 cd        eello6=0.0d0
11764 cd        return
11765 cd      endif
11766 cd      write (iout,*)
11767 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11768 cd     &   ' and',k,l
11769 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11770       do iii=1,2
11771         do kkk=1,5
11772           do lll=1,3
11773             derx_turn(lll,kkk,iii)=0.0d0
11774           enddo
11775         enddo
11776       enddo
11777 cd      eij=1.0d0
11778 cd      ekl=1.0d0
11779 cd      ekont=1.0d0
11780       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11781 cd      eello6_5=0.0d0
11782 cd      write (2,*) 'eello6_5',eello6_5
11783 #ifdef MOMENT
11784       call transpose2(AEA(1,1,1),auxmat(1,1))
11785       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11786       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11787       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11788 #endif
11789       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11790       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11791       s2 = scalar2(b1(1,k),vtemp1(1))
11792 #ifdef MOMENT
11793       call transpose2(AEA(1,1,2),atemp(1,1))
11794       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11795       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11796       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11797 #endif
11798       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11799       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11800       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11801 #ifdef MOMENT
11802       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11803       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11804       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11805       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11806       ss13 = scalar2(b1(1,k),vtemp4(1))
11807       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11808 #endif
11809 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11810 c      s1=0.0d0
11811 c      s2=0.0d0
11812 c      s8=0.0d0
11813 c      s12=0.0d0
11814 c      s13=0.0d0
11815       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11816 C Derivatives in gamma(i+2)
11817       s1d =0.0d0
11818       s8d =0.0d0
11819 #ifdef MOMENT
11820       call transpose2(AEA(1,1,1),auxmatd(1,1))
11821       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11822       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11823       call transpose2(AEAderg(1,1,2),atempd(1,1))
11824       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11825       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11826 #endif
11827       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11828       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11829       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11830 c      s1d=0.0d0
11831 c      s2d=0.0d0
11832 c      s8d=0.0d0
11833 c      s12d=0.0d0
11834 c      s13d=0.0d0
11835       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11836 C Derivatives in gamma(i+3)
11837 #ifdef MOMENT
11838       call transpose2(AEA(1,1,1),auxmatd(1,1))
11839       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11840       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11841       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11842 #endif
11843       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11844       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11845       s2d = scalar2(b1(1,k),vtemp1d(1))
11846 #ifdef MOMENT
11847       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11848       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11849 #endif
11850       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11851 #ifdef MOMENT
11852       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11853       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11854       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11855 #endif
11856 c      s1d=0.0d0
11857 c      s2d=0.0d0
11858 c      s8d=0.0d0
11859 c      s12d=0.0d0
11860 c      s13d=0.0d0
11861 #ifdef MOMENT
11862       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11863      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11864 #else
11865       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11866      &               -0.5d0*ekont*(s2d+s12d)
11867 #endif
11868 C Derivatives in gamma(i+4)
11869       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11870       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11871       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11872 #ifdef MOMENT
11873       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11874       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11875       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11876 #endif
11877 c      s1d=0.0d0
11878 c      s2d=0.0d0
11879 c      s8d=0.0d0
11880 C      s12d=0.0d0
11881 c      s13d=0.0d0
11882 #ifdef MOMENT
11883       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11884 #else
11885       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11886 #endif
11887 C Derivatives in gamma(i+5)
11888 #ifdef MOMENT
11889       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11890       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11891       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11892 #endif
11893       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11894       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11895       s2d = scalar2(b1(1,k),vtemp1d(1))
11896 #ifdef MOMENT
11897       call transpose2(AEA(1,1,2),atempd(1,1))
11898       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11899       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11900 #endif
11901       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11902       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11903 #ifdef MOMENT
11904       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11905       ss13d = scalar2(b1(1,k),vtemp4d(1))
11906       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11907 #endif
11908 c      s1d=0.0d0
11909 c      s2d=0.0d0
11910 c      s8d=0.0d0
11911 c      s12d=0.0d0
11912 c      s13d=0.0d0
11913 #ifdef MOMENT
11914       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11915      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11916 #else
11917       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11918      &               -0.5d0*ekont*(s2d+s12d)
11919 #endif
11920 C Cartesian derivatives
11921       do iii=1,2
11922         do kkk=1,5
11923           do lll=1,3
11924 #ifdef MOMENT
11925             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11926             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11927             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11928 #endif
11929             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11930             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11931      &          vtemp1d(1))
11932             s2d = scalar2(b1(1,k),vtemp1d(1))
11933 #ifdef MOMENT
11934             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11935             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11936             s8d = -(atempd(1,1)+atempd(2,2))*
11937      &           scalar2(cc(1,1,l),vtemp2(1))
11938 #endif
11939             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11940      &           auxmatd(1,1))
11941             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11942             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11943 c      s1d=0.0d0
11944 c      s2d=0.0d0
11945 c      s8d=0.0d0
11946 c      s12d=0.0d0
11947 c      s13d=0.0d0
11948 #ifdef MOMENT
11949             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11950      &        - 0.5d0*(s1d+s2d)
11951 #else
11952             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11953      &        - 0.5d0*s2d
11954 #endif
11955 #ifdef MOMENT
11956             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11957      &        - 0.5d0*(s8d+s12d)
11958 #else
11959             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11960      &        - 0.5d0*s12d
11961 #endif
11962           enddo
11963         enddo
11964       enddo
11965 #ifdef MOMENT
11966       do kkk=1,5
11967         do lll=1,3
11968           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11969      &      achuj_tempd(1,1))
11970           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11971           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11972           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11973           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11974           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11975      &      vtemp4d(1))
11976           ss13d = scalar2(b1(1,k),vtemp4d(1))
11977           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11978           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11979         enddo
11980       enddo
11981 #endif
11982 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11983 cd     &  16*eel_turn6_num
11984 cd      goto 1112
11985       if (j.lt.nres-1) then
11986         j1=j+1
11987         j2=j-1
11988       else
11989         j1=j-1
11990         j2=j-2
11991       endif
11992       if (l.lt.nres-1) then
11993         l1=l+1
11994         l2=l-1
11995       else
11996         l1=l-1
11997         l2=l-2
11998       endif
11999       do ll=1,3
12000 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
12001 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
12002 cgrad        ghalf=0.5d0*ggg1(ll)
12003 cd        ghalf=0.0d0
12004         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
12005         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
12006         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
12007      &    +ekont*derx_turn(ll,2,1)
12008         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
12009         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
12010      &    +ekont*derx_turn(ll,4,1)
12011         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
12012         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
12013         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
12014 cgrad        ghalf=0.5d0*ggg2(ll)
12015 cd        ghalf=0.0d0
12016         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
12017      &    +ekont*derx_turn(ll,2,2)
12018         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
12019         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
12020      &    +ekont*derx_turn(ll,4,2)
12021         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
12022         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
12023         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
12024       enddo
12025 cd      goto 1112
12026 cgrad      do m=i+1,j-1
12027 cgrad        do ll=1,3
12028 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
12029 cgrad        enddo
12030 cgrad      enddo
12031 cgrad      do m=k+1,l-1
12032 cgrad        do ll=1,3
12033 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
12034 cgrad        enddo
12035 cgrad      enddo
12036 cgrad1112  continue
12037 cgrad      do m=i+2,j2
12038 cgrad        do ll=1,3
12039 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
12040 cgrad        enddo
12041 cgrad      enddo
12042 cgrad      do m=k+2,l2
12043 cgrad        do ll=1,3
12044 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
12045 cgrad        enddo
12046 cgrad      enddo
12047 cd      do iii=1,nres-3
12048 cd        write (2,*) iii,g_corr6_loc(iii)
12049 cd      enddo
12050       eello_turn6=ekont*eel_turn6
12051 cd      write (2,*) 'ekont',ekont
12052 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
12053       return
12054       end
12055 C-----------------------------------------------------------------------------
12056 #endif
12057       double precision function scalar(u,v)
12058 !DIR$ INLINEALWAYS scalar
12059 #ifndef OSF
12060 cDEC$ ATTRIBUTES FORCEINLINE::scalar
12061 #endif
12062       implicit none
12063       double precision u(3),v(3)
12064 cd      double precision sc
12065 cd      integer i
12066 cd      sc=0.0d0
12067 cd      do i=1,3
12068 cd        sc=sc+u(i)*v(i)
12069 cd      enddo
12070 cd      scalar=sc
12071
12072       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12073       return
12074       end
12075 crc-------------------------------------------------
12076       SUBROUTINE MATVEC2(A1,V1,V2)
12077 !DIR$ INLINEALWAYS MATVEC2
12078 #ifndef OSF
12079 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12080 #endif
12081       implicit real*8 (a-h,o-z)
12082       include 'DIMENSIONS'
12083       DIMENSION A1(2,2),V1(2),V2(2)
12084 c      DO 1 I=1,2
12085 c        VI=0.0
12086 c        DO 3 K=1,2
12087 c    3     VI=VI+A1(I,K)*V1(K)
12088 c        Vaux(I)=VI
12089 c    1 CONTINUE
12090
12091       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12092       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12093
12094       v2(1)=vaux1
12095       v2(2)=vaux2
12096       END
12097 C---------------------------------------
12098       SUBROUTINE MATMAT2(A1,A2,A3)
12099 #ifndef OSF
12100 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12101 #endif
12102       implicit real*8 (a-h,o-z)
12103       include 'DIMENSIONS'
12104       DIMENSION A1(2,2),A2(2,2),A3(2,2)
12105 c      DIMENSION AI3(2,2)
12106 c        DO  J=1,2
12107 c          A3IJ=0.0
12108 c          DO K=1,2
12109 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
12110 c          enddo
12111 c          A3(I,J)=A3IJ
12112 c       enddo
12113 c      enddo
12114
12115       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12116       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12117       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12118       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12119
12120       A3(1,1)=AI3_11
12121       A3(2,1)=AI3_21
12122       A3(1,2)=AI3_12
12123       A3(2,2)=AI3_22
12124       END
12125
12126 c-------------------------------------------------------------------------
12127       double precision function scalar2(u,v)
12128 !DIR$ INLINEALWAYS scalar2
12129       implicit none
12130       double precision u(2),v(2)
12131       double precision sc
12132       integer i
12133       scalar2=u(1)*v(1)+u(2)*v(2)
12134       return
12135       end
12136
12137 C-----------------------------------------------------------------------------
12138
12139       subroutine transpose2(a,at)
12140 !DIR$ INLINEALWAYS transpose2
12141 #ifndef OSF
12142 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12143 #endif
12144       implicit none
12145       double precision a(2,2),at(2,2)
12146       at(1,1)=a(1,1)
12147       at(1,2)=a(2,1)
12148       at(2,1)=a(1,2)
12149       at(2,2)=a(2,2)
12150       return
12151       end
12152 c--------------------------------------------------------------------------
12153       subroutine transpose(n,a,at)
12154       implicit none
12155       integer n,i,j
12156       double precision a(n,n),at(n,n)
12157       do i=1,n
12158         do j=1,n
12159           at(j,i)=a(i,j)
12160         enddo
12161       enddo
12162       return
12163       end
12164 C---------------------------------------------------------------------------
12165       subroutine prodmat3(a1,a2,kk,transp,prod)
12166 !DIR$ INLINEALWAYS prodmat3
12167 #ifndef OSF
12168 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12169 #endif
12170       implicit none
12171       integer i,j
12172       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12173       logical transp
12174 crc      double precision auxmat(2,2),prod_(2,2)
12175
12176       if (transp) then
12177 crc        call transpose2(kk(1,1),auxmat(1,1))
12178 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12179 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12180
12181            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12182      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12183            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12184      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12185            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12186      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12187            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12188      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12189
12190       else
12191 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12192 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12193
12194            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12195      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12196            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12197      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12198            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12199      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12200            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12201      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12202
12203       endif
12204 c      call transpose2(a2(1,1),a2t(1,1))
12205
12206 crc      print *,transp
12207 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12208 crc      print *,((prod(i,j),i=1,2),j=1,2)
12209
12210       return
12211       end
12212 CCC----------------------------------------------
12213       subroutine Eliptransfer(eliptran)
12214       implicit real*8 (a-h,o-z)
12215       include 'DIMENSIONS'
12216       include 'COMMON.GEO'
12217       include 'COMMON.VAR'
12218       include 'COMMON.LOCAL'
12219       include 'COMMON.CHAIN'
12220       include 'COMMON.DERIV'
12221       include 'COMMON.NAMES'
12222       include 'COMMON.INTERACT'
12223       include 'COMMON.IOUNITS'
12224       include 'COMMON.CALC'
12225       include 'COMMON.CONTROL'
12226       include 'COMMON.SPLITELE'
12227       include 'COMMON.SBRIDGE'
12228 C this is done by Adasko
12229 C      print *,"wchodze"
12230 C structure of box:
12231 C      water
12232 C--bordliptop-- buffore starts
12233 C--bufliptop--- here true lipid starts
12234 C      lipid
12235 C--buflipbot--- lipid ends buffore starts
12236 C--bordlipbot--buffore ends
12237       eliptran=0.0
12238       do i=ilip_start,ilip_end
12239 C       do i=1,1
12240         if (itype(i).eq.ntyp1) cycle
12241
12242         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12243         if (positi.le.0.0) positi=positi+boxzsize
12244 C        print *,i
12245 C first for peptide groups
12246 c for each residue check if it is in lipid or lipid water border area
12247        if ((positi.gt.bordlipbot)
12248      &.and.(positi.lt.bordliptop)) then
12249 C the energy transfer exist
12250         if (positi.lt.buflipbot) then
12251 C what fraction I am in
12252          fracinbuf=1.0d0-
12253      &        ((positi-bordlipbot)/lipbufthick)
12254 C lipbufthick is thickenes of lipid buffore
12255          sslip=sscalelip(fracinbuf)
12256          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12257          eliptran=eliptran+sslip*pepliptran
12258          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12259          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12260 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12261
12262 C        print *,"doing sccale for lower part"
12263 C         print *,i,sslip,fracinbuf,ssgradlip
12264         elseif (positi.gt.bufliptop) then
12265          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12266          sslip=sscalelip(fracinbuf)
12267          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12268          eliptran=eliptran+sslip*pepliptran
12269          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12270          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12271 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12272 C          print *, "doing sscalefor top part"
12273 C         print *,i,sslip,fracinbuf,ssgradlip
12274         else
12275          eliptran=eliptran+pepliptran
12276 C         print *,"I am in true lipid"
12277         endif
12278 C       else
12279 C       eliptran=elpitran+0.0 ! I am in water
12280        endif
12281        enddo
12282 C       print *, "nic nie bylo w lipidzie?"
12283 C now multiply all by the peptide group transfer factor
12284 C       eliptran=eliptran*pepliptran
12285 C now the same for side chains
12286 CV       do i=1,1
12287        do i=ilip_start,ilip_end
12288         if (itype(i).eq.ntyp1) cycle
12289         positi=(mod(c(3,i+nres),boxzsize))
12290         if (positi.le.0) positi=positi+boxzsize
12291 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12292 c for each residue check if it is in lipid or lipid water border area
12293 C       respos=mod(c(3,i+nres),boxzsize)
12294 C       print *,positi,bordlipbot,buflipbot
12295        if ((positi.gt.bordlipbot)
12296      & .and.(positi.lt.bordliptop)) then
12297 C the energy transfer exist
12298         if (positi.lt.buflipbot) then
12299          fracinbuf=1.0d0-
12300      &     ((positi-bordlipbot)/lipbufthick)
12301 C lipbufthick is thickenes of lipid buffore
12302          sslip=sscalelip(fracinbuf)
12303          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12304          eliptran=eliptran+sslip*liptranene(itype(i))
12305          gliptranx(3,i)=gliptranx(3,i)
12306      &+ssgradlip*liptranene(itype(i))
12307          gliptranc(3,i-1)= gliptranc(3,i-1)
12308      &+ssgradlip*liptranene(itype(i))
12309 C         print *,"doing sccale for lower part"
12310         elseif (positi.gt.bufliptop) then
12311          fracinbuf=1.0d0-
12312      &((bordliptop-positi)/lipbufthick)
12313          sslip=sscalelip(fracinbuf)
12314          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12315          eliptran=eliptran+sslip*liptranene(itype(i))
12316          gliptranx(3,i)=gliptranx(3,i)
12317      &+ssgradlip*liptranene(itype(i))
12318          gliptranc(3,i-1)= gliptranc(3,i-1)
12319      &+ssgradlip*liptranene(itype(i))
12320 C          print *, "doing sscalefor top part",sslip,fracinbuf
12321         else
12322          eliptran=eliptran+liptranene(itype(i))
12323 C         print *,"I am in true lipid"
12324         endif
12325         endif ! if in lipid or buffor
12326 C       else
12327 C       eliptran=elpitran+0.0 ! I am in water
12328        enddo
12329        return
12330        end
12331 C---------------------------------------------------------
12332 C AFM soubroutine for constant force
12333        subroutine AFMforce(Eafmforce)
12334        implicit real*8 (a-h,o-z)
12335       include 'DIMENSIONS'
12336       include 'COMMON.GEO'
12337       include 'COMMON.VAR'
12338       include 'COMMON.LOCAL'
12339       include 'COMMON.CHAIN'
12340       include 'COMMON.DERIV'
12341       include 'COMMON.NAMES'
12342       include 'COMMON.INTERACT'
12343       include 'COMMON.IOUNITS'
12344       include 'COMMON.CALC'
12345       include 'COMMON.CONTROL'
12346       include 'COMMON.SPLITELE'
12347       include 'COMMON.SBRIDGE'
12348       real*8 diffafm(3)
12349       dist=0.0d0
12350       Eafmforce=0.0d0
12351       do i=1,3
12352       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12353       dist=dist+diffafm(i)**2
12354       enddo
12355       dist=dsqrt(dist)
12356       Eafmforce=-forceAFMconst*(dist-distafminit)
12357       do i=1,3
12358       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12359       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12360       enddo
12361 C      print *,'AFM',Eafmforce
12362       return
12363       end
12364 C---------------------------------------------------------
12365 C AFM subroutine with pseudoconstant velocity
12366        subroutine AFMvel(Eafmforce)
12367        implicit real*8 (a-h,o-z)
12368       include 'DIMENSIONS'
12369       include 'COMMON.GEO'
12370       include 'COMMON.VAR'
12371       include 'COMMON.LOCAL'
12372       include 'COMMON.CHAIN'
12373       include 'COMMON.DERIV'
12374       include 'COMMON.NAMES'
12375       include 'COMMON.INTERACT'
12376       include 'COMMON.IOUNITS'
12377       include 'COMMON.CALC'
12378       include 'COMMON.CONTROL'
12379       include 'COMMON.SPLITELE'
12380       include 'COMMON.SBRIDGE'
12381       real*8 diffafm(3)
12382 C Only for check grad COMMENT if not used for checkgrad
12383 C      totT=3.0d0
12384 C--------------------------------------------------------
12385 C      print *,"wchodze"
12386       dist=0.0d0
12387       Eafmforce=0.0d0
12388       do i=1,3
12389       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12390       dist=dist+diffafm(i)**2
12391       enddo
12392       dist=dsqrt(dist)
12393       Eafmforce=0.5d0*forceAFMconst
12394      & *(distafminit+totTafm*velAFMconst-dist)**2
12395 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12396       do i=1,3
12397       gradafm(i,afmend-1)=-forceAFMconst*
12398      &(distafminit+totTafm*velAFMconst-dist)
12399      &*diffafm(i)/dist
12400       gradafm(i,afmbeg-1)=forceAFMconst*
12401      &(distafminit+totTafm*velAFMconst-dist)
12402      &*diffafm(i)/dist
12403       enddo
12404 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12405       return
12406       end
12407 C-----------------------------------------------------------
12408 C first for shielding is setting of function of side-chains
12409        subroutine set_shield_fac
12410       implicit real*8 (a-h,o-z)
12411       include 'DIMENSIONS'
12412       include 'COMMON.CHAIN'
12413       include 'COMMON.DERIV'
12414       include 'COMMON.IOUNITS'
12415       include 'COMMON.SHIELD'
12416       include 'COMMON.INTERACT'
12417 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12418       double precision div77_81/0.974996043d0/,
12419      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12420
12421 C the vector between center of side_chain and peptide group
12422        double precision pep_side(3),long,side_calf(3),
12423      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12424      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12425 C the line belowe needs to be changed for FGPROC>1
12426       do i=1,nres-1
12427       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12428       ishield_list(i)=0
12429 Cif there two consequtive dummy atoms there is no peptide group between them
12430 C the line below has to be changed for FGPROC>1
12431       VolumeTotal=0.0
12432       do k=1,nres
12433        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12434        dist_pep_side=0.0
12435        dist_side_calf=0.0
12436        do j=1,3
12437 C first lets set vector conecting the ithe side-chain with kth side-chain
12438       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12439 C      pep_side(j)=2.0d0
12440 C and vector conecting the side-chain with its proper calfa
12441       side_calf(j)=c(j,k+nres)-c(j,k)
12442 C      side_calf(j)=2.0d0
12443       pept_group(j)=c(j,i)-c(j,i+1)
12444 C lets have their lenght
12445       dist_pep_side=pep_side(j)**2+dist_pep_side
12446       dist_side_calf=dist_side_calf+side_calf(j)**2
12447       dist_pept_group=dist_pept_group+pept_group(j)**2
12448       enddo
12449        dist_pep_side=dsqrt(dist_pep_side)
12450        dist_pept_group=dsqrt(dist_pept_group)
12451        dist_side_calf=dsqrt(dist_side_calf)
12452       do j=1,3
12453         pep_side_norm(j)=pep_side(j)/dist_pep_side
12454         side_calf_norm(j)=dist_side_calf
12455       enddo
12456 C now sscale fraction
12457        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12458 C       print *,buff_shield,"buff"
12459 C now sscale
12460         if (sh_frac_dist.le.0.0) cycle
12461 C If we reach here it means that this side chain reaches the shielding sphere
12462 C Lets add him to the list for gradient
12463         ishield_list(i)=ishield_list(i)+1
12464 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12465 C this list is essential otherwise problem would be O3
12466         shield_list(ishield_list(i),i)=k
12467 C Lets have the sscale value
12468         if (sh_frac_dist.gt.1.0) then
12469          scale_fac_dist=1.0d0
12470          do j=1,3
12471          sh_frac_dist_grad(j)=0.0d0
12472          enddo
12473         else
12474          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12475      &                   *(2.0*sh_frac_dist-3.0d0)
12476          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12477      &                  /dist_pep_side/buff_shield*0.5
12478 C remember for the final gradient multiply sh_frac_dist_grad(j)
12479 C for side_chain by factor -2 !
12480          do j=1,3
12481          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12482 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12483 C     &                    sh_frac_dist_grad(j)
12484          enddo
12485         endif
12486 C        if ((i.eq.3).and.(k.eq.2)) then
12487 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12488 C     & ,"TU"
12489 C        endif
12490
12491 C this is what is now we have the distance scaling now volume...
12492       short=short_r_sidechain(itype(k))
12493       long=long_r_sidechain(itype(k))
12494       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12495 C now costhet_grad
12496 C       costhet=0.0d0
12497        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12498 C       costhet_fac=0.0d0
12499        do j=1,3
12500          costhet_grad(j)=costhet_fac*pep_side(j)
12501        enddo
12502 C remember for the final gradient multiply costhet_grad(j)
12503 C for side_chain by factor -2 !
12504 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12505 C pep_side0pept_group is vector multiplication
12506       pep_side0pept_group=0.0
12507       do j=1,3
12508       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12509       enddo
12510       cosalfa=(pep_side0pept_group/
12511      & (dist_pep_side*dist_side_calf))
12512       fac_alfa_sin=1.0-cosalfa**2
12513       fac_alfa_sin=dsqrt(fac_alfa_sin)
12514       rkprim=fac_alfa_sin*(long-short)+short
12515 C now costhet_grad
12516        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12517        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12518
12519        do j=1,3
12520          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12521      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12522      &*(long-short)/fac_alfa_sin*cosalfa/
12523      &((dist_pep_side*dist_side_calf))*
12524      &((side_calf(j))-cosalfa*
12525      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12526
12527         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12528      &*(long-short)/fac_alfa_sin*cosalfa
12529      &/((dist_pep_side*dist_side_calf))*
12530      &(pep_side(j)-
12531      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12532        enddo
12533
12534       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12535      &                    /VSolvSphere_div
12536      &                    *wshield
12537 C now the gradient...
12538 C grad_shield is gradient of Calfa for peptide groups
12539 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12540 C     &               costhet,cosphi
12541 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12542 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12543       do j=1,3
12544       grad_shield(j,i)=grad_shield(j,i)
12545 C gradient po skalowaniu
12546      &                +(sh_frac_dist_grad(j)
12547 C  gradient po costhet
12548      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12549      &-scale_fac_dist*(cosphi_grad_long(j))
12550      &/(1.0-cosphi) )*div77_81
12551      &*VofOverlap
12552 C grad_shield_side is Cbeta sidechain gradient
12553       grad_shield_side(j,ishield_list(i),i)=
12554      &        (sh_frac_dist_grad(j)*(-2.0d0)
12555      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12556      &       +scale_fac_dist*(cosphi_grad_long(j))
12557      &        *2.0d0/(1.0-cosphi))
12558      &        *div77_81*VofOverlap
12559
12560        grad_shield_loc(j,ishield_list(i),i)=
12561      &   scale_fac_dist*cosphi_grad_loc(j)
12562      &        *2.0d0/(1.0-cosphi)
12563      &        *div77_81*VofOverlap
12564       enddo
12565       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12566       enddo
12567       fac_shield(i)=VolumeTotal*div77_81+div4_81
12568 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12569       enddo
12570       return
12571       end
12572 C--------------------------------------------------------------------------
12573       double precision function tschebyshev(m,n,x,y)
12574       implicit none
12575       include "DIMENSIONS"
12576       integer i,m,n
12577       double precision x(n),y,yy(0:maxvar),aux
12578 c Tschebyshev polynomial. Note that the first term is omitted
12579 c m=0: the constant term is included
12580 c m=1: the constant term is not included
12581       yy(0)=1.0d0
12582       yy(1)=y
12583       do i=2,n
12584         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12585       enddo
12586       aux=0.0d0
12587       do i=m,n
12588         aux=aux+x(i)*yy(i)
12589       enddo
12590       tschebyshev=aux
12591       return
12592       end
12593 C--------------------------------------------------------------------------
12594       double precision function gradtschebyshev(m,n,x,y)
12595       implicit none
12596       include "DIMENSIONS"
12597       integer i,m,n
12598       double precision x(n+1),y,yy(0:maxvar),aux
12599 c Tschebyshev polynomial. Note that the first term is omitted
12600 c m=0: the constant term is included
12601 c m=1: the constant term is not included
12602       yy(0)=1.0d0
12603       yy(1)=2.0d0*y
12604       do i=2,n
12605         yy(i)=2*y*yy(i-1)-yy(i-2)
12606       enddo
12607       aux=0.0d0
12608       do i=m,n
12609         aux=aux+x(i+1)*yy(i)*(i+1)
12610 C        print *, x(i+1),yy(i),i
12611       enddo
12612       gradtschebyshev=aux
12613       return
12614       end
12615 C------------------------------------------------------------------------
12616 C first for shielding is setting of function of side-chains
12617        subroutine set_shield_fac2
12618       implicit real*8 (a-h,o-z)
12619       include 'DIMENSIONS'
12620       include 'COMMON.CHAIN'
12621       include 'COMMON.DERIV'
12622       include 'COMMON.IOUNITS'
12623       include 'COMMON.SHIELD'
12624       include 'COMMON.INTERACT'
12625 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12626       double precision div77_81/0.974996043d0/,
12627      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12628
12629 C the vector between center of side_chain and peptide group
12630        double precision pep_side(3),long,side_calf(3),
12631      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12632      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12633 C the line belowe needs to be changed for FGPROC>1
12634       do i=1,nres-1
12635       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12636       ishield_list(i)=0
12637 Cif there two consequtive dummy atoms there is no peptide group between them
12638 C the line below has to be changed for FGPROC>1
12639       VolumeTotal=0.0
12640       do k=1,nres
12641        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12642        dist_pep_side=0.0
12643        dist_side_calf=0.0
12644        do j=1,3
12645 C first lets set vector conecting the ithe side-chain with kth side-chain
12646       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12647 C      pep_side(j)=2.0d0
12648 C and vector conecting the side-chain with its proper calfa
12649       side_calf(j)=c(j,k+nres)-c(j,k)
12650 C      side_calf(j)=2.0d0
12651       pept_group(j)=c(j,i)-c(j,i+1)
12652 C lets have their lenght
12653       dist_pep_side=pep_side(j)**2+dist_pep_side
12654       dist_side_calf=dist_side_calf+side_calf(j)**2
12655       dist_pept_group=dist_pept_group+pept_group(j)**2
12656       enddo
12657        dist_pep_side=dsqrt(dist_pep_side)
12658        dist_pept_group=dsqrt(dist_pept_group)
12659        dist_side_calf=dsqrt(dist_side_calf)
12660       do j=1,3
12661         pep_side_norm(j)=pep_side(j)/dist_pep_side
12662         side_calf_norm(j)=dist_side_calf
12663       enddo
12664 C now sscale fraction
12665        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12666 C       print *,buff_shield,"buff"
12667 C now sscale
12668         if (sh_frac_dist.le.0.0) cycle
12669 C If we reach here it means that this side chain reaches the shielding sphere
12670 C Lets add him to the list for gradient
12671         ishield_list(i)=ishield_list(i)+1
12672 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12673 C this list is essential otherwise problem would be O3
12674         shield_list(ishield_list(i),i)=k
12675 C Lets have the sscale value
12676         if (sh_frac_dist.gt.1.0) then
12677          scale_fac_dist=1.0d0
12678          do j=1,3
12679          sh_frac_dist_grad(j)=0.0d0
12680          enddo
12681         else
12682          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12683      &                   *(2.0d0*sh_frac_dist-3.0d0)
12684          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12685      &                  /dist_pep_side/buff_shield*0.5d0
12686 C remember for the final gradient multiply sh_frac_dist_grad(j)
12687 C for side_chain by factor -2 !
12688          do j=1,3
12689          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12690 C         sh_frac_dist_grad(j)=0.0d0
12691 C         scale_fac_dist=1.0d0
12692 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12693 C     &                    sh_frac_dist_grad(j)
12694          enddo
12695         endif
12696 C this is what is now we have the distance scaling now volume...
12697       short=short_r_sidechain(itype(k))
12698       long=long_r_sidechain(itype(k))
12699       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12700       sinthet=short/dist_pep_side*costhet
12701 C now costhet_grad
12702 C       costhet=0.6d0
12703 C       sinthet=0.8
12704        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12705 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12706 C     &             -short/dist_pep_side**2/costhet)
12707 C       costhet_fac=0.0d0
12708        do j=1,3
12709          costhet_grad(j)=costhet_fac*pep_side(j)
12710        enddo
12711 C remember for the final gradient multiply costhet_grad(j)
12712 C for side_chain by factor -2 !
12713 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12714 C pep_side0pept_group is vector multiplication
12715       pep_side0pept_group=0.0d0
12716       do j=1,3
12717       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12718       enddo
12719       cosalfa=(pep_side0pept_group/
12720      & (dist_pep_side*dist_side_calf))
12721       fac_alfa_sin=1.0d0-cosalfa**2
12722       fac_alfa_sin=dsqrt(fac_alfa_sin)
12723       rkprim=fac_alfa_sin*(long-short)+short
12724 C      rkprim=short
12725
12726 C now costhet_grad
12727        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12728 C       cosphi=0.6
12729        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12730        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12731      &      dist_pep_side**2)
12732 C       sinphi=0.8
12733        do j=1,3
12734          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12735      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12736      &*(long-short)/fac_alfa_sin*cosalfa/
12737      &((dist_pep_side*dist_side_calf))*
12738      &((side_calf(j))-cosalfa*
12739      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12740 C       cosphi_grad_long(j)=0.0d0
12741         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12742      &*(long-short)/fac_alfa_sin*cosalfa
12743      &/((dist_pep_side*dist_side_calf))*
12744      &(pep_side(j)-
12745      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12746 C       cosphi_grad_loc(j)=0.0d0
12747        enddo
12748 C      print *,sinphi,sinthet
12749 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12750 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12751       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12752      &                    /VSolvSphere_div
12753 C     &                    *wshield
12754 C now the gradient...
12755       do j=1,3
12756       grad_shield(j,i)=grad_shield(j,i)
12757 C gradient po skalowaniu
12758      &                +(sh_frac_dist_grad(j)*VofOverlap
12759 C  gradient po costhet
12760      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12761      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12762      &       sinphi/sinthet*costhet*costhet_grad(j)
12763      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12764      & )*wshield
12765 C grad_shield_side is Cbeta sidechain gradient
12766       grad_shield_side(j,ishield_list(i),i)=
12767      &        (sh_frac_dist_grad(j)*(-2.0d0)
12768      &        *VofOverlap
12769      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12770      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12771      &       sinphi/sinthet*costhet*costhet_grad(j)
12772      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12773      &       )*wshield
12774
12775        grad_shield_loc(j,ishield_list(i),i)=
12776      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12777      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12778      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12779      &        ))
12780      &        *wshield
12781       enddo
12782 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12783 c     & scale_fac_dist
12784       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12785       enddo
12786       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12787 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12788 c     &  " wshield",wshield
12789 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12790       enddo
12791       return
12792       end
12793 C-----------------------------------------------------------------------
12794 C-----------------------------------------------------------
12795 C This subroutine is to mimic the histone like structure but as well can be
12796 C utilizet to nanostructures (infinit) small modification has to be used to
12797 C make it finite (z gradient at the ends has to be changes as well as the x,y
12798 C gradient has to be modified at the ends
12799 C The energy function is Kihara potential
12800 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12801 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12802 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12803 C simple Kihara potential
12804       subroutine calctube(Etube)
12805        implicit real*8 (a-h,o-z)
12806       include 'DIMENSIONS'
12807       include 'COMMON.GEO'
12808       include 'COMMON.VAR'
12809       include 'COMMON.LOCAL'
12810       include 'COMMON.CHAIN'
12811       include 'COMMON.DERIV'
12812       include 'COMMON.NAMES'
12813       include 'COMMON.INTERACT'
12814       include 'COMMON.IOUNITS'
12815       include 'COMMON.CALC'
12816       include 'COMMON.CONTROL'
12817       include 'COMMON.SPLITELE'
12818       include 'COMMON.SBRIDGE'
12819       double precision tub_r,vectube(3),enetube(maxres*2)
12820       Etube=0.0d0
12821       do i=1,2*nres
12822         enetube(i)=0.0d0
12823       enddo
12824 C first we calculate the distance from tube center
12825 C first sugare-phosphate group for NARES this would be peptide group
12826 C for UNRES
12827       do i=1,nres
12828 C lets ommit dummy atoms for now
12829        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12830 C now calculate distance from center of tube and direction vectors
12831       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12832           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12833       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12834           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12835       vectube(1)=vectube(1)-tubecenter(1)
12836       vectube(2)=vectube(2)-tubecenter(2)
12837
12838 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12839 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12840
12841 C as the tube is infinity we do not calculate the Z-vector use of Z
12842 C as chosen axis
12843       vectube(3)=0.0d0
12844 C now calculte the distance
12845        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12846 C now normalize vector
12847       vectube(1)=vectube(1)/tub_r
12848       vectube(2)=vectube(2)/tub_r
12849 C calculte rdiffrence between r and r0
12850       rdiff=tub_r-tubeR0
12851 C and its 6 power
12852       rdiff6=rdiff**6.0d0
12853 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12854        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12855 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12856 C       print *,rdiff,rdiff6,pep_aa_tube
12857 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12858 C now we calculate gradient
12859        fac=(-12.0d0*pep_aa_tube/rdiff6+
12860      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12861 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12862 C     &rdiff,fac
12863
12864 C now direction of gg_tube vector
12865         do j=1,3
12866         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12867         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12868         enddo
12869         enddo
12870 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12871         do i=1,nres
12872 C Lets not jump over memory as we use many times iti
12873          iti=itype(i)
12874 C lets ommit dummy atoms for now
12875          if ((iti.eq.ntyp1)
12876 C in UNRES uncomment the line below as GLY has no side-chain...
12877 C      .or.(iti.eq.10)
12878      &   ) cycle
12879           vectube(1)=c(1,i+nres)
12880           vectube(1)=mod(vectube(1),boxxsize)
12881           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12882           vectube(2)=c(2,i+nres)
12883           vectube(2)=mod(vectube(2),boxxsize)
12884           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12885
12886       vectube(1)=vectube(1)-tubecenter(1)
12887       vectube(2)=vectube(2)-tubecenter(2)
12888
12889 C as the tube is infinity we do not calculate the Z-vector use of Z
12890 C as chosen axis
12891       vectube(3)=0.0d0
12892 C now calculte the distance
12893        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12894 C now normalize vector
12895       vectube(1)=vectube(1)/tub_r
12896       vectube(2)=vectube(2)/tub_r
12897 C calculte rdiffrence between r and r0
12898       rdiff=tub_r-tubeR0
12899 C and its 6 power
12900       rdiff6=rdiff**6.0d0
12901 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12902        sc_aa_tube=sc_aa_tube_par(iti)
12903        sc_bb_tube=sc_bb_tube_par(iti)
12904        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12905 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12906 C now we calculate gradient
12907        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12908      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12909 C now direction of gg_tube vector
12910          do j=1,3
12911           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12912           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12913          enddo
12914         enddo
12915         do i=1,2*nres
12916           Etube=Etube+enetube(i)
12917         enddo
12918 C        print *,"ETUBE", etube
12919         return
12920         end
12921 C TO DO 1) add to total energy
12922 C       2) add to gradient summation
12923 C       3) add reading parameters (AND of course oppening of PARAM file)
12924 C       4) add reading the center of tube
12925 C       5) add COMMONs
12926 C       6) add to zerograd
12927
12928 C-----------------------------------------------------------------------
12929 C-----------------------------------------------------------
12930 C This subroutine is to mimic the histone like structure but as well can be
12931 C utilizet to nanostructures (infinit) small modification has to be used to
12932 C make it finite (z gradient at the ends has to be changes as well as the x,y
12933 C gradient has to be modified at the ends
12934 C The energy function is Kihara potential
12935 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12936 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12937 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12938 C simple Kihara potential
12939       subroutine calctube2(Etube)
12940        implicit real*8 (a-h,o-z)
12941       include 'DIMENSIONS'
12942       include 'COMMON.GEO'
12943       include 'COMMON.VAR'
12944       include 'COMMON.LOCAL'
12945       include 'COMMON.CHAIN'
12946       include 'COMMON.DERIV'
12947       include 'COMMON.NAMES'
12948       include 'COMMON.INTERACT'
12949       include 'COMMON.IOUNITS'
12950       include 'COMMON.CALC'
12951       include 'COMMON.CONTROL'
12952       include 'COMMON.SPLITELE'
12953       include 'COMMON.SBRIDGE'
12954       double precision tub_r,vectube(3),enetube(maxres*2)
12955       Etube=0.0d0
12956       do i=1,2*nres
12957         enetube(i)=0.0d0
12958       enddo
12959 C first we calculate the distance from tube center
12960 C first sugare-phosphate group for NARES this would be peptide group
12961 C for UNRES
12962       do i=1,nres
12963 C lets ommit dummy atoms for now
12964        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12965 C now calculate distance from center of tube and direction vectors
12966       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12967           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12968       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12969           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12970       vectube(1)=vectube(1)-tubecenter(1)
12971       vectube(2)=vectube(2)-tubecenter(2)
12972
12973 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12974 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12975
12976 C as the tube is infinity we do not calculate the Z-vector use of Z
12977 C as chosen axis
12978       vectube(3)=0.0d0
12979 C now calculte the distance
12980        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12981 C now normalize vector
12982       vectube(1)=vectube(1)/tub_r
12983       vectube(2)=vectube(2)/tub_r
12984 C calculte rdiffrence between r and r0
12985       rdiff=tub_r-tubeR0
12986 C and its 6 power
12987       rdiff6=rdiff**6.0d0
12988 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12989        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12990 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12991 C       print *,rdiff,rdiff6,pep_aa_tube
12992 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12993 C now we calculate gradient
12994        fac=(-12.0d0*pep_aa_tube/rdiff6+
12995      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12996 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12997 C     &rdiff,fac
12998
12999 C now direction of gg_tube vector
13000         do j=1,3
13001         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
13002         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
13003         enddo
13004         enddo
13005 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
13006         do i=1,nres
13007 C Lets not jump over memory as we use many times iti
13008          iti=itype(i)
13009 C lets ommit dummy atoms for now
13010          if ((iti.eq.ntyp1)
13011 C in UNRES uncomment the line below as GLY has no side-chain...
13012      &      .or.(iti.eq.10)
13013      &   ) cycle
13014           vectube(1)=c(1,i+nres)
13015           vectube(1)=mod(vectube(1),boxxsize)
13016           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
13017           vectube(2)=c(2,i+nres)
13018           vectube(2)=mod(vectube(2),boxxsize)
13019           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
13020
13021       vectube(1)=vectube(1)-tubecenter(1)
13022       vectube(2)=vectube(2)-tubecenter(2)
13023 C THIS FRAGMENT MAKES TUBE FINITE
13024         positi=(mod(c(3,i+nres),boxzsize))
13025         if (positi.le.0) positi=positi+boxzsize
13026 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
13027 c for each residue check if it is in lipid or lipid water border area
13028 C       respos=mod(c(3,i+nres),boxzsize)
13029        print *,positi,bordtubebot,buftubebot,bordtubetop
13030        if ((positi.gt.bordtubebot)
13031      & .and.(positi.lt.bordtubetop)) then
13032 C the energy transfer exist
13033         if (positi.lt.buftubebot) then
13034          fracinbuf=1.0d0-
13035      &     ((positi-bordtubebot)/tubebufthick)
13036 C lipbufthick is thickenes of lipid buffore
13037          sstube=sscalelip(fracinbuf)
13038          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
13039          print *,ssgradtube, sstube,tubetranene(itype(i))
13040          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13041          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13042      &+ssgradtube*tubetranene(itype(i))
13043          gg_tube(3,i-1)= gg_tube(3,i-1)
13044      &+ssgradtube*tubetranene(itype(i))
13045 C         print *,"doing sccale for lower part"
13046         elseif (positi.gt.buftubetop) then
13047          fracinbuf=1.0d0-
13048      &((bordtubetop-positi)/tubebufthick)
13049          sstube=sscalelip(fracinbuf)
13050          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
13051          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13052 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
13053 C     &+ssgradtube*tubetranene(itype(i))
13054 C         gg_tube(3,i-1)= gg_tube(3,i-1)
13055 C     &+ssgradtube*tubetranene(itype(i))
13056 C          print *, "doing sscalefor top part",sslip,fracinbuf
13057         else
13058          sstube=1.0d0
13059          ssgradtube=0.0d0
13060          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13061 C         print *,"I am in true lipid"
13062         endif
13063         else
13064 C          sstube=0.0d0
13065 C          ssgradtube=0.0d0
13066         cycle
13067         endif ! if in lipid or buffor
13068 CEND OF FINITE FRAGMENT
13069 C as the tube is infinity we do not calculate the Z-vector use of Z
13070 C as chosen axis
13071       vectube(3)=0.0d0
13072 C now calculte the distance
13073        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13074 C now normalize vector
13075       vectube(1)=vectube(1)/tub_r
13076       vectube(2)=vectube(2)/tub_r
13077 C calculte rdiffrence between r and r0
13078       rdiff=tub_r-tubeR0
13079 C and its 6 power
13080       rdiff6=rdiff**6.0d0
13081 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13082        sc_aa_tube=sc_aa_tube_par(iti)
13083        sc_bb_tube=sc_bb_tube_par(iti)
13084        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13085      &                 *sstube+enetube(i+nres)
13086 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13087 C now we calculate gradient
13088        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13089      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13090 C now direction of gg_tube vector
13091          do j=1,3
13092           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13093           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13094          enddo
13095          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13096      &+ssgradtube*enetube(i+nres)/sstube
13097          gg_tube(3,i-1)= gg_tube(3,i-1)
13098      &+ssgradtube*enetube(i+nres)/sstube
13099
13100         enddo
13101         do i=1,2*nres
13102           Etube=Etube+enetube(i)
13103         enddo
13104 C        print *,"ETUBE", etube
13105         return
13106         end
13107 C TO DO 1) add to total energy
13108 C       2) add to gradient summation
13109 C       3) add reading parameters (AND of course oppening of PARAM file)
13110 C       4) add reading the center of tube
13111 C       5) add COMMONs
13112 C       6) add to zerograd
13113 c----------------------------------------------------------------------------
13114       subroutine e_saxs(Esaxs_constr)
13115       implicit none
13116       include 'DIMENSIONS'
13117 #ifdef MPI
13118       include "mpif.h"
13119       include "COMMON.SETUP"
13120       integer IERR
13121 #endif
13122       include 'COMMON.SBRIDGE'
13123       include 'COMMON.CHAIN'
13124       include 'COMMON.GEO'
13125       include 'COMMON.DERIV'
13126       include 'COMMON.LOCAL'
13127       include 'COMMON.INTERACT'
13128       include 'COMMON.VAR'
13129       include 'COMMON.IOUNITS'
13130 c      include 'COMMON.MD'
13131 #ifdef LANG0
13132 #ifdef FIVEDIAG
13133       include 'COMMON.LANGEVIN.lang0.5diag'
13134 #else
13135       include 'COMMON.LANGEVIN.lang0'
13136 #endif
13137 #else
13138       include 'COMMON.LANGEVIN'
13139 #endif
13140       include 'COMMON.CONTROL'
13141       include 'COMMON.SAXS'
13142       include 'COMMON.NAMES'
13143       include 'COMMON.TIME1'
13144       include 'COMMON.FFIELD'
13145 c
13146       double precision Esaxs_constr
13147       integer i,iint,j,k,l
13148       double precision PgradC(maxSAXS,3,maxres),
13149      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13150 #ifdef MPI
13151       double precision PgradC_(maxSAXS,3,maxres),
13152      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13153 #endif
13154       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13155      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13156      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13157      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13158       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13159       double precision dist,mygauss,mygaussder
13160       external dist
13161       integer llicz,lllicz
13162       double precision time01
13163 c  SAXS restraint penalty function
13164 #ifdef DEBUG
13165       write(iout,*) "------- SAXS penalty function start -------"
13166       write (iout,*) "nsaxs",nsaxs
13167       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13168       write (iout,*) "Psaxs"
13169       do i=1,nsaxs
13170         write (iout,'(i5,e15.5)') i, Psaxs(i)
13171       enddo
13172 #endif
13173 #ifdef TIMING
13174       time01=MPI_Wtime()
13175 #endif
13176       Esaxs_constr = 0.0d0
13177       do k=1,nsaxs
13178         Pcalc(k)=0.0d0
13179         do j=1,nres
13180           do l=1,3
13181             PgradC(k,l,j)=0.0d0
13182             PgradX(k,l,j)=0.0d0
13183           enddo
13184         enddo
13185       enddo
13186 c      lllicz=0
13187       do i=iatsc_s,iatsc_e
13188        if (itype(i).eq.ntyp1) cycle
13189        do iint=1,nint_gr(i)
13190          do j=istart(i,iint),iend(i,iint)
13191            if (itype(j).eq.ntyp1) cycle
13192 #ifdef ALLSAXS
13193            dijCACA=dist(i,j)
13194            dijCASC=dist(i,j+nres)
13195            dijSCCA=dist(i+nres,j)
13196            dijSCSC=dist(i+nres,j+nres)
13197            sigma2CACA=2.0d0/(pstok**2)
13198            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13199            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13200            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13201            do k=1,nsaxs
13202              dk = distsaxs(k)
13203              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13204              if (itype(j).ne.10) then
13205              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13206              else
13207              endif
13208              expCASC = 0.0d0
13209              if (itype(i).ne.10) then
13210              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13211              else
13212              expSCCA = 0.0d0
13213              endif
13214              if (itype(i).ne.10 .and. itype(j).ne.10) then
13215              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13216              else
13217              expSCSC = 0.0d0
13218              endif
13219              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13220 #ifdef DEBUG
13221              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13222 #endif
13223              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13224              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13225              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13226              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13227              do l=1,3
13228 c CA CA
13229                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13230                PgradC(k,l,i) = PgradC(k,l,i)-aux
13231                PgradC(k,l,j) = PgradC(k,l,j)+aux
13232 c CA SC
13233                if (itype(j).ne.10) then
13234                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13235                PgradC(k,l,i) = PgradC(k,l,i)-aux
13236                PgradC(k,l,j) = PgradC(k,l,j)+aux
13237                PgradX(k,l,j) = PgradX(k,l,j)+aux
13238                endif
13239 c SC CA
13240                if (itype(i).ne.10) then
13241                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13242                PgradX(k,l,i) = PgradX(k,l,i)-aux
13243                PgradC(k,l,i) = PgradC(k,l,i)-aux
13244                PgradC(k,l,j) = PgradC(k,l,j)+aux
13245                endif
13246 c SC SC
13247                if (itype(i).ne.10 .and. itype(j).ne.10) then
13248                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13249                PgradC(k,l,i) = PgradC(k,l,i)-aux
13250                PgradC(k,l,j) = PgradC(k,l,j)+aux
13251                PgradX(k,l,i) = PgradX(k,l,i)-aux
13252                PgradX(k,l,j) = PgradX(k,l,j)+aux
13253                endif
13254              enddo ! l
13255            enddo ! k
13256 #else
13257            dijCACA=dist(i,j)
13258            sigma2CACA=scal_rad**2*0.25d0/
13259      &        (restok(itype(j))**2+restok(itype(i))**2)
13260 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13261 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13262 #ifdef MYGAUSS
13263            sigmaCACA=dsqrt(sigma2CACA)
13264            threesig=3.0d0/sigmaCACA
13265 c           llicz=0
13266            do k=1,nsaxs
13267              dk = distsaxs(k)
13268              if (dabs(dijCACA-dk).ge.threesig) cycle
13269 c             llicz=llicz+1
13270 c             lllicz=lllicz+1
13271              aux = sigmaCACA*(dijCACA-dk)
13272              expCACA = mygauss(aux)
13273 c             if (expcaca.eq.0.0d0) cycle
13274              Pcalc(k) = Pcalc(k)+expCACA
13275              CACAgrad = -sigmaCACA*mygaussder(aux)
13276 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13277              do l=1,3
13278                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13279                PgradC(k,l,i) = PgradC(k,l,i)-aux
13280                PgradC(k,l,j) = PgradC(k,l,j)+aux
13281              enddo ! l
13282            enddo ! k
13283 c           write (iout,*) "i",i," j",j," llicz",llicz
13284 #else
13285            IF (saxs_cutoff.eq.0) THEN
13286            do k=1,nsaxs
13287              dk = distsaxs(k)
13288              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13289              Pcalc(k) = Pcalc(k)+expCACA
13290              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13291              do l=1,3
13292                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13293                PgradC(k,l,i) = PgradC(k,l,i)-aux
13294                PgradC(k,l,j) = PgradC(k,l,j)+aux
13295              enddo ! l
13296            enddo ! k
13297            ELSE
13298            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13299            do k=1,nsaxs
13300              dk = distsaxs(k)
13301 c             write (2,*) "ijk",i,j,k
13302              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13303              if (sss2.eq.0.0d0) cycle
13304              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13305              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13306      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13307      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13308      &           sss2,ssgrad2
13309              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13310              Pcalc(k) = Pcalc(k)+expCACA
13311 #ifdef DEBUG
13312              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13313 #endif
13314              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13315      &             ssgrad2*expCACA/sss2
13316              do l=1,3
13317 c CA CA
13318                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13319                PgradC(k,l,i) = PgradC(k,l,i)+aux
13320                PgradC(k,l,j) = PgradC(k,l,j)-aux
13321              enddo ! l
13322            enddo ! k
13323            ENDIF
13324 #endif
13325 #endif
13326          enddo ! j
13327        enddo ! iint
13328       enddo ! i
13329 c#ifdef TIMING
13330 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13331 c#endif
13332 c      write (iout,*) "lllicz",lllicz
13333 c#ifdef TIMING
13334 c      time01=MPI_Wtime()
13335 c#endif
13336 #ifdef MPI
13337       if (nfgtasks.gt.1) then
13338        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13339      &    MPI_SUM,FG_COMM,IERR)
13340 c        if (fg_rank.eq.king) then
13341           do k=1,nsaxs
13342             Pcalc(k) = Pcalc_(k)
13343           enddo
13344 c        endif
13345 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13346 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13347 c        if (fg_rank.eq.king) then
13348 c          do i=1,nres
13349 c            do l=1,3
13350 c              do k=1,nsaxs
13351 c                PgradC(k,l,i) = PgradC_(k,l,i)
13352 c              enddo
13353 c            enddo
13354 c          enddo
13355 c        endif
13356 #ifdef ALLSAXS
13357 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13358 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13359 c        if (fg_rank.eq.king) then
13360 c          do i=1,nres
13361 c            do l=1,3
13362 c              do k=1,nsaxs
13363 c                PgradX(k,l,i) = PgradX_(k,l,i)
13364 c              enddo
13365 c            enddo
13366 c          enddo
13367 c        endif
13368 #endif
13369       endif
13370 #endif
13371       Cnorm = 0.0d0
13372       do k=1,nsaxs
13373         Cnorm = Cnorm + Pcalc(k)
13374       enddo
13375 #ifdef MPI
13376       if (fg_rank.eq.king) then
13377 #endif
13378       Esaxs_constr = dlog(Cnorm)-wsaxs0
13379       do k=1,nsaxs
13380         if (Pcalc(k).gt.0.0d0)
13381      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13382 #ifdef DEBUG
13383         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13384 #endif
13385       enddo
13386 #ifdef DEBUG
13387       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13388 #endif
13389 #ifdef MPI
13390       endif
13391 #endif
13392       gsaxsC=0.0d0
13393       gsaxsX=0.0d0
13394       do i=nnt,nct
13395         do l=1,3
13396           auxC=0.0d0
13397           auxC1=0.0d0
13398           auxX=0.0d0
13399           auxX1=0.d0
13400           do k=1,nsaxs
13401             if (Pcalc(k).gt.0)
13402      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13403             auxC1 = auxC1+PgradC(k,l,i)
13404 #ifdef ALLSAXS
13405             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13406             auxX1 = auxX1+PgradX(k,l,i)
13407 #endif
13408           enddo
13409           gsaxsC(l,i) = auxC - auxC1/Cnorm
13410 #ifdef ALLSAXS
13411           gsaxsX(l,i) = auxX - auxX1/Cnorm
13412 #endif
13413 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13414 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13415 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13416 c     *     " gradX",wsaxs*gsaxsX(l,i)
13417         enddo
13418       enddo
13419 #ifdef TIMING
13420       time_SAXS=time_SAXS+MPI_Wtime()-time01
13421 #endif
13422 #ifdef DEBUG
13423       write (iout,*) "gsaxsc"
13424       do i=nnt,nct
13425         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13426       enddo
13427 #endif
13428 #ifdef MPI
13429 c      endif
13430 #endif
13431       return
13432       end
13433 c----------------------------------------------------------------------------
13434       subroutine e_saxsC(Esaxs_constr)
13435       implicit none
13436       include 'DIMENSIONS'
13437 #ifdef MPI
13438       include "mpif.h"
13439       include "COMMON.SETUP"
13440       integer IERR
13441 #endif
13442       include 'COMMON.SBRIDGE'
13443       include 'COMMON.CHAIN'
13444       include 'COMMON.GEO'
13445       include 'COMMON.DERIV'
13446       include 'COMMON.LOCAL'
13447       include 'COMMON.INTERACT'
13448       include 'COMMON.VAR'
13449       include 'COMMON.IOUNITS'
13450 c      include 'COMMON.MD'
13451 #ifdef LANG0
13452 #ifdef FIVEDIAG
13453       include 'COMMON.LANGEVIN.lang0.5diag'
13454 #else
13455       include 'COMMON.LANGEVIN.lang0'
13456 #endif
13457 #else
13458       include 'COMMON.LANGEVIN'
13459 #endif
13460       include 'COMMON.CONTROL'
13461       include 'COMMON.SAXS'
13462       include 'COMMON.NAMES'
13463       include 'COMMON.TIME1'
13464       include 'COMMON.FFIELD'
13465 c
13466       double precision Esaxs_constr
13467       integer i,iint,j,k,l
13468       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13469 #ifdef MPI
13470       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13471 #endif
13472       double precision dk,dijCASPH,dijSCSPH,
13473      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13474      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13475      & auxX,auxX1,Cnorm
13476 c  SAXS restraint penalty function
13477 #ifdef DEBUG
13478       write(iout,*) "------- SAXS penalty function start -------"
13479       write (iout,*) "nsaxs",nsaxs
13480
13481       do i=nnt,nct
13482         print *,MyRank,"C",i,(C(j,i),j=1,3)
13483       enddo
13484       do i=nnt,nct
13485         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13486       enddo
13487 #endif
13488       Esaxs_constr = 0.0d0
13489       logPtot=0.0d0
13490       do j=isaxs_start,isaxs_end
13491         Pcalc=0.0d0
13492         do i=1,nres
13493           do l=1,3
13494             PgradC(l,i)=0.0d0
13495             PgradX(l,i)=0.0d0
13496           enddo
13497         enddo
13498         do i=nnt,nct
13499           if (itype(i).eq.ntyp1) cycle
13500           dijCASPH=0.0d0
13501           dijSCSPH=0.0d0
13502           do l=1,3
13503             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13504           enddo
13505           if (itype(i).ne.10) then
13506           do l=1,3
13507             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13508           enddo
13509           endif
13510           sigma2CA=2.0d0/pstok**2
13511           sigma2SC=4.0d0/restok(itype(i))**2
13512           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13513           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13514           Pcalc = Pcalc+expCASPH+expSCSPH
13515 #ifdef DEBUG
13516           write(*,*) "processor i j Pcalc",
13517      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13518 #endif
13519           CASPHgrad = sigma2CA*expCASPH
13520           SCSPHgrad = sigma2SC*expSCSPH
13521           do l=1,3
13522             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13523             PgradX(l,i) = PgradX(l,i) + aux
13524             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13525           enddo ! l
13526         enddo ! i
13527         do i=nnt,nct
13528           do l=1,3
13529             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13530             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13531           enddo
13532         enddo
13533         logPtot = logPtot - dlog(Pcalc)
13534 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13535 c     &    " logPtot",logPtot
13536       enddo ! j
13537 #ifdef MPI
13538       if (nfgtasks.gt.1) then
13539 c        write (iout,*) "logPtot before reduction",logPtot
13540         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13541      &    MPI_SUM,king,FG_COMM,IERR)
13542         logPtot = logPtot_
13543 c        write (iout,*) "logPtot after reduction",logPtot
13544         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13545      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13546         if (fg_rank.eq.king) then
13547           do i=1,nres
13548             do l=1,3
13549               gsaxsC(l,i) = gsaxsC_(l,i)
13550             enddo
13551           enddo
13552         endif
13553         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13554      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13555         if (fg_rank.eq.king) then
13556           do i=1,nres
13557             do l=1,3
13558               gsaxsX(l,i) = gsaxsX_(l,i)
13559             enddo
13560           enddo
13561         endif
13562       endif
13563 #endif
13564       Esaxs_constr = logPtot
13565       return
13566       end
13567 c----------------------------------------------------------------------------
13568       double precision function sscale2(r,r_cut,r0,rlamb)
13569       implicit none
13570       double precision r,gamm,r_cut,r0,rlamb,rr
13571       rr = dabs(r-r0)
13572 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13573 c      write (2,*) "rr",rr
13574       if(rr.lt.r_cut-rlamb) then
13575         sscale2=1.0d0
13576       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13577         gamm=(rr-(r_cut-rlamb))/rlamb
13578         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13579       else
13580         sscale2=0d0
13581       endif
13582       return
13583       end
13584 C-----------------------------------------------------------------------
13585       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13586       implicit none
13587       double precision r,gamm,r_cut,r0,rlamb,rr
13588       rr = dabs(r-r0)
13589       if(rr.lt.r_cut-rlamb) then
13590         sscalgrad2=0.0d0
13591       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13592         gamm=(rr-(r_cut-rlamb))/rlamb
13593         if (r.ge.r0) then
13594           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13595         else
13596           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13597         endif
13598       else
13599         sscalgrad2=0.0d0
13600       endif
13601       return
13602       end