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

   1       subroutine etotal(energia)
   2       implicit none
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       include 'COMMON.MD'
  34       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  35      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  36      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  37      & eliptran,Eafmforce,Etube,
  38      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  39       integer n_corr,n_corr1
  40 #ifdef MPI
  41 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  42 c     & " nfgtasks",nfgtasks
  43       if (nfgtasks.gt.1) then
  44         time00=MPI_Wtime()
  45 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  46         if (fg_rank.eq.0) then
  47           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  48 c          print *,"Processor",myrank," BROADCAST iorder"
  49 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  50 C FG slaves as WEIGHTS array.
  51           weights_(1)=wsc
  52           weights_(2)=wscp
  53           weights_(3)=welec
  54           weights_(4)=wcorr
  55           weights_(5)=wcorr5
  56           weights_(6)=wcorr6
  57           weights_(7)=wel_loc
  58           weights_(8)=wturn3
  59           weights_(9)=wturn4
  60           weights_(10)=wturn6
  61           weights_(11)=wang
  62           weights_(12)=wscloc
  63           weights_(13)=wtor
  64           weights_(14)=wtor_d
  65           weights_(15)=wstrain
  66           weights_(16)=wvdwpp
  67           weights_(17)=wbond
  68           weights_(18)=scal14
  69           weights_(21)=wsccor
  70           weights_(22)=wliptran
  71           weights_(25)=wtube
  72           weights_(26)=wsaxs
  73           weights_(28)=wdfa_dist
  74           weights_(29)=wdfa_tor
  75           weights_(30)=wdfa_nei
  76           weights_(31)=wdfa_beta
  77 C FG Master broadcasts the WEIGHTS_ array
  78           call MPI_Bcast(weights_(1),n_ene,
  79      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  80         else
  81 C FG slaves receive the WEIGHTS array
  82           call MPI_Bcast(weights(1),n_ene,
  83      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  84           wsc=weights(1)
  85           wscp=weights(2)
  86           welec=weights(3)
  87           wcorr=weights(4)
  88           wcorr5=weights(5)
  89           wcorr6=weights(6)
  90           wel_loc=weights(7)
  91           wturn3=weights(8)
  92           wturn4=weights(9)
  93           wturn6=weights(10)
  94           wang=weights(11)
  95           wscloc=weights(12)
  96           wtor=weights(13)
  97           wtor_d=weights(14)
  98           wstrain=weights(15)
  99           wvdwpp=weights(16)
 100           wbond=weights(17)
 101           scal14=weights(18)
 102           wsccor=weights(21)
 103           wliptran=weights(22)
 104           wtube=weights(25)
 105           wsaxs=weights(26)
 106           wdfa_dist=weights_(28)
 107           wdfa_tor=weights_(29)
 108           wdfa_nei=weights_(30)
 109           wdfa_beta=weights_(31)
 110         endif
 111         time_Bcast=time_Bcast+MPI_Wtime()-time00
 112         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 113 c        call chainbuild_cart
 114       endif
 115       if (nfgtasks.gt.1) then
 116         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 117       endif
 118 c      write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
 119       if (mod(itime_mat,imatupdate).eq.0) then
 120         call make_SCp_inter_list
 121 c        write (iout,*) "Finished make_SCp_inter_list"
 122 c        call flush(iout)
 123         call make_SCSC_inter_list
 124 c        write (iout,*) "Finished make_SCSC_inter_list"
 125 c        call flush(iout)
 126         call make_pp_inter_list
 127 c        write (iout,*) "Finished make_pp_inter_list"
 128 c        call flush(iout)
 129         call make_pp_vdw_inter_list
 130 c        write (iout,*) "Finished make_pp_vdw_inter_list"
 131 c        call flush(iout)
 132       endif
 133 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 134 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 135 #else
 136 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 137 c        call int_from_cart1(.false.)
 138 c      endif
 139 #endif
 140 #ifdef TIMING
 141       time00=MPI_Wtime()
 142 #endif
 143
 144 #ifndef DFA
 145       edfadis=0.0d0
 146       edfator=0.0d0
 147       edfanei=0.0d0
 148       edfabet=0.0d0
 149 #endif
 150 C
 151 C Compute the side-chain and electrostatic interaction energy
 152 C
 153 C      print *,ipot
 154       goto (101,102,103,104,105,106) ipot
 155 C Lennard-Jones potential.
 156   101 call elj(evdw)
 157 cd    print '(a)','Exit ELJ'
 158       goto 107
 159 C Lennard-Jones-Kihara potential (shifted).
 160   102 call eljk(evdw)
 161       goto 107
 162 C Berne-Pechukas potential (dilated LJ, angular dependence).
 163   103 call ebp(evdw)
 164       goto 107
 165 C Gay-Berne potential (shifted LJ, angular dependence).
 166   104 call egb(evdw)
 167 C      print *,"bylem w egb"
 168       goto 107
 169 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 170   105 call egbv(evdw)
 171       goto 107
 172 C Soft-sphere potential
 173   106 call e_softsphere(evdw)
 174 C
 175 C Calculate electrostatic (H-bonding) energy of the main chain.
 176 C
 177   107 continue
 178 #ifdef DFA
 179 C     BARTEK for dfa test!
 180       if (wdfa_dist.gt.0) then
 181         call edfad(edfadis)
 182       else
 183         edfadis=0
 184       endif
 185 c      print*, 'edfad is finished!', edfadis
 186       if (wdfa_tor.gt.0) then
 187         call edfat(edfator)
 188       else
 189         edfator=0
 190       endif
 191 c      print*, 'edfat is finished!', edfator
 192       if (wdfa_nei.gt.0) then
 193         call edfan(edfanei)
 194       else
 195         edfanei=0
 196       endif
 197 c      print*, 'edfan is finished!', edfanei
 198       if (wdfa_beta.gt.0) then
 199         call edfab(edfabet)
 200       else
 201         edfabet=0
 202       endif
 203 #endif
 204 cmc
 205 cmc Sep-06: egb takes care of dynamic ss bonds too
 206 cmc
 207 c      if (dyn_ss) call dyn_set_nss
 208
 209 c      print *,"Processor",myrank," computed USCSC"
 210 #ifdef TIMING
 211       time01=MPI_Wtime()
 212 #endif
 213       call vec_and_deriv
 214 #ifdef TIMING
 215       time_vec=time_vec+MPI_Wtime()-time01
 216 #endif
 217 C Introduction of shielding effect first for each peptide group
 218 C the shielding factor is set this factor is describing how each
 219 C peptide group is shielded by side-chains
 220 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 221 C      write (iout,*) "shield_mode",shield_mode
 222       if (shield_mode.eq.1) then
 223        call set_shield_fac
 224       else if  (shield_mode.eq.2) then
 225        call set_shield_fac2
 226       endif
 227 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 228       if (ipot.lt.6) then
 229 #ifdef SPLITELE
 230          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 231      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 232      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 233      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 234 #else
 235          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 236      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 237      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 238      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 239 #endif
 240             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 241          else
 242             ees=0.0d0
 243             evdw1=0.0d0
 244             eel_loc=0.0d0
 245             eello_turn3=0.0d0
 246             eello_turn4=0.0d0
 247          endif
 248       else
 249         write (iout,*) "Soft-spheer ELEC potential"
 250 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 251 c     &   eello_turn4)
 252       endif
 253 c#ifdef TIMING
 254 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 255 c#endif
 256 c      print *,"Processor",myrank," computed UELEC"
 257 C
 258 C Calculate excluded-volume interaction energy between peptide groups
 259 C and side chains.
 260 C
 261       if (ipot.lt.6) then
 262        if(wscp.gt.0d0) then
 263         call escp(evdw2,evdw2_14)
 264        else
 265         evdw2=0
 266         evdw2_14=0
 267        endif
 268       else
 269 c        write (iout,*) "Soft-sphere SCP potential"
 270         call escp_soft_sphere(evdw2,evdw2_14)
 271       endif
 272 c
 273 c Calculate the bond-stretching energy
 274 c
 275       call ebond(estr)
 276 C
 277 C Calculate the disulfide-bridge and other energy and the contributions
 278 C from other distance constraints.
 279 cd      write (iout,*) 'Calling EHPB'
 280       call edis(ehpb)
 281 cd    print *,'EHPB exitted succesfully.'
 282 C
 283 C Calculate the virtual-bond-angle energy.
 284 C
 285       if (wang.gt.0d0) then
 286        if (tor_mode.eq.0) then
 287          call ebend(ebe)
 288        else
 289 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 290 C energy function
 291          call ebend_kcc(ebe)
 292        endif
 293       else
 294         ebe=0.0d0
 295       endif
 296       ethetacnstr=0.0d0
 297       if (with_theta_constr) call etheta_constr(ethetacnstr)
 298 c      print *,"Processor",myrank," computed UB"
 299 C
 300 C Calculate the SC local energy.
 301 C
 302 C      print *,"TU DOCHODZE?"
 303       call esc(escloc)
 304 c      print *,"Processor",myrank," computed USC"
 305 C
 306 C Calculate the virtual-bond torsional energy.
 307 C
 308 cd    print *,'nterm=',nterm
 309 C      print *,"tor",tor_mode
 310       if (wtor.gt.0.0d0) then
 311          if (tor_mode.eq.0) then
 312            call etor(etors)
 313          else
 314 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 315 C energy function
 316            call etor_kcc(etors)
 317          endif
 318       else
 319         etors=0.0d0
 320       endif
 321       edihcnstr=0.0d0
 322       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 323 c      print *,"Processor",myrank," computed Utor"
 324       if (constr_homology.ge.1) then
 325         call e_modeller(ehomology_constr)
 326 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 327 c     &  'Processor',fg_rank,' CG group',kolor,
 328 c     &  ' absolute rank',MyRank
 329       else
 330         ehomology_constr=0.0d0
 331       endif
 332 C
 333 C 6/23/01 Calculate double-torsional energy
 334 C
 335       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 336         call etor_d(etors_d)
 337       else
 338         etors_d=0
 339       endif
 340 c      print *,"Processor",myrank," computed Utord"
 341 C
 342 C 21/5/07 Calculate local sicdechain correlation energy
 343 C
 344       if (wsccor.gt.0.0d0) then
 345         call eback_sc_corr(esccor)
 346       else
 347         esccor=0.0d0
 348       endif
 349 #ifdef FOURBODY
 350 C      print *,"PRZED MULIt"
 351 c      print *,"Processor",myrank," computed Usccorr"
 352 C
 353 C 12/1/95 Multi-body terms
 354 C
 355       n_corr=0
 356       n_corr1=0
 357       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 358      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 359          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 360 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 361 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 362 c        call flush(iout)
 363       else
 364          ecorr=0.0d0
 365          ecorr5=0.0d0
 366          ecorr6=0.0d0
 367          eturn6=0.0d0
 368       endif
 369       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 370 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 371 c     &     n_corr,n_corr1
 372 c         call flush(iout)
 373          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 374 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 375 c     &     n_corr1
 376 c         call flush(iout)
 377       else
 378          ecorr=0.0d0
 379          ecorr5=0.0d0
 380          ecorr6=0.0d0
 381          eturn6=0.0d0
 382       endif
 383 #else
 384       ecorr=0.0d0
 385       ecorr5=0.0d0
 386       ecorr6=0.0d0
 387       eturn6=0.0d0
 388 #endif
 389 c      print *,"Processor",myrank," computed Ucorr"
 390 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 391       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 392         call e_saxs(Esaxs_constr)
 393 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 394       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 395         call e_saxsC(Esaxs_constr)
 396 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 397       else
 398         Esaxs_constr = 0.0d0
 399       endif
 400 C
 401 C If performing constraint dynamics, call the constraint energy
 402 C  after the equilibration time
 403 c      if(usampl.and.totT.gt.eq_time) then
 404 c      write (iout,*) "usampl",usampl
 405       if(usampl) then
 406          call EconstrQ
 407          if (loc_qlike) then
 408            call Econstr_back_qlike
 409          else
 410            call Econstr_back
 411          endif
 412       else
 413          Uconst=0.0d0
 414          Uconst_back=0.0d0
 415       endif
 416 C 01/27/2015 added by adasko
 417 C the energy component below is energy transfer into lipid environment
 418 C based on partition function
 419 C      print *,"przed lipidami"
 420       if (wliptran.gt.0) then
 421         call Eliptransfer(eliptran)
 422       else
 423         eliptran=0.0d0
 424       endif
 425 C      print *,"za lipidami"
 426       if (AFMlog.gt.0) then
 427         call AFMforce(Eafmforce)
 428       else if (selfguide.gt.0) then
 429         call AFMvel(Eafmforce)
 430       else
 431         Eafmforce=0.0d0
 432       endif
 433       if (TUBElog.eq.1) then
 434 C      print *,"just before call"
 435         call calctube(Etube)
 436       elseif (TUBElog.eq.2) then
 437         call calctube2(Etube)
 438       else
 439         Etube=0.0d0
 440       endif
 441
 442 #ifdef TIMING
 443       time_enecalc=time_enecalc+MPI_Wtime()-time00
 444 #endif
 445 c      print *,"Processor",myrank," computed Uconstr"
 446 #ifdef TIMING
 447       time00=MPI_Wtime()
 448 #endif
 449 c
 450 C Sum the energies
 451 C
 452       energia(1)=evdw
 453 #ifdef SCP14
 454       energia(2)=evdw2-evdw2_14
 455       energia(18)=evdw2_14
 456 #else
 457       energia(2)=evdw2
 458       energia(18)=0.0d0
 459 #endif
 460 #ifdef SPLITELE
 461       energia(3)=ees
 462       energia(16)=evdw1
 463 #else
 464       energia(3)=ees+evdw1
 465       energia(16)=0.0d0
 466 #endif
 467       energia(4)=ecorr
 468       energia(5)=ecorr5
 469       energia(6)=ecorr6
 470       energia(7)=eel_loc
 471       energia(8)=eello_turn3
 472       energia(9)=eello_turn4
 473       energia(10)=eturn6
 474       energia(11)=ebe
 475       energia(12)=escloc
 476       energia(13)=etors
 477       energia(14)=etors_d
 478       energia(15)=ehpb
 479       energia(19)=edihcnstr
 480       energia(17)=estr
 481       energia(20)=Uconst+Uconst_back
 482       energia(21)=esccor
 483       energia(22)=eliptran
 484       energia(23)=Eafmforce
 485       energia(24)=ethetacnstr
 486       energia(25)=Etube
 487       energia(26)=Esaxs_constr
 488       energia(27)=ehomology_constr
 489       energia(28)=edfadis
 490       energia(29)=edfator
 491       energia(30)=edfanei
 492       energia(31)=edfabet
 493 c      write (iout,*) "esaxs_constr",energia(26)
 494 c    Here are the energies showed per procesor if the are more processors
 495 c    per molecule then we sum it up in sum_energy subroutine
 496 c      print *," Processor",myrank," calls SUM_ENERGY"
 497       call sum_energy(energia,.true.)
 498 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 499       if (dyn_ss) call dyn_set_nss
 500 c      print *," Processor",myrank," left SUM_ENERGY"
 501 #ifdef TIMING
 502       time_sumene=time_sumene+MPI_Wtime()-time00
 503 #endif
 504       return
 505       end
 506 c-------------------------------------------------------------------------------
 507       subroutine sum_energy(energia,reduce)
 508       implicit none
 509       include 'DIMENSIONS'
 510 #ifndef ISNAN
 511       external proc_proc
 512 #ifdef WINPGI
 513 cMS$ATTRIBUTES C ::  proc_proc
 514 #endif
 515 #endif
 516 #ifdef MPI
 517       include "mpif.h"
 518       integer ierr
 519       double precision time00
 520 #endif
 521       include 'COMMON.SETUP'
 522       include 'COMMON.IOUNITS'
 523       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 524       include 'COMMON.FFIELD'
 525       include 'COMMON.DERIV'
 526       include 'COMMON.INTERACT'
 527       include 'COMMON.SBRIDGE'
 528       include 'COMMON.CHAIN'
 529       include 'COMMON.VAR'
 530       include 'COMMON.CONTROL'
 531       include 'COMMON.TIME1'
 532       logical reduce
 533       integer i
 534       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 535      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 536      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 537      & eliptran,Eafmforce,Etube,
 538      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 539       double precision Uconst,etot
 540 #ifdef MPI
 541       if (nfgtasks.gt.1 .and. reduce) then
 542 #ifdef DEBUG
 543         write (iout,*) "energies before REDUCE"
 544         call enerprint(energia)
 545         call flush(iout)
 546 #endif
 547         do i=0,n_ene
 548           enebuff(i)=energia(i)
 549         enddo
 550         time00=MPI_Wtime()
 551         call MPI_Barrier(FG_COMM,IERR)
 552         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 553         time00=MPI_Wtime()
 554         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 555      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 556 #ifdef DEBUG
 557         write (iout,*) "energies after REDUCE"
 558         call enerprint(energia)
 559         call flush(iout)
 560 #endif
 561         time_Reduce=time_Reduce+MPI_Wtime()-time00
 562       endif
 563       if (fg_rank.eq.0) then
 564 #endif
 565       evdw=energia(1)
 566 #ifdef SCP14
 567       evdw2=energia(2)+energia(18)
 568       evdw2_14=energia(18)
 569 #else
 570       evdw2=energia(2)
 571 #endif
 572 #ifdef SPLITELE
 573       ees=energia(3)
 574       evdw1=energia(16)
 575 #else
 576       ees=energia(3)
 577       evdw1=0.0d0
 578 #endif
 579       ecorr=energia(4)
 580       ecorr5=energia(5)
 581       ecorr6=energia(6)
 582       eel_loc=energia(7)
 583       eello_turn3=energia(8)
 584       eello_turn4=energia(9)
 585       eturn6=energia(10)
 586       ebe=energia(11)
 587       escloc=energia(12)
 588       etors=energia(13)
 589       etors_d=energia(14)
 590       ehpb=energia(15)
 591       edihcnstr=energia(19)
 592       estr=energia(17)
 593       Uconst=energia(20)
 594       esccor=energia(21)
 595       eliptran=energia(22)
 596       Eafmforce=energia(23)
 597       ethetacnstr=energia(24)
 598       Etube=energia(25)
 599       esaxs_constr=energia(26)
 600       ehomology_constr=energia(27)
 601       edfadis=energia(28)
 602       edfator=energia(29)
 603       edfanei=energia(30)
 604       edfabet=energia(31)
 605 #ifdef SPLITELE
 606       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 607      & +wang*ebe+wtor*etors+wscloc*escloc
 608      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 609      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 610      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 611      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 612      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 613      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 614      & +wdfa_beta*edfabet
 615 #else
 616       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 617      & +wang*ebe+wtor*etors+wscloc*escloc
 618      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 619      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 620      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 621      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 622      & +Eafmforce
 623      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 624      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 625      & +wdfa_beta*edfabet
 626 #endif
 627       energia(0)=etot
 628 c detecting NaNQ
 629 #ifdef ISNAN
 630 #ifdef AIX
 631       if (isnan(etot).ne.0) energia(0)=1.0d+99
 632 #else
 633       if (isnan(etot)) energia(0)=1.0d+99
 634 #endif
 635 #else
 636       i=0
 637 #ifdef WINPGI
 638       idumm=proc_proc(etot,i)
 639 #else
 640       call proc_proc(etot,i)
 641 #endif
 642       if(i.eq.1)energia(0)=1.0d+99
 643 #endif
 644 #ifdef MPI
 645       endif
 646 #endif
 647       return
 648       end
 649 c-------------------------------------------------------------------------------
 650       subroutine sum_gradient
 651       implicit none
 652       include 'DIMENSIONS'
 653 #ifndef ISNAN
 654       external proc_proc
 655 #ifdef WINPGI
 656 cMS$ATTRIBUTES C ::  proc_proc
 657 #endif
 658 #endif
 659 #ifdef MPI
 660       include 'mpif.h'
 661       integer ierror,ierr
 662       double precision time00,time01
 663 #endif
 664       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 665      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 666      & ,gloc_scbuf(3,-1:maxres)
 667       include 'COMMON.SETUP'
 668       include 'COMMON.IOUNITS'
 669       include 'COMMON.FFIELD'
 670       include 'COMMON.DERIV'
 671       include 'COMMON.INTERACT'
 672       include 'COMMON.SBRIDGE'
 673       include 'COMMON.CHAIN'
 674       include 'COMMON.VAR'
 675       include 'COMMON.CONTROL'
 676       include 'COMMON.TIME1'
 677       include 'COMMON.MAXGRAD'
 678       include 'COMMON.SCCOR'
 679 c      include 'COMMON.MD'
 680       include 'COMMON.QRESTR'
 681       integer i,j,k
 682       double precision scalar
 683       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 684      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 685      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 686      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 687      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 688      &gsclocx_norm
 689 #ifdef TIMING
 690       time01=MPI_Wtime()
 691 #endif
 692 #ifdef DEBUG
 693       write (iout,*) "sum_gradient gvdwc, gvdwx"
 694       do i=1,nres
 695         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 696      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 697       enddo
 698       call flush(iout)
 699 #endif
 700 #ifdef DEBUG
 701       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 702       do i=0,nres
 703         write (iout,'(i3,3e15.5,5x,3e15.5)')
 704      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 705       enddo
 706       call flush(iout)
 707 #endif
 708 #ifdef MPI
 709 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 710         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 711      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 712 #endif
 713 C
 714 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 715 C            in virtual-bond-vector coordinates
 716 C
 717 #ifdef DEBUG
 718 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 719 c      do i=1,nres-1
 720 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 721 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 722 c      enddo
 723 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 724 c      do i=1,nres-1
 725 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 726 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 727 c      enddo
 728       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 729       do i=1,nres
 730         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 731      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 732      &   g_corr5_loc(i)
 733       enddo
 734       call flush(iout)
 735 #endif
 736 #ifdef DEBUG
 737       write (iout,*) "gsaxsc"
 738       do i=1,nres
 739         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 740       enddo
 741       call flush(iout)
 742 #endif
 743 #ifdef SPLITELE
 744       do i=0,nct
 745         do j=1,3
 746           gradbufc(j,i)=wsc*gvdwc(j,i)+
 747      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 748      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 749      &                wel_loc*gel_loc_long(j,i)+
 750      &                wcorr*gradcorr_long(j,i)+
 751      &                wcorr5*gradcorr5_long(j,i)+
 752      &                wcorr6*gradcorr6_long(j,i)+
 753      &                wturn6*gcorr6_turn_long(j,i)+
 754      &                wstrain*ghpbc(j,i)
 755      &                +wliptran*gliptranc(j,i)
 756      &                +gradafm(j,i)
 757      &                +welec*gshieldc(j,i)
 758      &                +wcorr*gshieldc_ec(j,i)
 759      &                +wturn3*gshieldc_t3(j,i)
 760      &                +wturn4*gshieldc_t4(j,i)
 761      &                +wel_loc*gshieldc_ll(j,i)
 762      &                +wtube*gg_tube(j,i)
 763      &                +wsaxs*gsaxsc(j,i)
 764         enddo
 765       enddo
 766 #else
 767       do i=0,nct
 768         do j=1,3
 769           gradbufc(j,i)=wsc*gvdwc(j,i)+
 770      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 771      &                welec*gelc_long(j,i)+
 772      &                wbond*gradb(j,i)+
 773      &                wel_loc*gel_loc_long(j,i)+
 774      &                wcorr*gradcorr_long(j,i)+
 775      &                wcorr5*gradcorr5_long(j,i)+
 776      &                wcorr6*gradcorr6_long(j,i)+
 777      &                wturn6*gcorr6_turn_long(j,i)+
 778      &                wstrain*ghpbc(j,i)
 779      &                +wliptran*gliptranc(j,i)
 780      &                +gradafm(j,i)
 781      &                 +welec*gshieldc(j,i)
 782      &                 +wcorr*gshieldc_ec(j,i)
 783      &                 +wturn4*gshieldc_t4(j,i)
 784      &                 +wel_loc*gshieldc_ll(j,i)
 785      &                +wtube*gg_tube(j,i)
 786      &                +wsaxs*gsaxsc(j,i)
 787         enddo
 788       enddo
 789 #endif
 790       do i=1,nct
 791         do j=1,3
 792           gradbufc(j,i)=gradbufc(j,i)+
 793      &                wdfa_dist*gdfad(j,i)+
 794      &                wdfa_tor*gdfat(j,i)+
 795      &                wdfa_nei*gdfan(j,i)+
 796      &                wdfa_beta*gdfab(j,i)
 797         enddo
 798       enddo
 799 #ifdef DEBUG
 800       write (iout,*) "gradc from gradbufc"
 801       do i=1,nres
 802         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 803       enddo
 804       call flush(iout)
 805 #endif
 806 #ifdef MPI
 807       if (nfgtasks.gt.1) then
 808       time00=MPI_Wtime()
 809 #ifdef DEBUG
 810       write (iout,*) "gradbufc before allreduce"
 811       do i=1,nres
 812         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 813       enddo
 814       call flush(iout)
 815 #endif
 816       do i=0,nres
 817         do j=1,3
 818           gradbufc_sum(j,i)=gradbufc(j,i)
 819         enddo
 820       enddo
 821 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 822 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 823 c      time_reduce=time_reduce+MPI_Wtime()-time00
 824 #ifdef DEBUG
 825 c      write (iout,*) "gradbufc_sum after allreduce"
 826 c      do i=1,nres
 827 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 828 c      enddo
 829 c      call flush(iout)
 830 #endif
 831 #ifdef TIMING
 832 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 833 #endif
 834       do i=nnt,nres
 835         do k=1,3
 836           gradbufc(k,i)=0.0d0
 837         enddo
 838       enddo
 839 #ifdef DEBUG
 840       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 841       write (iout,*) (i," jgrad_start",jgrad_start(i),
 842      &                  " jgrad_end  ",jgrad_end(i),
 843      &                  i=igrad_start,igrad_end)
 844 #endif
 845 c
 846 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 847 c do not parallelize this part.
 848 c
 849 c      do i=igrad_start,igrad_end
 850 c        do j=jgrad_start(i),jgrad_end(i)
 851 c          do k=1,3
 852 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 853 c          enddo
 854 c        enddo
 855 c      enddo
 856       do j=1,3
 857         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 858       enddo
 859       do i=nres-2,-1,-1
 860         do j=1,3
 861           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 862         enddo
 863       enddo
 864 #ifdef DEBUG
 865       write (iout,*) "gradbufc after summing"
 866       do i=1,nres
 867         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 868       enddo
 869       call flush(iout)
 870 #endif
 871       else
 872 #endif
 873 #ifdef DEBUG
 874       write (iout,*) "gradbufc"
 875       do i=1,nres
 876         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 877       enddo
 878       call flush(iout)
 879 #endif
 880       do i=-1,nres
 881         do j=1,3
 882           gradbufc_sum(j,i)=gradbufc(j,i)
 883           gradbufc(j,i)=0.0d0
 884         enddo
 885       enddo
 886       do j=1,3
 887         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 888       enddo
 889       do i=nres-2,-1,-1
 890         do j=1,3
 891           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 892         enddo
 893       enddo
 894 c      do i=nnt,nres-1
 895 c        do k=1,3
 896 c          gradbufc(k,i)=0.0d0
 897 c        enddo
 898 c        do j=i+1,nres
 899 c          do k=1,3
 900 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 901 c          enddo
 902 c        enddo
 903 c      enddo
 904 #ifdef DEBUG
 905       write (iout,*) "gradbufc after summing"
 906       do i=1,nres
 907         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 908       enddo
 909       call flush(iout)
 910 #endif
 911 #ifdef MPI
 912       endif
 913 #endif
 914       do k=1,3
 915         gradbufc(k,nres)=0.0d0
 916       enddo
 917       do i=-1,nct
 918         do j=1,3
 919 #ifdef SPLITELE
 920 C          print *,gradbufc(1,13)
 921 C          print *,welec*gelc(1,13)
 922 C          print *,wel_loc*gel_loc(1,13)
 923 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 924 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 925 C          print *,wel_loc*gel_loc_long(1,13)
 926 C          print *,gradafm(1,13),"AFM"
 927           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 928      &                wel_loc*gel_loc(j,i)+
 929      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 930      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 931      &                wel_loc*gel_loc_long(j,i)+
 932      &                wcorr*gradcorr_long(j,i)+
 933      &                wcorr5*gradcorr5_long(j,i)+
 934      &                wcorr6*gradcorr6_long(j,i)+
 935      &                wturn6*gcorr6_turn_long(j,i))+
 936      &                wbond*gradb(j,i)+
 937      &                wcorr*gradcorr(j,i)+
 938      &                wturn3*gcorr3_turn(j,i)+
 939      &                wturn4*gcorr4_turn(j,i)+
 940      &                wcorr5*gradcorr5(j,i)+
 941      &                wcorr6*gradcorr6(j,i)+
 942      &                wturn6*gcorr6_turn(j,i)+
 943      &                wsccor*gsccorc(j,i)
 944      &               +wscloc*gscloc(j,i)
 945      &               +wliptran*gliptranc(j,i)
 946      &                +gradafm(j,i)
 947      &                 +welec*gshieldc(j,i)
 948      &                 +welec*gshieldc_loc(j,i)
 949      &                 +wcorr*gshieldc_ec(j,i)
 950      &                 +wcorr*gshieldc_loc_ec(j,i)
 951      &                 +wturn3*gshieldc_t3(j,i)
 952      &                 +wturn3*gshieldc_loc_t3(j,i)
 953      &                 +wturn4*gshieldc_t4(j,i)
 954      &                 +wturn4*gshieldc_loc_t4(j,i)
 955      &                 +wel_loc*gshieldc_ll(j,i)
 956      &                 +wel_loc*gshieldc_loc_ll(j,i)
 957      &                +wtube*gg_tube(j,i)
 958
 959 #else
 960           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 961      &                wel_loc*gel_loc(j,i)+
 962      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 963      &                welec*gelc_long(j,i)+
 964      &                wel_loc*gel_loc_long(j,i)+
 965      &                wcorr*gcorr_long(j,i)+
 966      &                wcorr5*gradcorr5_long(j,i)+
 967      &                wcorr6*gradcorr6_long(j,i)+
 968      &                wturn6*gcorr6_turn_long(j,i))+
 969      &                wbond*gradb(j,i)+
 970      &                wcorr*gradcorr(j,i)+
 971      &                wturn3*gcorr3_turn(j,i)+
 972      &                wturn4*gcorr4_turn(j,i)+
 973      &                wcorr5*gradcorr5(j,i)+
 974      &                wcorr6*gradcorr6(j,i)+
 975      &                wturn6*gcorr6_turn(j,i)+
 976      &                wsccor*gsccorc(j,i)
 977      &               +wscloc*gscloc(j,i)
 978      &               +wliptran*gliptranc(j,i)
 979      &                +gradafm(j,i)
 980      &                 +welec*gshieldc(j,i)
 981      &                 +welec*gshieldc_loc(j,i)
 982      &                 +wcorr*gshieldc_ec(j,i)
 983      &                 +wcorr*gshieldc_loc_ec(j,i)
 984      &                 +wturn3*gshieldc_t3(j,i)
 985      &                 +wturn3*gshieldc_loc_t3(j,i)
 986      &                 +wturn4*gshieldc_t4(j,i)
 987      &                 +wturn4*gshieldc_loc_t4(j,i)
 988      &                 +wel_loc*gshieldc_ll(j,i)
 989      &                 +wel_loc*gshieldc_loc_ll(j,i)
 990      &                +wtube*gg_tube(j,i)
 991
 992
 993 #endif
 994           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 995      &                  wbond*gradbx(j,i)+
 996      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 997      &                  wsccor*gsccorx(j,i)
 998      &                 +wscloc*gsclocx(j,i)
 999      &                 +wliptran*gliptranx(j,i)
1000      &                 +welec*gshieldx(j,i)
1001      &                 +wcorr*gshieldx_ec(j,i)
1002      &                 +wturn3*gshieldx_t3(j,i)
1003      &                 +wturn4*gshieldx_t4(j,i)
1004      &                 +wel_loc*gshieldx_ll(j,i)
1005      &                 +wtube*gg_tube_sc(j,i)
1006      &                 +wsaxs*gsaxsx(j,i)
1007
1008
1009
1010         enddo
1011       enddo
1012       if (constr_homology.gt.0) then
1013         do i=1,nct
1014           do j=1,3
1015             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
1016             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1017           enddo
1018         enddo
1019       endif
1020 #ifdef DEBUG
1021       write (iout,*) "gradc gradx gloc after adding"
1022       do i=1,nres
1023         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1024      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1025       enddo
1026 #endif
1027 #ifdef DEBUG
1028       write (iout,*) "gloc before adding corr"
1029       do i=1,4*nres
1030         write (iout,*) i,gloc(i,icg)
1031       enddo
1032 #endif
1033       do i=1,nres-3
1034         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1035      &   +wcorr5*g_corr5_loc(i)
1036      &   +wcorr6*g_corr6_loc(i)
1037      &   +wturn4*gel_loc_turn4(i)
1038      &   +wturn3*gel_loc_turn3(i)
1039      &   +wturn6*gel_loc_turn6(i)
1040      &   +wel_loc*gel_loc_loc(i)
1041       enddo
1042 #ifdef DEBUG
1043       write (iout,*) "gloc after adding corr"
1044       do i=1,4*nres
1045         write (iout,*) i,gloc(i,icg)
1046       enddo
1047 #endif
1048 #ifdef MPI
1049       if (nfgtasks.gt.1) then
1050         do j=1,3
1051           do i=1,nres
1052             gradbufc(j,i)=gradc(j,i,icg)
1053             gradbufx(j,i)=gradx(j,i,icg)
1054           enddo
1055         enddo
1056         do i=1,4*nres
1057           glocbuf(i)=gloc(i,icg)
1058         enddo
1059 c#define DEBUG
1060 #ifdef DEBUG
1061       write (iout,*) "gloc_sc before reduce"
1062       do i=1,nres
1063        do j=1,1
1064         write (iout,*) i,j,gloc_sc(j,i,icg)
1065        enddo
1066       enddo
1067 #endif
1068 c#undef DEBUG
1069         do i=1,nres
1070          do j=1,3
1071           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1072          enddo
1073         enddo
1074         time00=MPI_Wtime()
1075         call MPI_Barrier(FG_COMM,IERR)
1076         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1077         time00=MPI_Wtime()
1078         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1079      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1080         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1081      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1082         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1083      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1084         time_reduce=time_reduce+MPI_Wtime()-time00
1085         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1086      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1087         time_reduce=time_reduce+MPI_Wtime()-time00
1088 #ifdef DEBUG
1089       write (iout,*) "gradc after reduce"
1090       do i=1,nres
1091        do j=1,3
1092         write (iout,*) i,j,gradc(j,i,icg)
1093        enddo
1094       enddo
1095 #endif
1096 #ifdef DEBUG
1097       write (iout,*) "gloc_sc after reduce"
1098       do i=1,nres
1099        do j=1,1
1100         write (iout,*) i,j,gloc_sc(j,i,icg)
1101        enddo
1102       enddo
1103 #endif
1104 #ifdef DEBUG
1105       write (iout,*) "gloc after reduce"
1106       do i=1,4*nres
1107         write (iout,*) i,gloc(i,icg)
1108       enddo
1109 #endif
1110       endif
1111 #endif
1112       if (gnorm_check) then
1113 c
1114 c Compute the maximum elements of the gradient
1115 c
1116       gvdwc_max=0.0d0
1117       gvdwc_scp_max=0.0d0
1118       gelc_max=0.0d0
1119       gvdwpp_max=0.0d0
1120       gradb_max=0.0d0
1121       ghpbc_max=0.0d0
1122       gradcorr_max=0.0d0
1123       gel_loc_max=0.0d0
1124       gcorr3_turn_max=0.0d0
1125       gcorr4_turn_max=0.0d0
1126       gradcorr5_max=0.0d0
1127       gradcorr6_max=0.0d0
1128       gcorr6_turn_max=0.0d0
1129       gsccorrc_max=0.0d0
1130       gscloc_max=0.0d0
1131       gvdwx_max=0.0d0
1132       gradx_scp_max=0.0d0
1133       ghpbx_max=0.0d0
1134       gradxorr_max=0.0d0
1135       gsccorrx_max=0.0d0
1136       gsclocx_max=0.0d0
1137       do i=1,nct
1138         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1139         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1140         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1141         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1142      &   gvdwc_scp_max=gvdwc_scp_norm
1143         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1144         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1145         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1146         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1147         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1148         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1149         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1150         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1151         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1152         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1153         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1154         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1155         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1156      &    gcorr3_turn(1,i)))
1157         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1158      &    gcorr3_turn_max=gcorr3_turn_norm
1159         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1160      &    gcorr4_turn(1,i)))
1161         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1162      &    gcorr4_turn_max=gcorr4_turn_norm
1163         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1164         if (gradcorr5_norm.gt.gradcorr5_max)
1165      &    gradcorr5_max=gradcorr5_norm
1166         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1167         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1168         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1169      &    gcorr6_turn(1,i)))
1170         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1171      &    gcorr6_turn_max=gcorr6_turn_norm
1172         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1173         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1174         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1175         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1176         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1177         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1178         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1179         if (gradx_scp_norm.gt.gradx_scp_max)
1180      &    gradx_scp_max=gradx_scp_norm
1181         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1182         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1183         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1184         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1185         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1186         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1187         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1188         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1189       enddo
1190       if (gradout) then
1191 #if (defined AIX || defined CRAY)
1192         open(istat,file=statname,position="append")
1193 #else
1194         open(istat,file=statname,access="append")
1195 #endif
1196         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1197      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1198      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1199      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1200      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1201      &     gsccorrx_max,gsclocx_max
1202         close(istat)
1203         if (gvdwc_max.gt.1.0d4) then
1204           write (iout,*) "gvdwc gvdwx gradb gradbx"
1205           do i=nnt,nct
1206             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1207      &        gradb(j,i),gradbx(j,i),j=1,3)
1208           enddo
1209           call pdbout(0.0d0,'cipiszcze',iout)
1210           call flush(iout)
1211         endif
1212       endif
1213       endif
1214 #ifdef DEBUG
1215       write (iout,*) "gradc gradx gloc"
1216       do i=1,nres
1217         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1218      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1219       enddo
1220 #endif
1221 #ifdef TIMING
1222       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1223 #endif
1224       return
1225       end
1226 c-------------------------------------------------------------------------------
1227       subroutine rescale_weights(t_bath)
1228       implicit none
1229 #ifdef MPI
1230       include 'mpif.h'
1231       integer ierror
1232 #endif
1233       include 'DIMENSIONS'
1234       include 'COMMON.IOUNITS'
1235       include 'COMMON.FFIELD'
1236       include 'COMMON.SBRIDGE'
1237       include 'COMMON.CONTROL'
1238       double precision t_bath
1239       double precision facT,facT2,facT3,facT4,facT5
1240       double precision kfac /2.4d0/
1241       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1242 c      facT=temp0/t_bath
1243 c      facT=2*temp0/(t_bath+temp0)
1244       if (rescale_mode.eq.0) then
1245         facT=1.0d0
1246         facT2=1.0d0
1247         facT3=1.0d0
1248         facT4=1.0d0
1249         facT5=1.0d0
1250       else if (rescale_mode.eq.1) then
1251         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1252         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1253         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1254         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1255         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1256       else if (rescale_mode.eq.2) then
1257         x=t_bath/temp0
1258         x2=x*x
1259         x3=x2*x
1260         x4=x3*x
1261         x5=x4*x
1262         facT=licznik/dlog(dexp(x)+dexp(-x))
1263         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1264         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1265         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1266         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1267       else
1268         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1269         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1270 #ifdef MPI
1271        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1272 #endif
1273        stop 555
1274       endif
1275       if (shield_mode.gt.0) then
1276        wscp=weights(2)*fact
1277        wsc=weights(1)*fact
1278        wvdwpp=weights(16)*fact
1279       endif
1280       welec=weights(3)*fact
1281       wcorr=weights(4)*fact3
1282       wcorr5=weights(5)*fact4
1283       wcorr6=weights(6)*fact5
1284       wel_loc=weights(7)*fact2
1285       wturn3=weights(8)*fact2
1286       wturn4=weights(9)*fact3
1287       wturn6=weights(10)*fact5
1288       wtor=weights(13)*fact
1289       wtor_d=weights(14)*fact2
1290       wsccor=weights(21)*fact
1291       if (scale_umb) wumb=t_bath/temp0
1292 c      write (iout,*) "scale_umb",scale_umb
1293 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1294
1295       return
1296       end
1297 C------------------------------------------------------------------------
1298       subroutine enerprint(energia)
1299       implicit none
1300       include 'DIMENSIONS'
1301       include 'COMMON.IOUNITS'
1302       include 'COMMON.FFIELD'
1303       include 'COMMON.SBRIDGE'
1304       include 'COMMON.QRESTR'
1305       double precision energia(0:n_ene)
1306       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1307      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1308      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1309      & eello_turn6,
1310      & eliptran,Eafmforce,Etube,
1311      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1312       etot=energia(0)
1313       evdw=energia(1)
1314       evdw2=energia(2)
1315 #ifdef SCP14
1316       evdw2=energia(2)+energia(18)
1317 #else
1318       evdw2=energia(2)
1319 #endif
1320       ees=energia(3)
1321 #ifdef SPLITELE
1322       evdw1=energia(16)
1323 #endif
1324       ecorr=energia(4)
1325       ecorr5=energia(5)
1326       ecorr6=energia(6)
1327       eel_loc=energia(7)
1328       eello_turn3=energia(8)
1329       eello_turn4=energia(9)
1330       eello_turn6=energia(10)
1331       ebe=energia(11)
1332       escloc=energia(12)
1333       etors=energia(13)
1334       etors_d=energia(14)
1335       ehpb=energia(15)
1336       edihcnstr=energia(19)
1337       estr=energia(17)
1338       Uconst=energia(20)
1339       esccor=energia(21)
1340       eliptran=energia(22)
1341       Eafmforce=energia(23)
1342       ethetacnstr=energia(24)
1343       etube=energia(25)
1344       esaxs=energia(26)
1345       ehomology_constr=energia(27)
1346 C     Bartek
1347       edfadis = energia(28)
1348       edfator = energia(29)
1349       edfanei = energia(30)
1350       edfabet = energia(31)
1351 #ifdef SPLITELE
1352       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1353      &  estr,wbond,ebe,wang,
1354      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1355 #ifdef FOURBODY
1356      &  ecorr,wcorr,
1357      &  ecorr5,wcorr5,ecorr6,wcorr6,
1358 #endif
1359      &  eel_loc,wel_loc,eello_turn3,wturn3,
1360      &  eello_turn4,wturn4,
1361 #ifdef FOURBODY
1362      &  eello_turn6,wturn6,
1363 #endif
1364      &  esccor,wsccor,edihcnstr,
1365      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1366      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1367      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1368      &  edfabet,wdfa_beta,
1369      &  etot
1370    10 format (/'Virtual-chain energies:'//
1371      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1372      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1373      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1374      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1375      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1376      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1377      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1378      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1379      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1380      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1381      & ' (SS bridges & dist. cnstr.)'/
1382 #ifdef FOURBODY
1383      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1384      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1385      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1386 #endif
1387      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1388      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1389      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1390 #ifdef FOURBODY
1391      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1392 #endif
1393      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1394      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1395      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1396      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1397      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1398      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1399      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1400      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1401      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1402      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1403      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1404      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1405      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1406      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1407      & 'ETOT=  ',1pE16.6,' (total)')
1408
1409 #else
1410       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1411      &  estr,wbond,ebe,wang,
1412      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1413 #ifdef FOURBODY
1414      &  ecorr,wcorr,
1415      &  ecorr5,wcorr5,ecorr6,wcorr6,
1416 #endif
1417      &  eel_loc,wel_loc,eello_turn3,wturn3,
1418      &  eello_turn4,wturn4,
1419 #ifdef FOURBODY
1420      &  eello_turn6,wturn6,
1421 #endif
1422      &  esccor,wsccor,edihcnstr,
1423      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1424      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1425      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1426      &  edfabet,wdfa_beta,
1427      &  etot
1428    10 format (/'Virtual-chain energies:'//
1429      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1430      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1431      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1432      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1433      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1434      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1435      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1436      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1437      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1438      & ' (SS bridges & dist. restr.)'/
1439 #ifdef FOURBODY
1440      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1441      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1442      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1443 #endif
1444      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1445      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1446      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1447 #ifdef FOURBODY
1448      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1449 #endif
1450      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1451      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1452      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1453      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1454      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1455      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1456      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1457      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1458      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1459      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1460      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1461      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1462      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1463      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1464      & 'ETOT=  ',1pE16.6,' (total)')
1465 #endif
1466       return
1467       end
1468 C-----------------------------------------------------------------------
1469       subroutine elj(evdw)
1470 C
1471 C This subroutine calculates the interaction energy of nonbonded side chains
1472 C assuming the LJ potential of interaction.
1473 C
1474       implicit none
1475       double precision accur
1476       include 'DIMENSIONS'
1477       parameter (accur=1.0d-10)
1478       include 'COMMON.GEO'
1479       include 'COMMON.VAR'
1480       include 'COMMON.LOCAL'
1481       include 'COMMON.CHAIN'
1482       include 'COMMON.DERIV'
1483       include 'COMMON.INTERACT'
1484       include 'COMMON.TORSION'
1485       include 'COMMON.SBRIDGE'
1486       include 'COMMON.NAMES'
1487       include 'COMMON.IOUNITS'
1488       include 'COMMON.SPLITELE'
1489 #ifdef FOURBODY
1490       include 'COMMON.CONTACTS'
1491       include 'COMMON.CONTMAT'
1492 #endif
1493       double precision gg(3)
1494       double precision evdw,evdwij
1495       integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1496       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1497      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1498       double precision fcont,fprimcont
1499       double precision sscale,sscagrad
1500       double precision boxshift
1501 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1502       evdw=0.0D0
1503 c      do i=iatsc_s,iatsc_e
1504       do ikont=g_listscsc_start,g_listscsc_end
1505         i=newcontlisti(ikont)
1506         j=newcontlistj(ikont)
1507         itypi=iabs(itype(i))
1508         if (itypi.eq.ntyp1) cycle
1509         itypi1=iabs(itype(i+1))
1510         xi=c(1,nres+i)
1511         yi=c(2,nres+i)
1512         zi=c(3,nres+i)
1513         call to_box(xi,yi,zi)
1514 C Change 12/1/95
1515         num_conti=0
1516 C
1517 C Calculate SC interaction energy.
1518 C
1519 c        do iint=1,nint_gr(i)
1520 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1521 cd   &                  'iend=',iend(i,iint)
1522 c          do j=istart(i,iint),iend(i,iint)
1523             itypj=iabs(itype(j))
1524             if (itypj.eq.ntyp1) cycle
1525             xj=c(1,nres+j)
1526             yj=c(2,nres+j)
1527             zj=c(3,nres+j)
1528             call to_box(xj,yj,zj)
1529             xj=boxshift(xj-xi,boxxsize)
1530             yj=boxshift(yj-yi,boxysize)
1531             zj=boxshift(zj-zi,boxzsize)
1532 C Change 12/1/95 to calculate four-body interactions
1533             rij=xj*xj+yj*yj+zj*zj
1534             rrij=1.0D0/rij
1535             sqrij=dsqrt(rij)
1536             sss1=sscale(sqrij,r_cut_int)
1537             if (sss1.eq.0.0d0) cycle
1538             sssgrad1=sscagrad(sqrij,r_cut_int)
1539
1540 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1541             eps0ij=eps(itypi,itypj)
1542             fac=rrij**expon2
1543 C have you changed here?
1544             e1=fac*fac*aa
1545             e2=fac*bb
1546             evdwij=e1+e2
1547 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1548 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1549 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1550 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1551 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1552 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1553             evdw=evdw+sss1*evdwij
1554 C
1555 C Calculate the components of the gradient in DC and X
1556 C
1557             fac=-rrij*(e1+evdwij)*sss1
1558      &          +evdwij*sssgrad1/sqrij/expon
1559             gg(1)=xj*fac
1560             gg(2)=yj*fac
1561             gg(3)=zj*fac
1562             do k=1,3
1563               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1564               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1565               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1566               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1567             enddo
1568 cgrad            do k=i,j-1
1569 cgrad              do l=1,3
1570 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1571 cgrad              enddo
1572 cgrad            enddo
1573 C
1574 #ifdef FOURBODY
1575 C 12/1/95, revised on 5/20/97
1576 C
1577 C Calculate the contact function. The ith column of the array JCONT will
1578 C contain the numbers of atoms that make contacts with the atom I (of numbers
1579 C greater than I). The arrays FACONT and GACONT will contain the values of
1580 C the contact function and its derivative.
1581 C
1582 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1583 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1584 C Uncomment next line, if the correlation interactions are contact function only
1585             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1586               rij=dsqrt(rij)
1587               sigij=sigma(itypi,itypj)
1588               r0ij=rs0(itypi,itypj)
1589 C
1590 C Check whether the SC's are not too far to make a contact.
1591 C
1592               rcut=1.5d0*r0ij
1593               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1594 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1595 C
1596               if (fcont.gt.0.0D0) then
1597 C If the SC-SC distance if close to sigma, apply spline.
1598 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1599 cAdam &             fcont1,fprimcont1)
1600 cAdam           fcont1=1.0d0-fcont1
1601 cAdam           if (fcont1.gt.0.0d0) then
1602 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1603 cAdam             fcont=fcont*fcont1
1604 cAdam           endif
1605 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1606 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1607 cga             do k=1,3
1608 cga               gg(k)=gg(k)*eps0ij
1609 cga             enddo
1610 cga             eps0ij=-evdwij*eps0ij
1611 C Uncomment for AL's type of SC correlation interactions.
1612 cadam           eps0ij=-evdwij
1613                 num_conti=num_conti+1
1614                 jcont(num_conti,i)=j
1615                 facont(num_conti,i)=fcont*eps0ij
1616                 fprimcont=eps0ij*fprimcont/rij
1617                 fcont=expon*fcont
1618 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1619 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1620 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1621 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1622                 gacont(1,num_conti,i)=-fprimcont*xj
1623                 gacont(2,num_conti,i)=-fprimcont*yj
1624                 gacont(3,num_conti,i)=-fprimcont*zj
1625 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1626 cd              write (iout,'(2i3,3f10.5)')
1627 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1628               endif
1629             endif
1630 #endif
1631 c          enddo      ! j
1632 c        enddo        ! iint
1633 C Change 12/1/95
1634 #ifdef FOURBODY
1635         num_cont(i)=num_conti
1636 #endif
1637       enddo          ! i
1638       do i=1,nct
1639         do j=1,3
1640           gvdwc(j,i)=expon*gvdwc(j,i)
1641           gvdwx(j,i)=expon*gvdwx(j,i)
1642         enddo
1643       enddo
1644 C******************************************************************************
1645 C
1646 C                              N O T E !!!
1647 C
1648 C To save time, the factor of EXPON has been extracted from ALL components
1649 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1650 C use!
1651 C
1652 C******************************************************************************
1653       return
1654       end
1655 C-----------------------------------------------------------------------------
1656       subroutine eljk(evdw)
1657 C
1658 C This subroutine calculates the interaction energy of nonbonded side chains
1659 C assuming the LJK potential of interaction.
1660 C
1661       implicit none
1662       include 'DIMENSIONS'
1663       include 'COMMON.GEO'
1664       include 'COMMON.VAR'
1665       include 'COMMON.LOCAL'
1666       include 'COMMON.CHAIN'
1667       include 'COMMON.DERIV'
1668       include 'COMMON.INTERACT'
1669       include 'COMMON.IOUNITS'
1670       include 'COMMON.NAMES'
1671       include 'COMMON.SPLITELE'
1672       double precision gg(3)
1673       double precision evdw,evdwij
1674       integer i,j,k,itypi,itypj,itypi1,iint,ikont
1675       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1676      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1677       logical scheck
1678       double precision sscale,sscagrad
1679       double precision boxshift
1680 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1681       evdw=0.0D0
1682 c      do i=iatsc_s,iatsc_e
1683       do ikont=g_listscsc_start,g_listscsc_end
1684         i=newcontlisti(ikont)
1685         j=newcontlistj(ikont)
1686         itypi=iabs(itype(i))
1687         if (itypi.eq.ntyp1) cycle
1688         itypi1=iabs(itype(i+1))
1689         xi=c(1,nres+i)
1690         yi=c(2,nres+i)
1691         zi=c(3,nres+i)
1692         call to_box(xi,yi,zi)
1693 C
1694 C Calculate SC interaction energy.
1695 C
1696 c        do iint=1,nint_gr(i)
1697 c          do j=istart(i,iint),iend(i,iint)
1698             itypj=iabs(itype(j))
1699             if (itypj.eq.ntyp1) cycle
1700             xj=c(1,nres+j)
1701             yj=c(2,nres+j)
1702             zj=c(3,nres+j)
1703             call to_box(xj,yj,zj)
1704             xj=boxshift(xj-xi,boxxsize)
1705             yj=boxshift(yj-yi,boxysize)
1706             zj=boxshift(zj-zi,boxzsize)
1707             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1708             fac_augm=rrij**expon
1709             e_augm=augm(itypi,itypj)*fac_augm
1710             r_inv_ij=dsqrt(rrij)
1711             rij=1.0D0/r_inv_ij
1712             sss1=sscale(rij,r_cut_int)
1713             if (sss1.eq.0.0d0) cycle
1714             sssgrad1=sscagrad(rij,r_cut_int)
1715             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1716             fac=r_shift_inv**expon
1717 C have you changed here?
1718             e1=fac*fac*aa
1719             e2=fac*bb
1720             evdwij=e_augm+e1+e2
1721 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1722 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1723 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1724 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1725 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1726 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1727 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1728             evdw=evdw+evdwij*sss1
1729 C
1730 C Calculate the components of the gradient in DC and X
1731 C
1732             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1733      &          +evdwij*sssgrad1*r_inv_ij/expon
1734             gg(1)=xj*fac
1735             gg(2)=yj*fac
1736             gg(3)=zj*fac
1737             do k=1,3
1738               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1739               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1740               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1741               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1742             enddo
1743 cgrad            do k=i,j-1
1744 cgrad              do l=1,3
1745 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1746 cgrad              enddo
1747 cgrad            enddo
1748 c          enddo      ! j
1749 c        enddo        ! iint
1750       enddo          ! i
1751       do i=1,nct
1752         do j=1,3
1753           gvdwc(j,i)=expon*gvdwc(j,i)
1754           gvdwx(j,i)=expon*gvdwx(j,i)
1755         enddo
1756       enddo
1757       return
1758       end
1759 C-----------------------------------------------------------------------------
1760       subroutine ebp(evdw)
1761 C
1762 C This subroutine calculates the interaction energy of nonbonded side chains
1763 C assuming the Berne-Pechukas potential of interaction.
1764 C
1765       implicit none
1766       include 'DIMENSIONS'
1767       include 'COMMON.GEO'
1768       include 'COMMON.VAR'
1769       include 'COMMON.LOCAL'
1770       include 'COMMON.CHAIN'
1771       include 'COMMON.DERIV'
1772       include 'COMMON.NAMES'
1773       include 'COMMON.INTERACT'
1774       include 'COMMON.IOUNITS'
1775       include 'COMMON.CALC'
1776       include 'COMMON.SPLITELE'
1777       integer icall
1778       common /srutu/ icall
1779       double precision evdw
1780       integer itypi,itypj,itypi1,iint,ind,ikont
1781       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1782      & sss1,sssgrad1
1783       double precision sscale,sscagrad
1784       double precision boxshift
1785 c     double precision rrsave(maxdim)
1786       logical lprn
1787       evdw=0.0D0
1788 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1789       evdw=0.0D0
1790 c     if (icall.eq.0) then
1791 c       lprn=.true.
1792 c     else
1793         lprn=.false.
1794 c     endif
1795       ind=0
1796 c      do i=iatsc_s,iatsc_e
1797       do ikont=g_listscsc_start,g_listscsc_end
1798         i=newcontlisti(ikont)
1799         j=newcontlistj(ikont)
1800         itypi=iabs(itype(i))
1801         if (itypi.eq.ntyp1) cycle
1802         itypi1=iabs(itype(i+1))
1803         xi=c(1,nres+i)
1804         yi=c(2,nres+i)
1805         zi=c(3,nres+i)
1806         call to_box(xi,yi,zi)
1807         dxi=dc_norm(1,nres+i)
1808         dyi=dc_norm(2,nres+i)
1809         dzi=dc_norm(3,nres+i)
1810 c        dsci_inv=dsc_inv(itypi)
1811         dsci_inv=vbld_inv(i+nres)
1812 C
1813 C Calculate SC interaction energy.
1814 C
1815 c        do iint=1,nint_gr(i)
1816 c          do j=istart(i,iint),iend(i,iint)
1817             ind=ind+1
1818             itypj=iabs(itype(j))
1819             if (itypj.eq.ntyp1) cycle
1820 c            dscj_inv=dsc_inv(itypj)
1821             dscj_inv=vbld_inv(j+nres)
1822             chi1=chi(itypi,itypj)
1823             chi2=chi(itypj,itypi)
1824             chi12=chi1*chi2
1825             chip1=chip(itypi)
1826             chip2=chip(itypj)
1827             chip12=chip1*chip2
1828             alf1=alp(itypi)
1829             alf2=alp(itypj)
1830             alf12=0.5D0*(alf1+alf2)
1831 C For diagnostics only!!!
1832 c           chi1=0.0D0
1833 c           chi2=0.0D0
1834 c           chi12=0.0D0
1835 c           chip1=0.0D0
1836 c           chip2=0.0D0
1837 c           chip12=0.0D0
1838 c           alf1=0.0D0
1839 c           alf2=0.0D0
1840 c           alf12=0.0D0
1841             xj=c(1,nres+j)
1842             yj=c(2,nres+j)
1843             zj=c(3,nres+j)
1844             call to_box(xj,yj,zj)
1845             xj=boxshift(xj-xi,boxxsize)
1846             yj=boxshift(yj-yi,boxysize)
1847             zj=boxshift(zj-zi,boxzsize)
1848             dxj=dc_norm(1,nres+j)
1849             dyj=dc_norm(2,nres+j)
1850             dzj=dc_norm(3,nres+j)
1851             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1852 cd          if (icall.eq.0) then
1853 cd            rrsave(ind)=rrij
1854 cd          else
1855 cd            rrij=rrsave(ind)
1856 cd          endif
1857             rij=dsqrt(rrij)
1858             sss1=sscale(1.0d0/rij,r_cut_int)
1859             if (sss1.eq.0.0d0) cycle
1860             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1861 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1862             call sc_angular
1863 C Calculate whole angle-dependent part of epsilon and contributions
1864 C to its derivatives
1865 C have you changed here?
1866             fac=(rrij*sigsq)**expon2
1867             e1=fac*fac*aa
1868             e2=fac*bb
1869             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1870             eps2der=evdwij*eps3rt
1871             eps3der=evdwij*eps2rt
1872             evdwij=evdwij*eps2rt*eps3rt
1873             evdw=evdw+sss1*evdwij
1874             if (lprn) then
1875             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1876             epsi=bb**2/aa
1877 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1878 cd     &        restyp(itypi),i,restyp(itypj),j,
1879 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1880 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1881 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1882 cd     &        evdwij
1883             endif
1884 C Calculate gradient components.
1885             e1=e1*eps1*eps2rt**2*eps3rt**2
1886             fac=-expon*(e1+evdwij)
1887             sigder=fac/sigsq
1888             fac=rrij*fac
1889      &          +evdwij*sssgrad1/sss1*rij
1890 C Calculate radial part of the gradient
1891             gg(1)=xj*fac
1892             gg(2)=yj*fac
1893             gg(3)=zj*fac
1894 C Calculate the angular part of the gradient and sum add the contributions
1895 C to the appropriate components of the Cartesian gradient.
1896             call sc_grad
1897 !          enddo      ! j
1898 !        enddo        ! iint
1899       enddo          ! i
1900 c     stop
1901       return
1902       end
1903 C-----------------------------------------------------------------------------
1904       subroutine egb(evdw)
1905 C
1906 C This subroutine calculates the interaction energy of nonbonded side chains
1907 C assuming the Gay-Berne potential of interaction.
1908 C
1909       implicit none
1910       include 'DIMENSIONS'
1911       include 'COMMON.GEO'
1912       include 'COMMON.VAR'
1913       include 'COMMON.LOCAL'
1914       include 'COMMON.CHAIN'
1915       include 'COMMON.DERIV'
1916       include 'COMMON.NAMES'
1917       include 'COMMON.INTERACT'
1918       include 'COMMON.IOUNITS'
1919       include 'COMMON.CALC'
1920       include 'COMMON.CONTROL'
1921       include 'COMMON.SPLITELE'
1922       include 'COMMON.SBRIDGE'
1923       logical lprn
1924       double precision evdw
1925       integer itypi,itypj,itypi1,iint,ind,ikont
1926       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1927       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1928      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
1929       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1930       double precision boxshift
1931       evdw=0.0D0
1932 ccccc      energy_dec=.false.
1933 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1934       evdw=0.0D0
1935       lprn=.false.
1936 c     if (icall.eq.0) lprn=.false.
1937       ind=0
1938 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1939 C we have the original box)
1940 C      do xshift=-1,1
1941 C      do yshift=-1,1
1942 C      do zshift=-1,1
1943 c      do i=iatsc_s,iatsc_e
1944       do ikont=g_listscsc_start,g_listscsc_end
1945         i=newcontlisti(ikont)
1946         j=newcontlistj(ikont)
1947         itypi=iabs(itype(i))
1948         if (itypi.eq.ntyp1) cycle
1949         itypi1=iabs(itype(i+1))
1950         xi=c(1,nres+i)
1951         yi=c(2,nres+i)
1952         zi=c(3,nres+i)
1953         call to_box(xi,yi,zi)
1954 C define scaling factor for lipids
1955
1956 C        if (positi.le.0) positi=positi+boxzsize
1957 C        print *,i
1958 C first for peptide groups
1959 c for each residue check if it is in lipid or lipid water border area
1960         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1961 C          xi=xi+xshift*boxxsize
1962 C          yi=yi+yshift*boxysize
1963 C          zi=zi+zshift*boxzsize
1964
1965         dxi=dc_norm(1,nres+i)
1966         dyi=dc_norm(2,nres+i)
1967         dzi=dc_norm(3,nres+i)
1968 c        dsci_inv=dsc_inv(itypi)
1969         dsci_inv=vbld_inv(i+nres)
1970 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1971 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1972 C
1973 C Calculate SC interaction energy.
1974 C
1975 c        do iint=1,nint_gr(i)
1976 c          do j=istart(i,iint),iend(i,iint)
1977             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1978
1979 c              write(iout,*) "PRZED ZWYKLE", evdwij
1980               call dyn_ssbond_ene(i,j,evdwij)
1981 c              write(iout,*) "PO ZWYKLE", evdwij
1982
1983               evdw=evdw+evdwij
1984               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1985      &                        'evdw',i,j,evdwij,' ss'
1986 C triple bond artifac removal
1987               do k=j+1,iend(i,iint)
1988 C search over all next residues
1989                 if (dyn_ss_mask(k)) then
1990 C check if they are cysteins
1991 C              write(iout,*) 'k=',k
1992
1993 c              write(iout,*) "PRZED TRI", evdwij
1994                   evdwij_przed_tri=evdwij
1995                   call triple_ssbond_ene(i,j,k,evdwij)
1996 c               if(evdwij_przed_tri.ne.evdwij) then
1997 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1998 c               endif
1999
2000 c              write(iout,*) "PO TRI", evdwij
2001 C call the energy function that removes the artifical triple disulfide
2002 C bond the soubroutine is located in ssMD.F
2003                   evdw=evdw+evdwij
2004                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2005      &                        'evdw',i,j,evdwij,'tss'
2006                 endif!dyn_ss_mask(k)
2007               enddo! k
2008             ELSE
2009               ind=ind+1
2010               itypj=iabs(itype(j))
2011               if (itypj.eq.ntyp1) cycle
2012 c            dscj_inv=dsc_inv(itypj)
2013               dscj_inv=vbld_inv(j+nres)
2014 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2015 c     &       1.0d0/vbld(j+nres)
2016 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2017               sig0ij=sigma(itypi,itypj)
2018               chi1=chi(itypi,itypj)
2019               chi2=chi(itypj,itypi)
2020               chi12=chi1*chi2
2021               chip1=chip(itypi)
2022               chip2=chip(itypj)
2023               chip12=chip1*chip2
2024               alf1=alp(itypi)
2025               alf2=alp(itypj)
2026               alf12=0.5D0*(alf1+alf2)
2027 C For diagnostics only!!!
2028 c           chi1=0.0D0
2029 c           chi2=0.0D0
2030 c           chi12=0.0D0
2031 c           chip1=0.0D0
2032 c           chip2=0.0D0
2033 c           chip12=0.0D0
2034 c           alf1=0.0D0
2035 c           alf2=0.0D0
2036 c           alf12=0.0D0
2037               xj=c(1,nres+j)
2038               yj=c(2,nres+j)
2039               zj=c(3,nres+j)
2040               call to_box(xj,yj,zj)
2041               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2042               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2043      &          +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2044               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2045      &          +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2046 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2047 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2048 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2049 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2050 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2051               xj=boxshift(xj-xi,boxxsize)
2052               yj=boxshift(yj-yi,boxysize)
2053               zj=boxshift(zj-zi,boxzsize)
2054               dxj=dc_norm(1,nres+j)
2055               dyj=dc_norm(2,nres+j)
2056               dzj=dc_norm(3,nres+j)
2057 C            xj=xj-xi
2058 C            yj=yj-yi
2059 C            zj=zj-zi
2060 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2061 c            write (iout,*) "j",j," dc_norm",
2062 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2063               rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2064               rij=dsqrt(rrij)
2065               sss=sscale(1.0d0/rij,r_cut_int)
2066 c            write (iout,'(a7,4f8.3)')
2067 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2068               if (sss.eq.0.0d0) cycle
2069               sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2070 C Calculate angle-dependent terms of energy and contributions to their
2071 C derivatives.
2072               call sc_angular
2073               sigsq=1.0D0/sigsq
2074               sig=sig0ij*dsqrt(sigsq)
2075               rij_shift=1.0D0/rij-sig+sig0ij
2076 c              if (energy_dec)
2077 c     &        write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2078 c     &       " sig",sig," sig0ij",sig0ij
2079 c for diagnostics; uncomment
2080 c            rij_shift=1.2*sig0ij
2081 C I hate to put IF's in the loops, but here don't have another choice!!!!
2082               if (rij_shift.le.0.0D0) then
2083                 evdw=1.0D20
2084 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2085 cd     &        restyp(itypi),i,restyp(itypj),j,
2086 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2087 c                return
2088               endif
2089               sigder=-sig*sigsq
2090 c---------------------------------------------------------------
2091               rij_shift=1.0D0/rij_shift
2092               fac=rij_shift**expon
2093 C here to start with
2094 C            if (c(i,3).gt.
2095               faclip=fac
2096               e1=fac*fac*aa
2097               e2=fac*bb
2098               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2099               eps2der=evdwij*eps3rt
2100               eps3der=evdwij*eps2rt
2101 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2102 C     &((sslipi+sslipj)/2.0d0+
2103 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2104 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2105 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2106               evdwij=evdwij*eps2rt*eps3rt
2107               evdw=evdw+evdwij*sss
2108               if (lprn) then
2109                 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2110                 epsi=bb**2/aa
2111                 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2112      &           restyp(itypi),i,restyp(itypj),j,
2113      &           epsi,sigm,chi1,chi2,chip1,chip2,
2114      &           eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2115      &           om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2116      &           evdwij
2117               endif
2118
2119               if (energy_dec) write (iout,'(a,2i5,2f10.5,e15.5)')
2120      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2121
2122 C Calculate gradient components.
2123               e1=e1*eps1*eps2rt**2*eps3rt**2
2124               fac=-expon*(e1+evdwij)*rij_shift
2125               sigder=fac*sigder
2126               fac=rij*fac
2127 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2128 c     &      evdwij,fac,sigma(itypi,itypj),expon
2129               fac=fac+evdwij*sssgrad/sss*rij
2130 c            fac=0.0d0
2131 C Calculate the radial part of the gradient
2132               gg_lipi(3)=eps1*(eps2rt*eps2rt)
2133      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2134      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2135      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2136               gg_lipj(3)=ssgradlipj*gg_lipi(3)
2137               gg_lipi(3)=gg_lipi(3)*ssgradlipi
2138 C            gg_lipi(3)=0.0d0
2139 C            gg_lipj(3)=0.0d0
2140               gg(1)=xj*fac
2141               gg(2)=yj*fac
2142               gg(3)=zj*fac
2143 C Calculate angular part of the gradient.
2144 c            call sc_grad_scale(sss)
2145               call sc_grad
2146             ENDIF    ! dyn_ss
2147 c          enddo      ! j
2148 c        enddo        ! iint
2149       enddo          ! i
2150 C      enddo          ! zshift
2151 C      enddo          ! yshift
2152 C      enddo          ! xshift
2153 c      write (iout,*) "Number of loop steps in EGB:",ind
2154 cccc      energy_dec=.false.
2155       return
2156       end
2157 C-----------------------------------------------------------------------------
2158       subroutine egbv(evdw)
2159 C
2160 C This subroutine calculates the interaction energy of nonbonded side chains
2161 C assuming the Gay-Berne-Vorobjev potential of interaction.
2162 C
2163       implicit none
2164       include 'DIMENSIONS'
2165       include 'COMMON.GEO'
2166       include 'COMMON.VAR'
2167       include 'COMMON.LOCAL'
2168       include 'COMMON.CHAIN'
2169       include 'COMMON.DERIV'
2170       include 'COMMON.NAMES'
2171       include 'COMMON.INTERACT'
2172       include 'COMMON.IOUNITS'
2173       include 'COMMON.CALC'
2174       include 'COMMON.SPLITELE'
2175       double precision boxshift
2176       integer icall
2177       common /srutu/ icall
2178       logical lprn
2179       double precision evdw
2180       integer itypi,itypj,itypi1,iint,ind,ikont
2181       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2182      & xi,yi,zi,fac_augm,e_augm
2183       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2184      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2185       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2186       evdw=0.0D0
2187 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2188       evdw=0.0D0
2189       lprn=.false.
2190 c     if (icall.eq.0) lprn=.true.
2191       ind=0
2192 c      do i=iatsc_s,iatsc_e
2193       do ikont=g_listscsc_start,g_listscsc_end
2194         i=newcontlisti(ikont)
2195         j=newcontlistj(ikont)
2196         itypi=iabs(itype(i))
2197         if (itypi.eq.ntyp1) cycle
2198         itypi1=iabs(itype(i+1))
2199         xi=c(1,nres+i)
2200         yi=c(2,nres+i)
2201         zi=c(3,nres+i)
2202         call to_box(xi,yi,zi)
2203 C define scaling factor for lipids
2204
2205 C        if (positi.le.0) positi=positi+boxzsize
2206 C        print *,i
2207 C first for peptide groups
2208 c for each residue check if it is in lipid or lipid water border area
2209         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2210         dxi=dc_norm(1,nres+i)
2211         dyi=dc_norm(2,nres+i)
2212         dzi=dc_norm(3,nres+i)
2213 c        dsci_inv=dsc_inv(itypi)
2214         dsci_inv=vbld_inv(i+nres)
2215 C
2216 C Calculate SC interaction energy.
2217 C
2218 c        do iint=1,nint_gr(i)
2219 c          do j=istart(i,iint),iend(i,iint)
2220             ind=ind+1
2221             itypj=iabs(itype(j))
2222             if (itypj.eq.ntyp1) cycle
2223 c            dscj_inv=dsc_inv(itypj)
2224             dscj_inv=vbld_inv(j+nres)
2225             sig0ij=sigma(itypi,itypj)
2226             r0ij=r0(itypi,itypj)
2227             chi1=chi(itypi,itypj)
2228             chi2=chi(itypj,itypi)
2229             chi12=chi1*chi2
2230             chip1=chip(itypi)
2231             chip2=chip(itypj)
2232             chip12=chip1*chip2
2233             alf1=alp(itypi)
2234             alf2=alp(itypj)
2235             alf12=0.5D0*(alf1+alf2)
2236 C For diagnostics only!!!
2237 c           chi1=0.0D0
2238 c           chi2=0.0D0
2239 c           chi12=0.0D0
2240 c           chip1=0.0D0
2241 c           chip2=0.0D0
2242 c           chip12=0.0D0
2243 c           alf1=0.0D0
2244 c           alf2=0.0D0
2245 c           alf12=0.0D0
2246            xj=c(1,nres+j)
2247            yj=c(2,nres+j)
2248            zj=c(3,nres+j)
2249            call to_box(xj,yj,zj)
2250            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2251            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2252      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2253            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2254      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2255 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2256 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2257 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2258            xj=boxshift(xj-xi,boxxsize)
2259            yj=boxshift(yj-yi,boxysize)
2260            zj=boxshift(zj-zi,boxzsize)
2261            dxj=dc_norm(1,nres+j)
2262            dyj=dc_norm(2,nres+j)
2263            dzj=dc_norm(3,nres+j)
2264            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2265            rij=dsqrt(rrij)
2266            sss=sscale(1.0d0/rij,r_cut_int)
2267            if (sss.eq.0.0d0) cycle
2268            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2269 C Calculate angle-dependent terms of energy and contributions to their
2270 C derivatives.
2271            call sc_angular
2272            sigsq=1.0D0/sigsq
2273            sig=sig0ij*dsqrt(sigsq)
2274            rij_shift=1.0D0/rij-sig+r0ij
2275 C I hate to put IF's in the loops, but here don't have another choice!!!!
2276            if (rij_shift.le.0.0D0) then
2277              evdw=1.0D20
2278              return
2279            endif
2280            sigder=-sig*sigsq
2281 c---------------------------------------------------------------
2282            rij_shift=1.0D0/rij_shift
2283            fac=rij_shift**expon
2284            e1=fac*fac*aa
2285            e2=fac*bb
2286            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2287            eps2der=evdwij*eps3rt
2288            eps3der=evdwij*eps2rt
2289            fac_augm=rrij**expon
2290            e_augm=augm(itypi,itypj)*fac_augm
2291            evdwij=evdwij*eps2rt*eps3rt
2292            evdw=evdw+evdwij+e_augm
2293            if (lprn) then
2294              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2295              epsi=bb**2/aa
2296              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2297      &        restyp(itypi),i,restyp(itypj),j,
2298      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2299      &        chi1,chi2,chip1,chip2,
2300      &        eps1,eps2rt**2,eps3rt**2,
2301      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2302      &        evdwij+e_augm
2303            endif
2304 C Calculate gradient components.
2305            e1=e1*eps1*eps2rt**2*eps3rt**2
2306            fac=-expon*(e1+evdwij)*rij_shift
2307            sigder=fac*sigder
2308            fac=rij*fac-2*expon*rrij*e_augm
2309            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2310 C Calculate the radial part of the gradient
2311            gg_lipi(3)=eps1*(eps2rt*eps2rt)
2312      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2313      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2314      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2315            gg_lipj(3)=ssgradlipj*gg_lipi(3)
2316            gg_lipi(3)=gg_lipi(3)*ssgradlipi
2317            gg(1)=xj*fac
2318            gg(2)=yj*fac
2319            gg(3)=zj*fac
2320 C Calculate angular part of the gradient.
2321 c            call sc_grad_scale(sss)
2322            call sc_grad
2323 c          enddo      ! j
2324 c        enddo        ! iint
2325       enddo          ! i
2326       end
2327 C-----------------------------------------------------------------------------
2328       subroutine sc_angular
2329 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2330 C om12. Called by ebp, egb, and egbv.
2331       implicit none
2332       include 'COMMON.CALC'
2333       include 'COMMON.IOUNITS'
2334       erij(1)=xj*rij
2335       erij(2)=yj*rij
2336       erij(3)=zj*rij
2337       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2338       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2339       om12=dxi*dxj+dyi*dyj+dzi*dzj
2340       chiom12=chi12*om12
2341 C Calculate eps1(om12) and its derivative in om12
2342       faceps1=1.0D0-om12*chiom12
2343       faceps1_inv=1.0D0/faceps1
2344       eps1=dsqrt(faceps1_inv)
2345 C Following variable is eps1*deps1/dom12
2346       eps1_om12=faceps1_inv*chiom12
2347 c diagnostics only
2348 c      faceps1_inv=om12
2349 c      eps1=om12
2350 c      eps1_om12=1.0d0
2351 c      write (iout,*) "om12",om12," eps1",eps1
2352 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2353 C and om12.
2354       om1om2=om1*om2
2355       chiom1=chi1*om1
2356       chiom2=chi2*om2
2357       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2358       sigsq=1.0D0-facsig*faceps1_inv
2359       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2360       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2361       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2362 c diagnostics only
2363 c      sigsq=1.0d0
2364 c      sigsq_om1=0.0d0
2365 c      sigsq_om2=0.0d0
2366 c      sigsq_om12=0.0d0
2367 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2368 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2369 c     &    " eps1",eps1
2370 C Calculate eps2 and its derivatives in om1, om2, and om12.
2371       chipom1=chip1*om1
2372       chipom2=chip2*om2
2373       chipom12=chip12*om12
2374       facp=1.0D0-om12*chipom12
2375       facp_inv=1.0D0/facp
2376       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2377 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2378 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2379 C Following variable is the square root of eps2
2380       eps2rt=1.0D0-facp1*facp_inv
2381 C Following three variables are the derivatives of the square root of eps
2382 C in om1, om2, and om12.
2383       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2384       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2385       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2386 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2387       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2388 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2389 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2390 c     &  " eps2rt_om12",eps2rt_om12
2391 C Calculate whole angle-dependent part of epsilon and contributions
2392 C to its derivatives
2393       return
2394       end
2395 C----------------------------------------------------------------------------
2396       subroutine sc_grad
2397       implicit real*8 (a-h,o-z)
2398       include 'DIMENSIONS'
2399       include 'COMMON.CHAIN'
2400       include 'COMMON.DERIV'
2401       include 'COMMON.CALC'
2402       include 'COMMON.IOUNITS'
2403       double precision dcosom1(3),dcosom2(3)
2404 cc      print *,'sss=',sss
2405       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2406       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2407       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2408      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2409 c diagnostics only
2410 c      eom1=0.0d0
2411 c      eom2=0.0d0
2412 c      eom12=evdwij*eps1_om12
2413 c end diagnostics
2414 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2415 c     &  " sigder",sigder
2416 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2417 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2418       do k=1,3
2419         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2420         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2421       enddo
2422       do k=1,3
2423         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2424       enddo
2425 c      write (iout,*) "gg",(gg(k),k=1,3)
2426       do k=1,3
2427         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2428      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2429      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2430         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2431      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2432      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2433 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2434 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2435 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2436 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2437       enddo
2438 C
2439 C Calculate the components of the gradient in DC and X
2440 C
2441 cgrad      do k=i,j-1
2442 cgrad        do l=1,3
2443 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2444 cgrad        enddo
2445 cgrad      enddo
2446       do l=1,3
2447         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2448         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2449       enddo
2450       return
2451       end
2452 C-----------------------------------------------------------------------
2453       subroutine e_softsphere(evdw)
2454 C
2455 C This subroutine calculates the interaction energy of nonbonded side chains
2456 C assuming the LJ potential of interaction.
2457 C
2458       implicit real*8 (a-h,o-z)
2459       include 'DIMENSIONS'
2460       parameter (accur=1.0d-10)
2461       include 'COMMON.GEO'
2462       include 'COMMON.VAR'
2463       include 'COMMON.LOCAL'
2464       include 'COMMON.CHAIN'
2465       include 'COMMON.DERIV'
2466       include 'COMMON.INTERACT'
2467       include 'COMMON.TORSION'
2468       include 'COMMON.SBRIDGE'
2469       include 'COMMON.NAMES'
2470       include 'COMMON.IOUNITS'
2471 c      include 'COMMON.CONTACTS'
2472       dimension gg(3)
2473       double precision boxshift
2474 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2475       evdw=0.0D0
2476 c      do i=iatsc_s,iatsc_e
2477       do ikont=g_listscsc_start,g_listscsc_end
2478         i=newcontlisti(ikont)
2479         j=newcontlistj(ikont)
2480         itypi=iabs(itype(i))
2481         if (itypi.eq.ntyp1) cycle
2482         itypi1=iabs(itype(i+1))
2483         xi=c(1,nres+i)
2484         yi=c(2,nres+i)
2485         zi=c(3,nres+i)
2486         call to_box(xi,yi,zi)
2487 C
2488 C Calculate SC interaction energy.
2489 C
2490 c        do iint=1,nint_gr(i)
2491 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2492 cd   &                  'iend=',iend(i,iint)
2493 c          do j=istart(i,iint),iend(i,iint)
2494             itypj=iabs(itype(j))
2495             if (itypj.eq.ntyp1) cycle
2496             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2497             yj=boxshift(c(2,nres+j)-yi,boxysize)
2498             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2499             rij=xj*xj+yj*yj+zj*zj
2500 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2501             r0ij=r0(itypi,itypj)
2502             r0ijsq=r0ij*r0ij
2503 c            print *,i,j,r0ij,dsqrt(rij)
2504             if (rij.lt.r0ijsq) then
2505               evdwij=0.25d0*(rij-r0ijsq)**2
2506               fac=rij-r0ijsq
2507             else
2508               evdwij=0.0d0
2509               fac=0.0d0
2510             endif
2511             evdw=evdw+evdwij
2512 C
2513 C Calculate the components of the gradient in DC and X
2514 C
2515             gg(1)=xj*fac
2516             gg(2)=yj*fac
2517             gg(3)=zj*fac
2518             do k=1,3
2519               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2520               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2521               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2522               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2523             enddo
2524 cgrad            do k=i,j-1
2525 cgrad              do l=1,3
2526 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2527 cgrad              enddo
2528 cgrad            enddo
2529 c          enddo ! j
2530 c        enddo ! iint
2531       enddo ! i
2532       return
2533       end
2534 C--------------------------------------------------------------------------
2535       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2536      &              eello_turn4)
2537 C
2538 C Soft-sphere potential of p-p interaction
2539 C
2540       implicit real*8 (a-h,o-z)
2541       include 'DIMENSIONS'
2542       include 'COMMON.CONTROL'
2543       include 'COMMON.IOUNITS'
2544       include 'COMMON.GEO'
2545       include 'COMMON.VAR'
2546       include 'COMMON.LOCAL'
2547       include 'COMMON.CHAIN'
2548       include 'COMMON.DERIV'
2549       include 'COMMON.INTERACT'
2550 c      include 'COMMON.CONTACTS'
2551       include 'COMMON.TORSION'
2552       include 'COMMON.VECTORS'
2553       include 'COMMON.FFIELD'
2554       dimension ggg(3)
2555       double precision boxshift
2556 C      write(iout,*) 'In EELEC_soft_sphere'
2557       ees=0.0D0
2558       evdw1=0.0D0
2559       eel_loc=0.0d0
2560       eello_turn3=0.0d0
2561       eello_turn4=0.0d0
2562       ind=0
2563       do i=iatel_s,iatel_e
2564         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2565         dxi=dc(1,i)
2566         dyi=dc(2,i)
2567         dzi=dc(3,i)
2568         xmedi=c(1,i)+0.5d0*dxi
2569         ymedi=c(2,i)+0.5d0*dyi
2570         zmedi=c(3,i)+0.5d0*dzi
2571         call to_box(xmedi,ymedi,zmedi)
2572         num_conti=0
2573 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2574         do j=ielstart(i),ielend(i)
2575           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2576           ind=ind+1
2577           iteli=itel(i)
2578           itelj=itel(j)
2579           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2580           r0ij=rpp(iteli,itelj)
2581           r0ijsq=r0ij*r0ij
2582           dxj=dc(1,j)
2583           dyj=dc(2,j)
2584           dzj=dc(3,j)
2585           xj=c(1,j)+0.5D0*dxj
2586           yj=c(2,j)+0.5D0*dyj
2587           zj=c(3,j)+0.5D0*dzj
2588           call to_box(xj,yj,zj)
2589           xj=boxshift(xj-xmedi,boxxsize)
2590           yj=boxshift(yj-ymedi,boxysize)
2591           zj=boxshift(zj-zmedi,boxzsize)
2592           rij=xj*xj+yj*yj+zj*zj
2593             sss=sscale(sqrt(rij),r_cut_int)
2594             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2595           if (rij.lt.r0ijsq) then
2596             evdw1ij=0.25d0*(rij-r0ijsq)**2
2597             fac=rij-r0ijsq
2598           else
2599             evdw1ij=0.0d0
2600             fac=0.0d0
2601           endif
2602           evdw1=evdw1+evdw1ij*sss
2603 C
2604 C Calculate contributions to the Cartesian gradient.
2605 C
2606           ggg(1)=fac*xj*sssgrad
2607           ggg(2)=fac*yj*sssgrad
2608           ggg(3)=fac*zj*sssgrad
2609           do k=1,3
2610             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2611             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2612           enddo
2613 *
2614 * Loop over residues i+1 thru j-1.
2615 *
2616 cgrad          do k=i+1,j-1
2617 cgrad            do l=1,3
2618 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2619 cgrad            enddo
2620 cgrad          enddo
2621         enddo ! j
2622       enddo   ! i
2623 cgrad      do i=nnt,nct-1
2624 cgrad        do k=1,3
2625 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2626 cgrad        enddo
2627 cgrad        do j=i+1,nct-1
2628 cgrad          do k=1,3
2629 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2630 cgrad          enddo
2631 cgrad        enddo
2632 cgrad      enddo
2633       return
2634       end
2635 c------------------------------------------------------------------------------
2636       subroutine vec_and_deriv
2637       implicit real*8 (a-h,o-z)
2638       include 'DIMENSIONS'
2639 #ifdef MPI
2640       include 'mpif.h'
2641 #endif
2642       include 'COMMON.IOUNITS'
2643       include 'COMMON.GEO'
2644       include 'COMMON.VAR'
2645       include 'COMMON.LOCAL'
2646       include 'COMMON.CHAIN'
2647       include 'COMMON.VECTORS'
2648       include 'COMMON.SETUP'
2649       include 'COMMON.TIME1'
2650       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2651 C Compute the local reference systems. For reference system (i), the
2652 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2653 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2654 #ifdef PARVEC
2655       do i=ivec_start,ivec_end
2656 #else
2657       do i=1,nres-1
2658 #endif
2659           if (i.eq.nres-1) then
2660 C Case of the last full residue
2661 C Compute the Z-axis
2662             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2663             costh=dcos(pi-theta(nres))
2664             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2665             do k=1,3
2666               uz(k,i)=fac*uz(k,i)
2667             enddo
2668 C Compute the derivatives of uz
2669             uzder(1,1,1)= 0.0d0
2670             uzder(2,1,1)=-dc_norm(3,i-1)
2671             uzder(3,1,1)= dc_norm(2,i-1)
2672             uzder(1,2,1)= dc_norm(3,i-1)
2673             uzder(2,2,1)= 0.0d0
2674             uzder(3,2,1)=-dc_norm(1,i-1)
2675             uzder(1,3,1)=-dc_norm(2,i-1)
2676             uzder(2,3,1)= dc_norm(1,i-1)
2677             uzder(3,3,1)= 0.0d0
2678             uzder(1,1,2)= 0.0d0
2679             uzder(2,1,2)= dc_norm(3,i)
2680             uzder(3,1,2)=-dc_norm(2,i)
2681             uzder(1,2,2)=-dc_norm(3,i)
2682             uzder(2,2,2)= 0.0d0
2683             uzder(3,2,2)= dc_norm(1,i)
2684             uzder(1,3,2)= dc_norm(2,i)
2685             uzder(2,3,2)=-dc_norm(1,i)
2686             uzder(3,3,2)= 0.0d0
2687 C Compute the Y-axis
2688             facy=fac
2689             do k=1,3
2690               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2691             enddo
2692 C Compute the derivatives of uy
2693             do j=1,3
2694               do k=1,3
2695                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2696      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2697                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2698               enddo
2699               uyder(j,j,1)=uyder(j,j,1)-costh
2700               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2701             enddo
2702             do j=1,2
2703               do k=1,3
2704                 do l=1,3
2705                   uygrad(l,k,j,i)=uyder(l,k,j)
2706                   uzgrad(l,k,j,i)=uzder(l,k,j)
2707                 enddo
2708               enddo
2709             enddo
2710             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2711             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2712             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2713             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2714           else
2715 C Other residues
2716 C Compute the Z-axis
2717             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2718             costh=dcos(pi-theta(i+2))
2719             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2720             do k=1,3
2721               uz(k,i)=fac*uz(k,i)
2722             enddo
2723 C Compute the derivatives of uz
2724             uzder(1,1,1)= 0.0d0
2725             uzder(2,1,1)=-dc_norm(3,i+1)
2726             uzder(3,1,1)= dc_norm(2,i+1)
2727             uzder(1,2,1)= dc_norm(3,i+1)
2728             uzder(2,2,1)= 0.0d0
2729             uzder(3,2,1)=-dc_norm(1,i+1)
2730             uzder(1,3,1)=-dc_norm(2,i+1)
2731             uzder(2,3,1)= dc_norm(1,i+1)
2732             uzder(3,3,1)= 0.0d0
2733             uzder(1,1,2)= 0.0d0
2734             uzder(2,1,2)= dc_norm(3,i)
2735             uzder(3,1,2)=-dc_norm(2,i)
2736             uzder(1,2,2)=-dc_norm(3,i)
2737             uzder(2,2,2)= 0.0d0
2738             uzder(3,2,2)= dc_norm(1,i)
2739             uzder(1,3,2)= dc_norm(2,i)
2740             uzder(2,3,2)=-dc_norm(1,i)
2741             uzder(3,3,2)= 0.0d0
2742 C Compute the Y-axis
2743             facy=fac
2744             do k=1,3
2745               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2746             enddo
2747 C Compute the derivatives of uy
2748             do j=1,3
2749               do k=1,3
2750                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2751      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2752                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2753               enddo
2754               uyder(j,j,1)=uyder(j,j,1)-costh
2755               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2756             enddo
2757             do j=1,2
2758               do k=1,3
2759                 do l=1,3
2760                   uygrad(l,k,j,i)=uyder(l,k,j)
2761                   uzgrad(l,k,j,i)=uzder(l,k,j)
2762                 enddo
2763               enddo
2764             enddo
2765             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2766             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2767             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2768             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2769           endif
2770       enddo
2771       do i=1,nres-1
2772         vbld_inv_temp(1)=vbld_inv(i+1)
2773         if (i.lt.nres-1) then
2774           vbld_inv_temp(2)=vbld_inv(i+2)
2775           else
2776           vbld_inv_temp(2)=vbld_inv(i)
2777           endif
2778         do j=1,2
2779           do k=1,3
2780             do l=1,3
2781               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2782               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2783             enddo
2784           enddo
2785         enddo
2786       enddo
2787 #if defined(PARVEC) && defined(MPI)
2788       if (nfgtasks1.gt.1) then
2789         time00=MPI_Wtime()
2790 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2791 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2792 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2793         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2795      &   FG_COMM1,IERR)
2796         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2800      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2801      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2802         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2803      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2804      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2805         time_gather=time_gather+MPI_Wtime()-time00
2806       endif
2807 #endif
2808 #ifdef DEBUG
2809       if (fg_rank.eq.0) then
2810         write (iout,*) "Arrays UY and UZ"
2811         do i=1,nres-1
2812           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2813      &     (uz(k,i),k=1,3)
2814         enddo
2815       endif
2816 #endif
2817       return
2818       end
2819 C--------------------------------------------------------------------------
2820       subroutine set_matrices
2821       implicit real*8 (a-h,o-z)
2822       include 'DIMENSIONS'
2823 #ifdef MPI
2824       include "mpif.h"
2825       include "COMMON.SETUP"
2826       integer IERR
2827       integer status(MPI_STATUS_SIZE)
2828 #endif
2829       include 'COMMON.IOUNITS'
2830       include 'COMMON.GEO'
2831       include 'COMMON.VAR'
2832       include 'COMMON.LOCAL'
2833       include 'COMMON.CHAIN'
2834       include 'COMMON.DERIV'
2835       include 'COMMON.INTERACT'
2836       include 'COMMON.CORRMAT'
2837       include 'COMMON.TORSION'
2838       include 'COMMON.VECTORS'
2839       include 'COMMON.FFIELD'
2840       double precision auxvec(2),auxmat(2,2)
2841 C
2842 C Compute the virtual-bond-torsional-angle dependent quantities needed
2843 C to calculate the el-loc multibody terms of various order.
2844 C
2845 c      write(iout,*) 'nphi=',nphi,nres
2846 c      write(iout,*) "itype2loc",itype2loc
2847 #ifdef PARMAT
2848       do i=ivec_start+2,ivec_end+2
2849 #else
2850       do i=3,nres+1
2851 #endif
2852         ii=ireschain(i-2)
2853 c        write (iout,*) "i",i,i-2," ii",ii
2854         if (ii.eq.0) cycle
2855         innt=chain_border(1,ii)
2856         inct=chain_border(2,ii)
2857 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2858 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2859         if (i.gt. innt+2 .and. i.lt.inct+2) then
2860           iti = itype2loc(itype(i-2))
2861         else
2862           iti=nloctyp
2863         endif
2864 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2865         if (i.gt. innt+1 .and. i.lt.inct+1) then
2866           iti1 = itype2loc(itype(i-1))
2867         else
2868           iti1=nloctyp
2869         endif
2870 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2871 c     &  " iti1",itype(i-1),iti1
2872 #ifdef NEWCORR
2873         cost1=dcos(theta(i-1))
2874         sint1=dsin(theta(i-1))
2875         sint1sq=sint1*sint1
2876         sint1cub=sint1sq*sint1
2877         sint1cost1=2*sint1*cost1
2878 c        write (iout,*) "bnew1",i,iti
2879 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2880 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2881 c        write (iout,*) "bnew2",i,iti
2882 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2883 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2884         do k=1,2
2885           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2886           b1(k,i-2)=sint1*b1k
2887           gtb1(k,i-2)=cost1*b1k-sint1sq*
2888      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2889           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2890           b2(k,i-2)=sint1*b2k
2891           gtb2(k,i-2)=cost1*b2k-sint1sq*
2892      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2893         enddo
2894         do k=1,2
2895           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2896           cc(1,k,i-2)=sint1sq*aux
2897           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2898      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2899           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2900           dd(1,k,i-2)=sint1sq*aux
2901           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2902      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2903         enddo
2904         cc(2,1,i-2)=cc(1,2,i-2)
2905         cc(2,2,i-2)=-cc(1,1,i-2)
2906         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2907         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2908         dd(2,1,i-2)=dd(1,2,i-2)
2909         dd(2,2,i-2)=-dd(1,1,i-2)
2910         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2911         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2912         do k=1,2
2913           do l=1,2
2914             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2915             EE(l,k,i-2)=sint1sq*aux
2916             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2917           enddo
2918         enddo
2919         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2920         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2921         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2922         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2923         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2924         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2925         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2926 c        b1tilde(1,i-2)=b1(1,i-2)
2927 c        b1tilde(2,i-2)=-b1(2,i-2)
2928 c        b2tilde(1,i-2)=b2(1,i-2)
2929 c        b2tilde(2,i-2)=-b2(2,i-2)
2930 #ifdef DEBUG
2931         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2932         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2933         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2934         write (iout,*) 'theta=', theta(i-1)
2935 #endif
2936 #else
2937         if (i.gt. innt+2 .and. i.lt.inct+2) then
2938 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2939           iti = itype2loc(itype(i-2))
2940         else
2941           iti=nloctyp
2942         endif
2943 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2944 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2945         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2946           iti1 = itype2loc(itype(i-1))
2947         else
2948           iti1=nloctyp
2949         endif
2950         b1(1,i-2)=b(3,iti)
2951         b1(2,i-2)=b(5,iti)
2952         b2(1,i-2)=b(2,iti)
2953         b2(2,i-2)=b(4,iti)
2954         do k=1,2
2955           do l=1,2
2956            CC(k,l,i-2)=ccold(k,l,iti)
2957            DD(k,l,i-2)=ddold(k,l,iti)
2958            EE(k,l,i-2)=eeold(k,l,iti)
2959            gtEE(k,l,i-2)=0.0d0
2960           enddo
2961         enddo
2962 #endif
2963         b1tilde(1,i-2)= b1(1,i-2)
2964         b1tilde(2,i-2)=-b1(2,i-2)
2965         b2tilde(1,i-2)= b2(1,i-2)
2966         b2tilde(2,i-2)=-b2(2,i-2)
2967 c
2968         Ctilde(1,1,i-2)= CC(1,1,i-2)
2969         Ctilde(1,2,i-2)= CC(1,2,i-2)
2970         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2971         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2972 c
2973         Dtilde(1,1,i-2)= DD(1,1,i-2)
2974         Dtilde(1,2,i-2)= DD(1,2,i-2)
2975         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2976         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2977 #ifdef DEBUG
2978         write(iout,*) "i",i," iti",iti
2979         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2980         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2981 #endif
2982       enddo
2983       mu=0.0d0
2984 #ifdef PARMAT
2985       do i=ivec_start+2,ivec_end+2
2986 #else
2987       do i=3,nres+1
2988 #endif
2989 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2990         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
2991           sin1=dsin(phi(i))
2992           cos1=dcos(phi(i))
2993           sintab(i-2)=sin1
2994           costab(i-2)=cos1
2995           obrot(1,i-2)=cos1
2996           obrot(2,i-2)=sin1
2997           sin2=dsin(2*phi(i))
2998           cos2=dcos(2*phi(i))
2999           sintab2(i-2)=sin2
3000           costab2(i-2)=cos2
3001           obrot2(1,i-2)=cos2
3002           obrot2(2,i-2)=sin2
3003           Ug(1,1,i-2)=-cos1
3004           Ug(1,2,i-2)=-sin1
3005           Ug(2,1,i-2)=-sin1
3006           Ug(2,2,i-2)= cos1
3007           Ug2(1,1,i-2)=-cos2
3008           Ug2(1,2,i-2)=-sin2
3009           Ug2(2,1,i-2)=-sin2
3010           Ug2(2,2,i-2)= cos2
3011         else
3012           costab(i-2)=1.0d0
3013           sintab(i-2)=0.0d0
3014           obrot(1,i-2)=1.0d0
3015           obrot(2,i-2)=0.0d0
3016           obrot2(1,i-2)=0.0d0
3017           obrot2(2,i-2)=0.0d0
3018           Ug(1,1,i-2)=1.0d0
3019           Ug(1,2,i-2)=0.0d0
3020           Ug(2,1,i-2)=0.0d0
3021           Ug(2,2,i-2)=1.0d0
3022           Ug2(1,1,i-2)=0.0d0
3023           Ug2(1,2,i-2)=0.0d0
3024           Ug2(2,1,i-2)=0.0d0
3025           Ug2(2,2,i-2)=0.0d0
3026         endif
3027         if (i .gt. 3) then
3028           obrot_der(1,i-2)=-sin1
3029           obrot_der(2,i-2)= cos1
3030           Ugder(1,1,i-2)= sin1
3031           Ugder(1,2,i-2)=-cos1
3032           Ugder(2,1,i-2)=-cos1
3033           Ugder(2,2,i-2)=-sin1
3034           dwacos2=cos2+cos2
3035           dwasin2=sin2+sin2
3036           obrot2_der(1,i-2)=-dwasin2
3037           obrot2_der(2,i-2)= dwacos2
3038           Ug2der(1,1,i-2)= dwasin2
3039           Ug2der(1,2,i-2)=-dwacos2
3040           Ug2der(2,1,i-2)=-dwacos2
3041           Ug2der(2,2,i-2)=-dwasin2
3042         else
3043           obrot_der(1,i-2)=0.0d0
3044           obrot_der(2,i-2)=0.0d0
3045           Ugder(1,1,i-2)=0.0d0
3046           Ugder(1,2,i-2)=0.0d0
3047           Ugder(2,1,i-2)=0.0d0
3048           Ugder(2,2,i-2)=0.0d0
3049           obrot2_der(1,i-2)=0.0d0
3050           obrot2_der(2,i-2)=0.0d0
3051           Ug2der(1,1,i-2)=0.0d0
3052           Ug2der(1,2,i-2)=0.0d0
3053           Ug2der(2,1,i-2)=0.0d0
3054           Ug2der(2,2,i-2)=0.0d0
3055         endif
3056 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3057 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3058         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3059           iti = itype2loc(itype(i-2))
3060         else
3061           iti=nloctyp
3062         endif
3063 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3064         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3065           iti1 = itype2loc(itype(i-1))
3066         else
3067           iti1=nloctyp
3068         endif
3069 cd        write (iout,*) '*******i',i,' iti1',iti
3070 cd        write (iout,*) 'b1',b1(:,iti)
3071 cd        write (iout,*) 'b2',b2(:,iti)
3072 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3073 c        if (i .gt. iatel_s+2) then
3074         if (i .gt. nnt+2) then
3075           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3076 #ifdef NEWCORR
3077           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3078 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3079 #endif
3080 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3081 c     &    EE(1,2,iti),EE(2,2,i)
3082           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3083           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3084 c          write(iout,*) "Macierz EUG",
3085 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3086 c     &    eug(2,2,i-2)
3087 #ifdef FOURBODY
3088           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3089      &    then
3090           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3091           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3092           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3093           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3094           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3095           endif
3096 #endif
3097         else
3098           do k=1,2
3099             Ub2(k,i-2)=0.0d0
3100             Ctobr(k,i-2)=0.0d0
3101             Dtobr2(k,i-2)=0.0d0
3102             do l=1,2
3103               EUg(l,k,i-2)=0.0d0
3104               CUg(l,k,i-2)=0.0d0
3105               DUg(l,k,i-2)=0.0d0
3106               DtUg2(l,k,i-2)=0.0d0
3107             enddo
3108           enddo
3109         endif
3110         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3111         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3112         do k=1,2
3113           muder(k,i-2)=Ub2der(k,i-2)
3114         enddo
3115 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3116         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3117           if (itype(i-1).le.ntyp) then
3118             iti1 = itype2loc(itype(i-1))
3119           else
3120             iti1=nloctyp
3121           endif
3122         else
3123           iti1=nloctyp
3124         endif
3125         do k=1,2
3126           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3127 c          mu(k,i-2)=b1(k,i-1)
3128 c          mu(k,i-2)=Ub2(k,i-2)
3129         enddo
3130 #ifdef MUOUT
3131         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3132      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3133      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3134      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3135      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3136      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3137 #endif
3138 cd        write (iout,*) 'mu1',mu1(:,i-2)
3139 cd        write (iout,*) 'mu2',mu2(:,i-2)
3140 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3141 #ifdef FOURBODY
3142         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3143      &  then
3144         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3145         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3146         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3147         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3148         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3149 C Vectors and matrices dependent on a single virtual-bond dihedral.
3150         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3151         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3152         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3153         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3154         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3155         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3156         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3157         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3158         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3159         endif
3160 #endif
3161       enddo
3162 #ifdef FOURBODY
3163 C Matrices dependent on two consecutive virtual-bond dihedrals.
3164 C The order of matrices is from left to right.
3165       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3166      &then
3167 c      do i=max0(ivec_start,2),ivec_end
3168       do i=2,nres-1
3169         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3170         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3171         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3172         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3173         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3174         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3175         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3176         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3177       enddo
3178       endif
3179 #endif
3180 #if defined(MPI) && defined(PARMAT)
3181 #ifdef DEBUG
3182 c      if (fg_rank.eq.0) then
3183         write (iout,*) "Arrays UG and UGDER before GATHER"
3184         do i=1,nres-1
3185           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3186      &     ((ug(l,k,i),l=1,2),k=1,2),
3187      &     ((ugder(l,k,i),l=1,2),k=1,2)
3188         enddo
3189         write (iout,*) "Arrays UG2 and UG2DER"
3190         do i=1,nres-1
3191           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3192      &     ((ug2(l,k,i),l=1,2),k=1,2),
3193      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3194         enddo
3195         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3196         do i=1,nres-1
3197           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3198      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3199      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3200         enddo
3201         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3202         do i=1,nres-1
3203           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3204      &     costab(i),sintab(i),costab2(i),sintab2(i)
3205         enddo
3206         write (iout,*) "Array MUDER"
3207         do i=1,nres-1
3208           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3209         enddo
3210 c      endif
3211 #endif
3212       if (nfgtasks.gt.1) then
3213         time00=MPI_Wtime()
3214 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3215 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3216 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3217 #ifdef MATGATHER
3218         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3219      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3220      &   FG_COMM1,IERR)
3221         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3222      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3223      &   FG_COMM1,IERR)
3224         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3225      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3226      &   FG_COMM1,IERR)
3227         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3228      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3229      &   FG_COMM1,IERR)
3230         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3231      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3232      &   FG_COMM1,IERR)
3233         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3234      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3235      &   FG_COMM1,IERR)
3236         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3237      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3238      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3239         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3240      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3241      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3242         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3243      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3244      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3245         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3246      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3247      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3248 #ifdef FOURBODY
3249         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3250      &  then
3251         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3252      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3253      &   FG_COMM1,IERR)
3254         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3255      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3256      &   FG_COMM1,IERR)
3257         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3258      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3259      &   FG_COMM1,IERR)
3260        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3261      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3262      &   FG_COMM1,IERR)
3263         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3264      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3265      &   FG_COMM1,IERR)
3266         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3267      &   ivec_count(fg_rank1),
3268      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3269      &   FG_COMM1,IERR)
3270         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3271      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3272      &   FG_COMM1,IERR)
3273         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3274      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3275      &   FG_COMM1,IERR)
3276         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3277      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3278      &   FG_COMM1,IERR)
3279         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3280      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3281      &   FG_COMM1,IERR)
3282         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3283      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3284      &   FG_COMM1,IERR)
3285         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3286      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3287      &   FG_COMM1,IERR)
3288         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3289      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3290      &   FG_COMM1,IERR)
3291         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3292      &   ivec_count(fg_rank1),
3293      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3294      &   FG_COMM1,IERR)
3295         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3296      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3297      &   FG_COMM1,IERR)
3298        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3299      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3300      &   FG_COMM1,IERR)
3301         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3302      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3303      &   FG_COMM1,IERR)
3304        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3305      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3306      &   FG_COMM1,IERR)
3307         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3308      &   ivec_count(fg_rank1),
3309      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3310      &   FG_COMM1,IERR)
3311         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3312      &   ivec_count(fg_rank1),
3313      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3314      &   FG_COMM1,IERR)
3315         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3316      &   ivec_count(fg_rank1),
3317      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3318      &   MPI_MAT2,FG_COMM1,IERR)
3319         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3320      &   ivec_count(fg_rank1),
3321      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3322      &   MPI_MAT2,FG_COMM1,IERR)
3323         endif
3324 #endif
3325 #else
3326 c Passes matrix info through the ring
3327       isend=fg_rank1
3328       irecv=fg_rank1-1
3329       if (irecv.lt.0) irecv=nfgtasks1-1
3330       iprev=irecv
3331       inext=fg_rank1+1
3332       if (inext.ge.nfgtasks1) inext=0
3333       do i=1,nfgtasks1-1
3334 c        write (iout,*) "isend",isend," irecv",irecv
3335 c        call flush(iout)
3336         lensend=lentyp(isend)
3337         lenrecv=lentyp(irecv)
3338 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3339 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3340 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3341 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3342 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3343 c        write (iout,*) "Gather ROTAT1"
3344 c        call flush(iout)
3345 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3346 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3347 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3348 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3349 c        write (iout,*) "Gather ROTAT2"
3350 c        call flush(iout)
3351         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3352      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3353      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3354      &   iprev,4400+irecv,FG_COMM,status,IERR)
3355 c        write (iout,*) "Gather ROTAT_OLD"
3356 c        call flush(iout)
3357         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3358      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3359      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3360      &   iprev,5500+irecv,FG_COMM,status,IERR)
3361 c        write (iout,*) "Gather PRECOMP11"
3362 c        call flush(iout)
3363         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3364      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3365      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3366      &   iprev,6600+irecv,FG_COMM,status,IERR)
3367 c        write (iout,*) "Gather PRECOMP12"
3368 c        call flush(iout)
3369 #ifdef FOURBODY
3370         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3371      &  then
3372         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3373      &   MPI_ROTAT2(lensend),inext,7700+isend,
3374      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3375      &   iprev,7700+irecv,FG_COMM,status,IERR)
3376 c        write (iout,*) "Gather PRECOMP21"
3377 c        call flush(iout)
3378         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3379      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3380      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3381      &   iprev,8800+irecv,FG_COMM,status,IERR)
3382 c        write (iout,*) "Gather PRECOMP22"
3383 c        call flush(iout)
3384         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3385      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3386      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3387      &   MPI_PRECOMP23(lenrecv),
3388      &   iprev,9900+irecv,FG_COMM,status,IERR)
3389 #endif
3390 c        write (iout,*) "Gather PRECOMP23"
3391 c        call flush(iout)
3392         endif
3393         isend=irecv
3394         irecv=irecv-1
3395         if (irecv.lt.0) irecv=nfgtasks1-1
3396       enddo
3397 #endif
3398         time_gather=time_gather+MPI_Wtime()-time00
3399       endif
3400 #ifdef DEBUG
3401 c      if (fg_rank.eq.0) then
3402         write (iout,*) "Arrays UG and UGDER"
3403         do i=1,nres-1
3404           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3405      &     ((ug(l,k,i),l=1,2),k=1,2),
3406      &     ((ugder(l,k,i),l=1,2),k=1,2)
3407         enddo
3408         write (iout,*) "Arrays UG2 and UG2DER"
3409         do i=1,nres-1
3410           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3411      &     ((ug2(l,k,i),l=1,2),k=1,2),
3412      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3413         enddo
3414         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3415         do i=1,nres-1
3416           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3417      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3418      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3419         enddo
3420         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3421         do i=1,nres-1
3422           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3423      &     costab(i),sintab(i),costab2(i),sintab2(i)
3424         enddo
3425         write (iout,*) "Array MUDER"
3426         do i=1,nres-1
3427           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3428         enddo
3429 c      endif
3430 #endif
3431 #endif
3432 cd      do i=1,nres
3433 cd        iti = itype2loc(itype(i))
3434 cd        write (iout,*) i
3435 cd        do j=1,2
3436 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3437 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3438 cd        enddo
3439 cd      enddo
3440       return
3441       end
3442 C-----------------------------------------------------------------------------
3443       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3444 C
3445 C This subroutine calculates the average interaction energy and its gradient
3446 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3447 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3448 C The potential depends both on the distance of peptide-group centers and on
3449 C the orientation of the CA-CA virtual bonds.
3450 C
3451       implicit real*8 (a-h,o-z)
3452 #ifdef MPI
3453       include 'mpif.h'
3454 #endif
3455       include 'DIMENSIONS'
3456       include 'COMMON.CONTROL'
3457       include 'COMMON.SETUP'
3458       include 'COMMON.IOUNITS'
3459       include 'COMMON.GEO'
3460       include 'COMMON.VAR'
3461       include 'COMMON.LOCAL'
3462       include 'COMMON.CHAIN'
3463       include 'COMMON.DERIV'
3464       include 'COMMON.INTERACT'
3465 #ifdef FOURBODY
3466       include 'COMMON.CONTACTS'
3467       include 'COMMON.CONTMAT'
3468 #endif
3469       include 'COMMON.CORRMAT'
3470       include 'COMMON.TORSION'
3471       include 'COMMON.VECTORS'
3472       include 'COMMON.FFIELD'
3473       include 'COMMON.TIME1'
3474       include 'COMMON.SPLITELE'
3475       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3476      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3477       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3478      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3479       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3480      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3481      &    num_conti,j1,j2
3482 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3483 #ifdef MOMENT
3484       double precision scal_el /1.0d0/
3485 #else
3486       double precision scal_el /0.5d0/
3487 #endif
3488 C 12/13/98
3489 C 13-go grudnia roku pamietnego...
3490       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3491      &                   0.0d0,1.0d0,0.0d0,
3492      &                   0.0d0,0.0d0,1.0d0/
3493 cd      write(iout,*) 'In EELEC'
3494 cd      do i=1,nloctyp
3495 cd        write(iout,*) 'Type',i
3496 cd        write(iout,*) 'B1',B1(:,i)
3497 cd        write(iout,*) 'B2',B2(:,i)
3498 cd        write(iout,*) 'CC',CC(:,:,i)
3499 cd        write(iout,*) 'DD',DD(:,:,i)
3500 cd        write(iout,*) 'EE',EE(:,:,i)
3501 cd      enddo
3502 cd      call check_vecgrad
3503 cd      stop
3504       if (icheckgrad.eq.1) then
3505         do i=1,nres-1
3506           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3507           do k=1,3
3508             dc_norm(k,i)=dc(k,i)*fac
3509           enddo
3510 c          write (iout,*) 'i',i,' fac',fac
3511         enddo
3512       endif
3513       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3514      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3515      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3516 c        call vec_and_deriv
3517 #ifdef TIMING
3518         time01=MPI_Wtime()
3519 #endif
3520         call set_matrices
3521 #ifdef TIMING
3522         time_mat=time_mat+MPI_Wtime()-time01
3523 #endif
3524       endif
3525 cd      do i=1,nres-1
3526 cd        write (iout,*) 'i=',i
3527 cd        do k=1,3
3528 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3529 cd        enddo
3530 cd        do k=1,3
3531 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3532 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3533 cd        enddo
3534 cd      enddo
3535       t_eelecij=0.0d0
3536       ees=0.0D0
3537       evdw1=0.0D0
3538       eel_loc=0.0d0
3539       eello_turn3=0.0d0
3540       eello_turn4=0.0d0
3541       ind=0
3542 #ifdef FOURBODY
3543       do i=1,nres
3544         num_cont_hb(i)=0
3545       enddo
3546 #endif
3547 cd      print '(a)','Enter EELEC'
3548 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3549       do i=1,nres
3550         gel_loc_loc(i)=0.0d0
3551         gcorr_loc(i)=0.0d0
3552       enddo
3553 c
3554 c
3555 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3556 C
3557 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3558 C
3559 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3560       do i=iturn3_start,iturn3_end
3561 c        if (i.le.1) cycle
3562 C        write(iout,*) "tu jest i",i
3563         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3564 C changes suggested by Ana to avoid out of bounds
3565 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3566 c     & .or.((i+4).gt.nres)
3567 c     & .or.((i-1).le.0)
3568 C end of changes by Ana
3569      &  .or. itype(i+2).eq.ntyp1
3570      &  .or. itype(i+3).eq.ntyp1) cycle
3571 C Adam: Instructions below will switch off existing interactions
3572 c        if(i.gt.1)then
3573 c          if(itype(i-1).eq.ntyp1)cycle
3574 c        end if
3575 c        if(i.LT.nres-3)then
3576 c          if (itype(i+4).eq.ntyp1) cycle
3577 c        end if
3578         dxi=dc(1,i)
3579         dyi=dc(2,i)
3580         dzi=dc(3,i)
3581         dx_normi=dc_norm(1,i)
3582         dy_normi=dc_norm(2,i)
3583         dz_normi=dc_norm(3,i)
3584         xmedi=c(1,i)+0.5d0*dxi
3585         ymedi=c(2,i)+0.5d0*dyi
3586         zmedi=c(3,i)+0.5d0*dzi
3587         call to_box(xmedi,ymedi,zmedi)
3588         num_conti=0
3589         call eelecij(i,i+2,ees,evdw1,eel_loc)
3590         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3591 #ifdef FOURBODY
3592         num_cont_hb(i)=num_conti
3593 #endif
3594       enddo
3595       do i=iturn4_start,iturn4_end
3596         if (i.lt.1) cycle
3597         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3598 C changes suggested by Ana to avoid out of bounds
3599 c     & .or.((i+5).gt.nres)
3600 c     & .or.((i-1).le.0)
3601 C end of changes suggested by Ana
3602      &    .or. itype(i+3).eq.ntyp1
3603      &    .or. itype(i+4).eq.ntyp1
3604 c     &    .or. itype(i+5).eq.ntyp1
3605 c     &    .or. itype(i).eq.ntyp1
3606 c     &    .or. itype(i-1).eq.ntyp1
3607      &                             ) cycle
3608         dxi=dc(1,i)
3609         dyi=dc(2,i)
3610         dzi=dc(3,i)
3611         dx_normi=dc_norm(1,i)
3612         dy_normi=dc_norm(2,i)
3613         dz_normi=dc_norm(3,i)
3614         xmedi=c(1,i)+0.5d0*dxi
3615         ymedi=c(2,i)+0.5d0*dyi
3616         zmedi=c(3,i)+0.5d0*dzi
3617 C Return atom into box, boxxsize is size of box in x dimension
3618 c  194   continue
3619 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3620 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3621 C Condition for being inside the proper box
3622 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3623 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3624 c        go to 194
3625 c        endif
3626 c  195   continue
3627 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3628 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3629 C Condition for being inside the proper box
3630 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3631 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3632 c        go to 195
3633 c        endif
3634 c  196   continue
3635 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3636 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3637 C Condition for being inside the proper box
3638 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3639 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3640 c        go to 196
3641 c        endif
3642         call to_box(xmedi,ymedi,zmedi)
3643 #ifdef FOURBODY
3644         num_conti=num_cont_hb(i)
3645 #endif
3646 c        write(iout,*) "JESTEM W PETLI"
3647         call eelecij(i,i+3,ees,evdw1,eel_loc)
3648         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3649      &   call eturn4(i,eello_turn4)
3650 #ifdef FOURBODY
3651         num_cont_hb(i)=num_conti
3652 #endif
3653       enddo   ! i
3654 C Loop over all neighbouring boxes
3655 C      do xshift=-1,1
3656 C      do yshift=-1,1
3657 C      do zshift=-1,1
3658 c
3659 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3660 c
3661 CTU KURWA
3662 c      do i=iatel_s,iatel_e
3663       do ikont=g_listpp_start,g_listpp_end
3664         i=newcontlistppi(ikont)
3665         j=newcontlistppj(ikont)
3666 C        do i=75,75
3667 c        if (i.le.1) cycle
3668         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3669 C changes suggested by Ana to avoid out of bounds
3670 c     & .or.((i+2).gt.nres)
3671 c     & .or.((i-1).le.0)
3672 C end of changes by Ana
3673 c     &  .or. itype(i+2).eq.ntyp1
3674 c     &  .or. itype(i-1).eq.ntyp1
3675      &                ) cycle
3676         dxi=dc(1,i)
3677         dyi=dc(2,i)
3678         dzi=dc(3,i)
3679         dx_normi=dc_norm(1,i)
3680         dy_normi=dc_norm(2,i)
3681         dz_normi=dc_norm(3,i)
3682         xmedi=c(1,i)+0.5d0*dxi
3683         ymedi=c(2,i)+0.5d0*dyi
3684         zmedi=c(3,i)+0.5d0*dzi
3685         call to_box(xmedi,ymedi,zmedi)
3686 C          xmedi=xmedi+xshift*boxxsize
3687 C          ymedi=ymedi+yshift*boxysize
3688 C          zmedi=zmedi+zshift*boxzsize
3689
3690 C Return tom into box, boxxsize is size of box in x dimension
3691 c  164   continue
3692 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3693 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3694 C Condition for being inside the proper box
3695 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3696 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3697 c        go to 164
3698 c        endif
3699 c  165   continue
3700 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3701 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3702 C Condition for being inside the proper box
3703 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3704 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3705 c        go to 165
3706 c        endif
3707 c  166   continue
3708 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3709 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3710 cC Condition for being inside the proper box
3711 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3712 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3713 c        go to 166
3714 c        endif
3715
3716 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3717 #ifdef FOURBODY
3718         num_conti=num_cont_hb(i)
3719 #endif
3720 C I TU KURWA
3721 c        do j=ielstart(i),ielend(i)
3722 C          do j=16,17
3723 C          write (iout,*) i,j
3724 C         if (j.le.1) cycle
3725         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3726 C changes suggested by Ana to avoid out of bounds
3727 c     & .or.((j+2).gt.nres)
3728 c     & .or.((j-1).le.0)
3729 C end of changes by Ana
3730 c     & .or.itype(j+2).eq.ntyp1
3731 c     & .or.itype(j-1).eq.ntyp1
3732      &) cycle
3733         call eelecij(i,j,ees,evdw1,eel_loc)
3734 c        enddo ! j
3735 #ifdef FOURBODY
3736         num_cont_hb(i)=num_conti
3737 #endif
3738       enddo   ! i
3739 C     enddo   ! zshift
3740 C      enddo   ! yshift
3741 C      enddo   ! xshift
3742
3743 c      write (iout,*) "Number of loop steps in EELEC:",ind
3744 cd      do i=1,nres
3745 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3746 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3747 cd      enddo
3748 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3749 ccc      eel_loc=eel_loc+eello_turn3
3750 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3751       return
3752       end
3753 C-------------------------------------------------------------------------------
3754       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3755       implicit none
3756       include 'DIMENSIONS'
3757 #ifdef MPI
3758       include "mpif.h"
3759 #endif
3760       include 'COMMON.CONTROL'
3761       include 'COMMON.IOUNITS'
3762       include 'COMMON.GEO'
3763       include 'COMMON.VAR'
3764       include 'COMMON.LOCAL'
3765       include 'COMMON.CHAIN'
3766       include 'COMMON.DERIV'
3767       include 'COMMON.INTERACT'
3768 #ifdef FOURBODY
3769       include 'COMMON.CONTACTS'
3770       include 'COMMON.CONTMAT'
3771 #endif
3772       include 'COMMON.CORRMAT'
3773       include 'COMMON.TORSION'
3774       include 'COMMON.VECTORS'
3775       include 'COMMON.FFIELD'
3776       include 'COMMON.TIME1'
3777       include 'COMMON.SPLITELE'
3778       include 'COMMON.SHIELD'
3779       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3780      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3781       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3782      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3783      &    gmuij2(4),gmuji2(4)
3784       double precision dxi,dyi,dzi
3785       double precision dx_normi,dy_normi,dz_normi,aux
3786       integer j1,j2,lll,num_conti
3787       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3788      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3789      &    num_conti,j1,j2
3790       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3791       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3792       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3793       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3794      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3795      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3796      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3797      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3798      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3799      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3800      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3801       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3802       double precision xmedi,ymedi,zmedi
3803       double precision sscale,sscagrad,scalar
3804       double precision boxshift
3805 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3806 #ifdef MOMENT
3807       double precision scal_el /1.0d0/
3808 #else
3809       double precision scal_el /0.5d0/
3810 #endif
3811 C 12/13/98
3812 C 13-go grudnia roku pamietnego...
3813       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3814      &                   0.0d0,1.0d0,0.0d0,
3815      &                   0.0d0,0.0d0,1.0d0/
3816 c          time00=MPI_Wtime()
3817 cd      write (iout,*) "eelecij",i,j
3818 c          ind=ind+1
3819           iteli=itel(i)
3820           itelj=itel(j)
3821           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3822           aaa=app(iteli,itelj)
3823           bbb=bpp(iteli,itelj)
3824           ael6i=ael6(iteli,itelj)
3825           ael3i=ael3(iteli,itelj)
3826           dxj=dc(1,j)
3827           dyj=dc(2,j)
3828           dzj=dc(3,j)
3829           dx_normj=dc_norm(1,j)
3830           dy_normj=dc_norm(2,j)
3831           dz_normj=dc_norm(3,j)
3832 C          xj=c(1,j)+0.5D0*dxj-xmedi
3833 C          yj=c(2,j)+0.5D0*dyj-ymedi
3834 C          zj=c(3,j)+0.5D0*dzj-zmedi
3835           xj=c(1,j)+0.5D0*dxj
3836           yj=c(2,j)+0.5D0*dyj
3837           zj=c(3,j)+0.5D0*dzj
3838           call to_box(xj,yj,zj)
3839           xj=boxshift(xj-xmedi,boxxsize)
3840           yj=boxshift(yj-ymedi,boxysize)
3841           zj=boxshift(zj-zmedi,boxzsize)
3842 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3843 c  174   continue
3844           rij=xj*xj+yj*yj+zj*zj
3845
3846           sss=sscale(dsqrt(rij),r_cut_int)
3847           if (sss.eq.0.0d0) return
3848           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3849 c            if (sss.gt.0.0d0) then
3850           rrmij=1.0D0/rij
3851           rij=dsqrt(rij)
3852           rmij=1.0D0/rij
3853           r3ij=rrmij*rmij
3854           r6ij=r3ij*r3ij
3855           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3856           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3857           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3858           fac=cosa-3.0D0*cosb*cosg
3859           ev1=aaa*r6ij*r6ij
3860 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3861           if (j.eq.i+2) ev1=scal_el*ev1
3862           ev2=bbb*r6ij
3863           fac3=ael6i*r6ij
3864           fac4=ael3i*r3ij
3865           evdwij=(ev1+ev2)
3866           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3867           el2=fac4*fac
3868 C MARYSIA
3869 C          eesij=(el1+el2)
3870 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3871           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3872           if (shield_mode.gt.0) then
3873 C          fac_shield(i)=0.4
3874 C          fac_shield(j)=0.6
3875           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3876           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3877           eesij=(el1+el2)
3878           ees=ees+eesij
3879           else
3880           fac_shield(i)=1.0
3881           fac_shield(j)=1.0
3882           eesij=(el1+el2)
3883           ees=ees+eesij*sss
3884           endif
3885           evdw1=evdw1+evdwij*sss
3886 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3887 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3888 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3889 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3890
3891           if (energy_dec) then
3892             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3893      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3894             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3895      &        fac_shield(i),fac_shield(j)
3896           endif
3897
3898 C
3899 C Calculate contributions to the Cartesian gradient.
3900 C
3901 #ifdef SPLITELE
3902           facvdw=-6*rrmij*(ev1+evdwij)*sss
3903           facel=-3*rrmij*(el1+eesij)
3904           fac1=fac
3905           erij(1)=xj*rmij
3906           erij(2)=yj*rmij
3907           erij(3)=zj*rmij
3908
3909 *
3910 * Radial derivatives. First process both termini of the fragment (i,j)
3911 *
3912           aux=facel*sss+rmij*sssgrad*eesij
3913           ggg(1)=aux*xj
3914           ggg(2)=aux*yj
3915           ggg(3)=aux*zj
3916           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3917      &  (shield_mode.gt.0)) then
3918 C          print *,i,j
3919           do ilist=1,ishield_list(i)
3920            iresshield=shield_list(ilist,i)
3921            do k=1,3
3922            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3923      &      *2.0
3924            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3925      &              rlocshield
3926      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3927             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3928 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3929 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3930 C             if (iresshield.gt.i) then
3931 C               do ishi=i+1,iresshield-1
3932 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3933 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3934 C
3935 C              enddo
3936 C             else
3937 C               do ishi=iresshield,i
3938 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3939 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3940 C
3941 C               enddo
3942 C              endif
3943            enddo
3944           enddo
3945           do ilist=1,ishield_list(j)
3946            iresshield=shield_list(ilist,j)
3947            do k=1,3
3948            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3949      &     *2.0*sss
3950            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3951      &              rlocshield
3952      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3953            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3954
3955 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3956 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3957 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3958 C             if (iresshield.gt.j) then
3959 C               do ishi=j+1,iresshield-1
3960 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3961 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3962 C
3963 C               enddo
3964 C            else
3965 C               do ishi=iresshield,j
3966 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3967 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3968 C               enddo
3969 C              endif
3970            enddo
3971           enddo
3972
3973           do k=1,3
3974             gshieldc(k,i)=gshieldc(k,i)+
3975      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3976             gshieldc(k,j)=gshieldc(k,j)+
3977      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3978             gshieldc(k,i-1)=gshieldc(k,i-1)+
3979      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3980             gshieldc(k,j-1)=gshieldc(k,j-1)+
3981      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3982
3983            enddo
3984            endif
3985 c          do k=1,3
3986 c            ghalf=0.5D0*ggg(k)
3987 c            gelc(k,i)=gelc(k,i)+ghalf
3988 c            gelc(k,j)=gelc(k,j)+ghalf
3989 c          enddo
3990 c 9/28/08 AL Gradient compotents will be summed only at the end
3991 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3992           do k=1,3
3993             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3994 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3995             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3996 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3997 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3998 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3999 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4000 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4001           enddo
4002 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4003
4004 *
4005 * Loop over residues i+1 thru j-1.
4006 *
4007 cgrad          do k=i+1,j-1
4008 cgrad            do l=1,3
4009 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4010 cgrad            enddo
4011 cgrad          enddo
4012           facvdw=facvdw+sssgrad*rmij*evdwij
4013           ggg(1)=facvdw*xj
4014           ggg(2)=facvdw*yj
4015           ggg(3)=facvdw*zj
4016 c          do k=1,3
4017 c            ghalf=0.5D0*ggg(k)
4018 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4019 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4020 c          enddo
4021 c 9/28/08 AL Gradient compotents will be summed only at the end
4022           do k=1,3
4023             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4024             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4025           enddo
4026 *
4027 * Loop over residues i+1 thru j-1.
4028 *
4029 cgrad          do k=i+1,j-1
4030 cgrad            do l=1,3
4031 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4032 cgrad            enddo
4033 cgrad          enddo
4034 #else
4035 C MARYSIA
4036           facvdw=(ev1+evdwij)
4037           facel=(el1+eesij)
4038           fac1=fac
4039           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4040      &       +(evdwij+eesij)*sssgrad*rrmij
4041           erij(1)=xj*rmij
4042           erij(2)=yj*rmij
4043           erij(3)=zj*rmij
4044 *
4045 * Radial derivatives. First process both termini of the fragment (i,j)
4046 *
4047           ggg(1)=fac*xj
4048 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4049           ggg(2)=fac*yj
4050 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4051           ggg(3)=fac*zj
4052 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4053 c          do k=1,3
4054 c            ghalf=0.5D0*ggg(k)
4055 c            gelc(k,i)=gelc(k,i)+ghalf
4056 c            gelc(k,j)=gelc(k,j)+ghalf
4057 c          enddo
4058 c 9/28/08 AL Gradient compotents will be summed only at the end
4059           do k=1,3
4060             gelc_long(k,j)=gelc(k,j)+ggg(k)
4061             gelc_long(k,i)=gelc(k,i)-ggg(k)
4062           enddo
4063 *
4064 * Loop over residues i+1 thru j-1.
4065 *
4066 cgrad          do k=i+1,j-1
4067 cgrad            do l=1,3
4068 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4069 cgrad            enddo
4070 cgrad          enddo
4071 c 9/28/08 AL Gradient compotents will be summed only at the end
4072           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4073           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4074           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4075           do k=1,3
4076             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4077             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4078           enddo
4079 #endif
4080 *
4081 * Angular part
4082 *
4083           ecosa=2.0D0*fac3*fac1+fac4
4084           fac4=-3.0D0*fac4
4085           fac3=-6.0D0*fac3
4086           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4087           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4088           do k=1,3
4089             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4090             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4091           enddo
4092 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4093 cd   &          (dcosg(k),k=1,3)
4094           do k=1,3
4095             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4096      &      fac_shield(i)**2*fac_shield(j)**2*sss
4097           enddo
4098 c          do k=1,3
4099 c            ghalf=0.5D0*ggg(k)
4100 c            gelc(k,i)=gelc(k,i)+ghalf
4101 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4102 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4103 c            gelc(k,j)=gelc(k,j)+ghalf
4104 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4105 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4106 c          enddo
4107 cgrad          do k=i+1,j-1
4108 cgrad            do l=1,3
4109 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4110 cgrad            enddo
4111 cgrad          enddo
4112 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4113           do k=1,3
4114             gelc(k,i)=gelc(k,i)
4115      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4116      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4117      &           *fac_shield(i)**2*fac_shield(j)**2
4118             gelc(k,j)=gelc(k,j)
4119      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4120      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4121      &           *fac_shield(i)**2*fac_shield(j)**2
4122             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4123             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4124           enddo
4125 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4126
4127 C MARYSIA
4128 c          endif !sscale
4129           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4130      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4131      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4132 C
4133 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4134 C   energy of a peptide unit is assumed in the form of a second-order
4135 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4136 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4137 C   are computed for EVERY pair of non-contiguous peptide groups.
4138 C
4139
4140           if (j.lt.nres-1) then
4141             j1=j+1
4142             j2=j-1
4143           else
4144             j1=j-1
4145             j2=j-2
4146           endif
4147           kkk=0
4148           lll=0
4149           do k=1,2
4150             do l=1,2
4151               kkk=kkk+1
4152               muij(kkk)=mu(k,i)*mu(l,j)
4153 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4154 #ifdef NEWCORR
4155              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4156 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4157              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4158              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4159 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4160              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4161 #endif
4162             enddo
4163           enddo
4164 #ifdef DEBUG
4165           write (iout,*) 'EELEC: i',i,' j',j
4166           write (iout,*) 'j',j,' j1',j1,' j2',j2
4167           write(iout,*) 'muij',muij
4168 #endif
4169           ury=scalar(uy(1,i),erij)
4170           urz=scalar(uz(1,i),erij)
4171           vry=scalar(uy(1,j),erij)
4172           vrz=scalar(uz(1,j),erij)
4173           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4174           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4175           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4176           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4177           fac=dsqrt(-ael6i)*r3ij
4178 #ifdef DEBUG
4179           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4180           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4181      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4182      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4183      &      "uzvz",scalar(uz(1,i),uz(1,j))
4184           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4185           write (iout,*) "fac",fac
4186 #endif
4187           a22=a22*fac
4188           a23=a23*fac
4189           a32=a32*fac
4190           a33=a33*fac
4191 #ifdef DEBUG
4192           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4193 #endif
4194 #undef DEBUG
4195 cd          write (iout,'(4i5,4f10.5)')
4196 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4197 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4198 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4199 cd     &      uy(:,j),uz(:,j)
4200 cd          write (iout,'(4f10.5)')
4201 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4202 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4203 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4204 cd           write (iout,'(9f10.5/)')
4205 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4206 C Derivatives of the elements of A in virtual-bond vectors
4207           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4208           do k=1,3
4209             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4210             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4211             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4212             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4213             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4214             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4215             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4216             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4217             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4218             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4219             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4220             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4221           enddo
4222 C Compute radial contributions to the gradient
4223           facr=-3.0d0*rrmij
4224           a22der=a22*facr
4225           a23der=a23*facr
4226           a32der=a32*facr
4227           a33der=a33*facr
4228           agg(1,1)=a22der*xj
4229           agg(2,1)=a22der*yj
4230           agg(3,1)=a22der*zj
4231           agg(1,2)=a23der*xj
4232           agg(2,2)=a23der*yj
4233           agg(3,2)=a23der*zj
4234           agg(1,3)=a32der*xj
4235           agg(2,3)=a32der*yj
4236           agg(3,3)=a32der*zj
4237           agg(1,4)=a33der*xj
4238           agg(2,4)=a33der*yj
4239           agg(3,4)=a33der*zj
4240 C Add the contributions coming from er
4241           fac3=-3.0d0*fac
4242           do k=1,3
4243             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4244             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4245             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4246             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4247           enddo
4248           do k=1,3
4249 C Derivatives in DC(i)
4250 cgrad            ghalf1=0.5d0*agg(k,1)
4251 cgrad            ghalf2=0.5d0*agg(k,2)
4252 cgrad            ghalf3=0.5d0*agg(k,3)
4253 cgrad            ghalf4=0.5d0*agg(k,4)
4254             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4255      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4256             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4257      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4258             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4259      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4260             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4261      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4262 C Derivatives in DC(i+1)
4263             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4264      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4265             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4266      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4267             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4268      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4269             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4270      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4271 C Derivatives in DC(j)
4272             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4273      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4274             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4275      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4276             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4277      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4278             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4279      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4280 C Derivatives in DC(j+1) or DC(nres-1)
4281             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4282      &      -3.0d0*vryg(k,3)*ury)
4283             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4284      &      -3.0d0*vrzg(k,3)*ury)
4285             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4286      &      -3.0d0*vryg(k,3)*urz)
4287             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4288      &      -3.0d0*vrzg(k,3)*urz)
4289 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4290 cgrad              do l=1,4
4291 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4292 cgrad              enddo
4293 cgrad            endif
4294           enddo
4295           acipa(1,1)=a22
4296           acipa(1,2)=a23
4297           acipa(2,1)=a32
4298           acipa(2,2)=a33
4299           a22=-a22
4300           a23=-a23
4301           do l=1,2
4302             do k=1,3
4303               agg(k,l)=-agg(k,l)
4304               aggi(k,l)=-aggi(k,l)
4305               aggi1(k,l)=-aggi1(k,l)
4306               aggj(k,l)=-aggj(k,l)
4307               aggj1(k,l)=-aggj1(k,l)
4308             enddo
4309           enddo
4310           if (j.lt.nres-1) then
4311             a22=-a22
4312             a32=-a32
4313             do l=1,3,2
4314               do k=1,3
4315                 agg(k,l)=-agg(k,l)
4316                 aggi(k,l)=-aggi(k,l)
4317                 aggi1(k,l)=-aggi1(k,l)
4318                 aggj(k,l)=-aggj(k,l)
4319                 aggj1(k,l)=-aggj1(k,l)
4320               enddo
4321             enddo
4322           else
4323             a22=-a22
4324             a23=-a23
4325             a32=-a32
4326             a33=-a33
4327             do l=1,4
4328               do k=1,3
4329                 agg(k,l)=-agg(k,l)
4330                 aggi(k,l)=-aggi(k,l)
4331                 aggi1(k,l)=-aggi1(k,l)
4332                 aggj(k,l)=-aggj(k,l)
4333                 aggj1(k,l)=-aggj1(k,l)
4334               enddo
4335             enddo
4336           endif
4337           ENDIF ! WCORR
4338           IF (wel_loc.gt.0.0d0) THEN
4339 C Contribution to the local-electrostatic energy coming from the i-j pair
4340           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4341      &     +a33*muij(4)
4342 #ifdef DEBUG
4343           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4344      &     " a33",a33
4345           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4346      &     " wel_loc",wel_loc
4347 #endif
4348           if (shield_mode.eq.0) then
4349            fac_shield(i)=1.0
4350            fac_shield(j)=1.0
4351 C          else
4352 C           fac_shield(i)=0.4
4353 C           fac_shield(j)=0.6
4354           endif
4355           eel_loc_ij=eel_loc_ij
4356      &    *fac_shield(i)*fac_shield(j)*sss
4357 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4358 c     &            'eelloc',i,j,eel_loc_ij
4359 C Now derivative over eel_loc
4360           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4361      &  (shield_mode.gt.0)) then
4362 C          print *,i,j
4363
4364           do ilist=1,ishield_list(i)
4365            iresshield=shield_list(ilist,i)
4366            do k=1,3
4367            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4368      &                                          /fac_shield(i)
4369 C     &      *2.0
4370            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4371      &              rlocshield
4372      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4373             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4374      &      +rlocshield
4375            enddo
4376           enddo
4377           do ilist=1,ishield_list(j)
4378            iresshield=shield_list(ilist,j)
4379            do k=1,3
4380            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4381      &                                       /fac_shield(j)
4382 C     &     *2.0
4383            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4384      &              rlocshield
4385      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4386            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4387      &             +rlocshield
4388
4389            enddo
4390           enddo
4391
4392           do k=1,3
4393             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4394      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4395             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4396      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4397             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4398      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4399             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4400      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4401            enddo
4402            endif
4403
4404
4405 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4406 c     &                     ' eel_loc_ij',eel_loc_ij
4407 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4408 C Calculate patrial derivative for theta angle
4409 #ifdef NEWCORR
4410          geel_loc_ij=(a22*gmuij1(1)
4411      &     +a23*gmuij1(2)
4412      &     +a32*gmuij1(3)
4413      &     +a33*gmuij1(4))
4414      &    *fac_shield(i)*fac_shield(j)*sss
4415 c         write(iout,*) "derivative over thatai"
4416 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4417 c     &   a33*gmuij1(4)
4418          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4419      &      geel_loc_ij*wel_loc
4420 c         write(iout,*) "derivative over thatai-1"
4421 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4422 c     &   a33*gmuij2(4)
4423          geel_loc_ij=
4424      &     a22*gmuij2(1)
4425      &     +a23*gmuij2(2)
4426      &     +a32*gmuij2(3)
4427      &     +a33*gmuij2(4)
4428          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4429      &      geel_loc_ij*wel_loc
4430      &    *fac_shield(i)*fac_shield(j)*sss
4431
4432 c  Derivative over j residue
4433          geel_loc_ji=a22*gmuji1(1)
4434      &     +a23*gmuji1(2)
4435      &     +a32*gmuji1(3)
4436      &     +a33*gmuji1(4)
4437 c         write(iout,*) "derivative over thataj"
4438 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4439 c     &   a33*gmuji1(4)
4440
4441         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4442      &      geel_loc_ji*wel_loc
4443      &    *fac_shield(i)*fac_shield(j)*sss
4444
4445          geel_loc_ji=
4446      &     +a22*gmuji2(1)
4447      &     +a23*gmuji2(2)
4448      &     +a32*gmuji2(3)
4449      &     +a33*gmuji2(4)
4450 c         write(iout,*) "derivative over thataj-1"
4451 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4452 c     &   a33*gmuji2(4)
4453          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4454      &      geel_loc_ji*wel_loc
4455      &    *fac_shield(i)*fac_shield(j)*sss
4456 #endif
4457 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4458
4459           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4460      &            'eelloc',i,j,eel_loc_ij
4461 c           if (eel_loc_ij.ne.0)
4462 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4463 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4464
4465           eel_loc=eel_loc+eel_loc_ij
4466 C Partial derivatives in virtual-bond dihedral angles gamma
4467           if (i.gt.1)
4468      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4469      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4470      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4471      &    *fac_shield(i)*fac_shield(j)*sss
4472
4473           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4474      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4475      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4476      &    *fac_shield(i)*fac_shield(j)*sss
4477 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4478           aux=eel_loc_ij/sss*sssgrad*rmij
4479           ggg(1)=aux*xj
4480           ggg(2)=aux*yj
4481           ggg(3)=aux*zj
4482           do l=1,3
4483             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4484      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4485      &    *fac_shield(i)*fac_shield(j)*sss
4486             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4487             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4488 cgrad            ghalf=0.5d0*ggg(l)
4489 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4490 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4491           enddo
4492 cgrad          do k=i+1,j2
4493 cgrad            do l=1,3
4494 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4495 cgrad            enddo
4496 cgrad          enddo
4497 C Remaining derivatives of eello
4498           do l=1,3
4499             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4500      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4501      &    *fac_shield(i)*fac_shield(j)*sss
4502
4503             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4504      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4505      &    *fac_shield(i)*fac_shield(j)*sss
4506
4507             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4508      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4509      &    *fac_shield(i)*fac_shield(j)*sss
4510
4511             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4512      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4513      &    *fac_shield(i)*fac_shield(j)*sss
4514
4515           enddo
4516           ENDIF
4517 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4518 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4519 #ifdef FOURBODY
4520           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4521      &       .and. num_conti.le.maxconts) then
4522 c            write (iout,*) i,j," entered corr"
4523 C
4524 C Calculate the contact function. The ith column of the array JCONT will
4525 C contain the numbers of atoms that make contacts with the atom I (of numbers
4526 C greater than I). The arrays FACONT and GACONT will contain the values of
4527 C the contact function and its derivative.
4528 c           r0ij=1.02D0*rpp(iteli,itelj)
4529 c           r0ij=1.11D0*rpp(iteli,itelj)
4530             r0ij=2.20D0*rpp(iteli,itelj)
4531 c           r0ij=1.55D0*rpp(iteli,itelj)
4532             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4533             if (fcont.gt.0.0D0) then
4534               num_conti=num_conti+1
4535               if (num_conti.gt.maxconts) then
4536                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4537      &                         ' will skip next contacts for this conf.'
4538               else
4539                 jcont_hb(num_conti,i)=j
4540 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4541 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4542                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4543      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4544 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4545 C  terms.
4546                 d_cont(num_conti,i)=rij
4547 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4548 C     --- Electrostatic-interaction matrix ---
4549                 a_chuj(1,1,num_conti,i)=a22
4550                 a_chuj(1,2,num_conti,i)=a23
4551                 a_chuj(2,1,num_conti,i)=a32
4552                 a_chuj(2,2,num_conti,i)=a33
4553 C     --- Gradient of rij
4554                 do kkk=1,3
4555                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4556                 enddo
4557                 kkll=0
4558                 do k=1,2
4559                   do l=1,2
4560                     kkll=kkll+1
4561                     do m=1,3
4562                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4563                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4564                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4565                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4566                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4567                     enddo
4568                   enddo
4569                 enddo
4570                 ENDIF
4571                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4572 C Calculate contact energies
4573                 cosa4=4.0D0*cosa
4574                 wij=cosa-3.0D0*cosb*cosg
4575                 cosbg1=cosb+cosg
4576                 cosbg2=cosb-cosg
4577 c               fac3=dsqrt(-ael6i)/r0ij**3
4578                 fac3=dsqrt(-ael6i)*r3ij
4579 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4580                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4581                 if (ees0tmp.gt.0) then
4582                   ees0pij=dsqrt(ees0tmp)
4583                 else
4584                   ees0pij=0
4585                 endif
4586 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4587                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4588                 if (ees0tmp.gt.0) then
4589                   ees0mij=dsqrt(ees0tmp)
4590                 else
4591                   ees0mij=0
4592                 endif
4593 c               ees0mij=0.0D0
4594                 if (shield_mode.eq.0) then
4595                 fac_shield(i)=1.0d0
4596                 fac_shield(j)=1.0d0
4597                 else
4598                 ees0plist(num_conti,i)=j
4599 C                fac_shield(i)=0.4d0
4600 C                fac_shield(j)=0.6d0
4601                 endif
4602                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4603      &          *fac_shield(i)*fac_shield(j)*sss
4604                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4605      &          *fac_shield(i)*fac_shield(j)*sss
4606 C Diagnostics. Comment out or remove after debugging!
4607 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4608 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4609 c               ees0m(num_conti,i)=0.0D0
4610 C End diagnostics.
4611 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4612 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4613 C Angular derivatives of the contact function
4614                 ees0pij1=fac3/ees0pij
4615                 ees0mij1=fac3/ees0mij
4616                 fac3p=-3.0D0*fac3*rrmij
4617                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4618                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4619 c               ees0mij1=0.0D0
4620                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4621                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4622                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4623                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4624                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4625                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4626                 ecosap=ecosa1+ecosa2
4627                 ecosbp=ecosb1+ecosb2
4628                 ecosgp=ecosg1+ecosg2
4629                 ecosam=ecosa1-ecosa2
4630                 ecosbm=ecosb1-ecosb2
4631                 ecosgm=ecosg1-ecosg2
4632 C Diagnostics
4633 c               ecosap=ecosa1
4634 c               ecosbp=ecosb1
4635 c               ecosgp=ecosg1
4636 c               ecosam=0.0D0
4637 c               ecosbm=0.0D0
4638 c               ecosgm=0.0D0
4639 C End diagnostics
4640                 facont_hb(num_conti,i)=fcont
4641                 fprimcont=fprimcont/rij
4642 cd              facont_hb(num_conti,i)=1.0D0
4643 C Following line is for diagnostics.
4644 cd              fprimcont=0.0D0
4645                 do k=1,3
4646                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4647                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4648                 enddo
4649                 do k=1,3
4650                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4651                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4652                 enddo
4653                 gggp(1)=gggp(1)+ees0pijp*xj
4654      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4655                 gggp(2)=gggp(2)+ees0pijp*yj
4656      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4657                 gggp(3)=gggp(3)+ees0pijp*zj
4658      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4659                 gggm(1)=gggm(1)+ees0mijp*xj
4660      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4661                 gggm(2)=gggm(2)+ees0mijp*yj
4662      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4663                 gggm(3)=gggm(3)+ees0mijp*zj
4664      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4665 C Derivatives due to the contact function
4666                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4667                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4668                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4669                 do k=1,3
4670 c
4671 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4672 c          following the change of gradient-summation algorithm.
4673 c
4674 cgrad                  ghalfp=0.5D0*gggp(k)
4675 cgrad                  ghalfm=0.5D0*gggm(k)
4676                   gacontp_hb1(k,num_conti,i)=!ghalfp
4677      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4678      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4679      &          *fac_shield(i)*fac_shield(j)*sss
4680
4681                   gacontp_hb2(k,num_conti,i)=!ghalfp
4682      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4683      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4684      &          *fac_shield(i)*fac_shield(j)*sss
4685
4686                   gacontp_hb3(k,num_conti,i)=gggp(k)
4687      &          *fac_shield(i)*fac_shield(j)*sss
4688
4689                   gacontm_hb1(k,num_conti,i)=!ghalfm
4690      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4691      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4692      &          *fac_shield(i)*fac_shield(j)*sss
4693
4694                   gacontm_hb2(k,num_conti,i)=!ghalfm
4695      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4696      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4697      &          *fac_shield(i)*fac_shield(j)*sss
4698
4699                   gacontm_hb3(k,num_conti,i)=gggm(k)
4700      &          *fac_shield(i)*fac_shield(j)*sss
4701
4702                 enddo
4703 C Diagnostics. Comment out or remove after debugging!
4704 cdiag           do k=1,3
4705 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4706 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4707 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4708 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4709 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4710 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4711 cdiag           enddo
4712               ENDIF ! wcorr
4713               endif  ! num_conti.le.maxconts
4714             endif  ! fcont.gt.0
4715           endif    ! j.gt.i+1
4716 #endif
4717           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4718             do k=1,4
4719               do l=1,3
4720                 ghalf=0.5d0*agg(l,k)
4721                 aggi(l,k)=aggi(l,k)+ghalf
4722                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4723                 aggj(l,k)=aggj(l,k)+ghalf
4724               enddo
4725             enddo
4726             if (j.eq.nres-1 .and. i.lt.j-2) then
4727               do k=1,4
4728                 do l=1,3
4729                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4730                 enddo
4731               enddo
4732             endif
4733           endif
4734 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4735       return
4736       end
4737 C-----------------------------------------------------------------------------
4738       subroutine eturn3(i,eello_turn3)
4739 C Third- and fourth-order contributions from turns
4740       implicit real*8 (a-h,o-z)
4741       include 'DIMENSIONS'
4742       include 'COMMON.IOUNITS'
4743       include 'COMMON.GEO'
4744       include 'COMMON.VAR'
4745       include 'COMMON.LOCAL'
4746       include 'COMMON.CHAIN'
4747       include 'COMMON.DERIV'
4748       include 'COMMON.INTERACT'
4749       include 'COMMON.CORRMAT'
4750       include 'COMMON.TORSION'
4751       include 'COMMON.VECTORS'
4752       include 'COMMON.FFIELD'
4753       include 'COMMON.CONTROL'
4754       include 'COMMON.SHIELD'
4755       dimension ggg(3)
4756       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4757      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4758      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4759      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4760      &  auxgmat2(2,2),auxgmatt2(2,2)
4761       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4762      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4763       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4764      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4765      &    num_conti,j1,j2
4766       j=i+2
4767 c      write (iout,*) "eturn3",i,j,j1,j2
4768       a_temp(1,1)=a22
4769       a_temp(1,2)=a23
4770       a_temp(2,1)=a32
4771       a_temp(2,2)=a33
4772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4773 C
4774 C               Third-order contributions
4775 C
4776 C                 (i+2)o----(i+3)
4777 C                      | |
4778 C                      | |
4779 C                 (i+1)o----i
4780 C
4781 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4782 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4783         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4784 c auxalary matices for theta gradient
4785 c auxalary matrix for i+1 and constant i+2
4786         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4787 c auxalary matrix for i+2 and constant i+1
4788         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4789         call transpose2(auxmat(1,1),auxmat1(1,1))
4790         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4791         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4792         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4793         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4794         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4795         if (shield_mode.eq.0) then
4796         fac_shield(i)=1.0
4797         fac_shield(j)=1.0
4798 C        else
4799 C        fac_shield(i)=0.4
4800 C        fac_shield(j)=0.6
4801         endif
4802         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4803      &  *fac_shield(i)*fac_shield(j)
4804         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4805      &  *fac_shield(i)*fac_shield(j)
4806         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4807      &    eello_t3
4808 C#ifdef NEWCORR
4809 C Derivatives in theta
4810         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4811      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4812      &   *fac_shield(i)*fac_shield(j)
4813         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4814      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4815      &   *fac_shield(i)*fac_shield(j)
4816 C#endif
4817
4818 C Derivatives in shield mode
4819           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4820      &  (shield_mode.gt.0)) then
4821 C          print *,i,j
4822
4823           do ilist=1,ishield_list(i)
4824            iresshield=shield_list(ilist,i)
4825            do k=1,3
4826            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4827 C     &      *2.0
4828            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4829      &              rlocshield
4830      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4831             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4832      &      +rlocshield
4833            enddo
4834           enddo
4835           do ilist=1,ishield_list(j)
4836            iresshield=shield_list(ilist,j)
4837            do k=1,3
4838            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4839 C     &     *2.0
4840            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4841      &              rlocshield
4842      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4843            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4844      &             +rlocshield
4845
4846            enddo
4847           enddo
4848
4849           do k=1,3
4850             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4851      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4852             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4853      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4854             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4855      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4856             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4857      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4858            enddo
4859            endif
4860
4861 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4862 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4863 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4864 cd     &    ' eello_turn3_num',4*eello_turn3_num
4865 C Derivatives in gamma(i)
4866         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4867         call transpose2(auxmat2(1,1),auxmat3(1,1))
4868         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4869         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4870      &   *fac_shield(i)*fac_shield(j)
4871 C Derivatives in gamma(i+1)
4872         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4873         call transpose2(auxmat2(1,1),auxmat3(1,1))
4874         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4875         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4876      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4877      &   *fac_shield(i)*fac_shield(j)
4878 C Cartesian derivatives
4879         do l=1,3
4880 c            ghalf1=0.5d0*agg(l,1)
4881 c            ghalf2=0.5d0*agg(l,2)
4882 c            ghalf3=0.5d0*agg(l,3)
4883 c            ghalf4=0.5d0*agg(l,4)
4884           a_temp(1,1)=aggi(l,1)!+ghalf1
4885           a_temp(1,2)=aggi(l,2)!+ghalf2
4886           a_temp(2,1)=aggi(l,3)!+ghalf3
4887           a_temp(2,2)=aggi(l,4)!+ghalf4
4888           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4889           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4890      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4891      &   *fac_shield(i)*fac_shield(j)
4892
4893           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4894           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4895           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4896           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4897           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4898           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4899      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4900      &   *fac_shield(i)*fac_shield(j)
4901           a_temp(1,1)=aggj(l,1)!+ghalf1
4902           a_temp(1,2)=aggj(l,2)!+ghalf2
4903           a_temp(2,1)=aggj(l,3)!+ghalf3
4904           a_temp(2,2)=aggj(l,4)!+ghalf4
4905           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4906           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4907      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4908      &   *fac_shield(i)*fac_shield(j)
4909           a_temp(1,1)=aggj1(l,1)
4910           a_temp(1,2)=aggj1(l,2)
4911           a_temp(2,1)=aggj1(l,3)
4912           a_temp(2,2)=aggj1(l,4)
4913           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4914           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4915      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4916      &   *fac_shield(i)*fac_shield(j)
4917         enddo
4918       return
4919       end
4920 C-------------------------------------------------------------------------------
4921       subroutine eturn4(i,eello_turn4)
4922 C Third- and fourth-order contributions from turns
4923       implicit real*8 (a-h,o-z)
4924       include 'DIMENSIONS'
4925       include 'COMMON.IOUNITS'
4926       include 'COMMON.GEO'
4927       include 'COMMON.VAR'
4928       include 'COMMON.LOCAL'
4929       include 'COMMON.CHAIN'
4930       include 'COMMON.DERIV'
4931       include 'COMMON.INTERACT'
4932       include 'COMMON.CORRMAT'
4933       include 'COMMON.TORSION'
4934       include 'COMMON.VECTORS'
4935       include 'COMMON.FFIELD'
4936       include 'COMMON.CONTROL'
4937       include 'COMMON.SHIELD'
4938       dimension ggg(3)
4939       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4940      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4941      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4942      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4943      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4944      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4945      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4946       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4947      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4948       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4949      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4950      &    num_conti,j1,j2
4951       j=i+3
4952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4953 C
4954 C               Fourth-order contributions
4955 C
4956 C                 (i+3)o----(i+4)
4957 C                     /  |
4958 C               (i+2)o   |
4959 C                     \  |
4960 C                 (i+1)o----i
4961 C
4962 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4963 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4964 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4965 c        write(iout,*)"WCHODZE W PROGRAM"
4966         a_temp(1,1)=a22
4967         a_temp(1,2)=a23
4968         a_temp(2,1)=a32
4969         a_temp(2,2)=a33
4970         iti1=itype2loc(itype(i+1))
4971         iti2=itype2loc(itype(i+2))
4972         iti3=itype2loc(itype(i+3))
4973 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4974         call transpose2(EUg(1,1,i+1),e1t(1,1))
4975         call transpose2(Eug(1,1,i+2),e2t(1,1))
4976         call transpose2(Eug(1,1,i+3),e3t(1,1))
4977 C Ematrix derivative in theta
4978         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4979         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4980         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4981         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4982 c       eta1 in derivative theta
4983         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4984         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4985 c       auxgvec is derivative of Ub2 so i+3 theta
4986         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4987 c       auxalary matrix of E i+1
4988         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4989 c        s1=0.0
4990 c        gs1=0.0
4991         s1=scalar2(b1(1,i+2),auxvec(1))
4992 c derivative of theta i+2 with constant i+3
4993         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4994 c derivative of theta i+2 with constant i+2
4995         gs32=scalar2(b1(1,i+2),auxgvec(1))
4996 c derivative of E matix in theta of i+1
4997         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4998
4999         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5000 c       ea31 in derivative theta
5001         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5002         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5003 c auxilary matrix auxgvec of Ub2 with constant E matirx
5004         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5005 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5006         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5007
5008 c        s2=0.0
5009 c        gs2=0.0
5010         s2=scalar2(b1(1,i+1),auxvec(1))
5011 c derivative of theta i+1 with constant i+3
5012         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5013 c derivative of theta i+2 with constant i+1
5014         gs21=scalar2(b1(1,i+1),auxgvec(1))
5015 c derivative of theta i+3 with constant i+1
5016         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5017 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5018 c     &  gtb1(1,i+1)
5019         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5020 c two derivatives over diffetent matrices
5021 c gtae3e2 is derivative over i+3
5022         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5023 c ae3gte2 is derivative over i+2
5024         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5025         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5026 c three possible derivative over theta E matices
5027 c i+1
5028         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5029 c i+2
5030         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5031 c i+3
5032         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5033         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5034
5035         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5036         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5037         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5038         if (shield_mode.eq.0) then
5039         fac_shield(i)=1.0
5040         fac_shield(j)=1.0
5041 C        else
5042 C        fac_shield(i)=0.6
5043 C        fac_shield(j)=0.4
5044         endif
5045         eello_turn4=eello_turn4-(s1+s2+s3)
5046      &  *fac_shield(i)*fac_shield(j)
5047         eello_t4=-(s1+s2+s3)
5048      &  *fac_shield(i)*fac_shield(j)
5049 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5050         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5051      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5052 C Now derivative over shield:
5053           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5054      &  (shield_mode.gt.0)) then
5055 C          print *,i,j
5056
5057           do ilist=1,ishield_list(i)
5058            iresshield=shield_list(ilist,i)
5059            do k=1,3
5060            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5061 C     &      *2.0
5062            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5063      &              rlocshield
5064      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5065             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5066      &      +rlocshield
5067            enddo
5068           enddo
5069           do ilist=1,ishield_list(j)
5070            iresshield=shield_list(ilist,j)
5071            do k=1,3
5072            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5073 C     &     *2.0
5074            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5075      &              rlocshield
5076      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5077            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5078      &             +rlocshield
5079
5080            enddo
5081           enddo
5082
5083           do k=1,3
5084             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5085      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5086             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5087      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5088             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5089      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5090             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5091      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5092            enddo
5093            endif
5094
5095
5096
5097
5098
5099
5100 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5101 cd     &    ' eello_turn4_num',8*eello_turn4_num
5102 #ifdef NEWCORR
5103         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5104      &                  -(gs13+gsE13+gsEE1)*wturn4
5105      &  *fac_shield(i)*fac_shield(j)
5106         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5107      &                    -(gs23+gs21+gsEE2)*wturn4
5108      &  *fac_shield(i)*fac_shield(j)
5109
5110         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5111      &                    -(gs32+gsE31+gsEE3)*wturn4
5112      &  *fac_shield(i)*fac_shield(j)
5113
5114 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5115 c     &   gs2
5116 #endif
5117         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5118      &      'eturn4',i,j,-(s1+s2+s3)
5119 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5120 c     &    ' eello_turn4_num',8*eello_turn4_num
5121 C Derivatives in gamma(i)
5122         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5123         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5124         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5125         s1=scalar2(b1(1,i+2),auxvec(1))
5126         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5127         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5128         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5129      &  *fac_shield(i)*fac_shield(j)
5130 C Derivatives in gamma(i+1)
5131         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5132         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5133         s2=scalar2(b1(1,i+1),auxvec(1))
5134         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5135         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5136         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5137         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5138      &  *fac_shield(i)*fac_shield(j)
5139 C Derivatives in gamma(i+2)
5140         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5141         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5142         s1=scalar2(b1(1,i+2),auxvec(1))
5143         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5144         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5145         s2=scalar2(b1(1,i+1),auxvec(1))
5146         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5147         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5148         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5149         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5150      &  *fac_shield(i)*fac_shield(j)
5151 C Cartesian derivatives
5152 C Derivatives of this turn contributions in DC(i+2)
5153         if (j.lt.nres-1) then
5154           do l=1,3
5155             a_temp(1,1)=agg(l,1)
5156             a_temp(1,2)=agg(l,2)
5157             a_temp(2,1)=agg(l,3)
5158             a_temp(2,2)=agg(l,4)
5159             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5160             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5161             s1=scalar2(b1(1,i+2),auxvec(1))
5162             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5163             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5164             s2=scalar2(b1(1,i+1),auxvec(1))
5165             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5166             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5167             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5168             ggg(l)=-(s1+s2+s3)
5169             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5170      &  *fac_shield(i)*fac_shield(j)
5171           enddo
5172         endif
5173 C Remaining derivatives of this turn contribution
5174         do l=1,3
5175           a_temp(1,1)=aggi(l,1)
5176           a_temp(1,2)=aggi(l,2)
5177           a_temp(2,1)=aggi(l,3)
5178           a_temp(2,2)=aggi(l,4)
5179           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5180           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5181           s1=scalar2(b1(1,i+2),auxvec(1))
5182           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5183           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5184           s2=scalar2(b1(1,i+1),auxvec(1))
5185           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5186           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5187           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5188           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5189      &  *fac_shield(i)*fac_shield(j)
5190           a_temp(1,1)=aggi1(l,1)
5191           a_temp(1,2)=aggi1(l,2)
5192           a_temp(2,1)=aggi1(l,3)
5193           a_temp(2,2)=aggi1(l,4)
5194           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5195           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5196           s1=scalar2(b1(1,i+2),auxvec(1))
5197           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5198           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5199           s2=scalar2(b1(1,i+1),auxvec(1))
5200           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5201           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5202           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5203           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5204      &  *fac_shield(i)*fac_shield(j)
5205           a_temp(1,1)=aggj(l,1)
5206           a_temp(1,2)=aggj(l,2)
5207           a_temp(2,1)=aggj(l,3)
5208           a_temp(2,2)=aggj(l,4)
5209           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5210           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5211           s1=scalar2(b1(1,i+2),auxvec(1))
5212           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5213           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5214           s2=scalar2(b1(1,i+1),auxvec(1))
5215           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5216           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5217           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5218           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5219      &  *fac_shield(i)*fac_shield(j)
5220           a_temp(1,1)=aggj1(l,1)
5221           a_temp(1,2)=aggj1(l,2)
5222           a_temp(2,1)=aggj1(l,3)
5223           a_temp(2,2)=aggj1(l,4)
5224           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5225           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5226           s1=scalar2(b1(1,i+2),auxvec(1))
5227           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5228           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5229           s2=scalar2(b1(1,i+1),auxvec(1))
5230           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5231           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5232           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5233 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5234           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5235      &  *fac_shield(i)*fac_shield(j)
5236         enddo
5237       return
5238       end
5239 C-----------------------------------------------------------------------------
5240       subroutine vecpr(u,v,w)
5241       implicit real*8(a-h,o-z)
5242       dimension u(3),v(3),w(3)
5243       w(1)=u(2)*v(3)-u(3)*v(2)
5244       w(2)=-u(1)*v(3)+u(3)*v(1)
5245       w(3)=u(1)*v(2)-u(2)*v(1)
5246       return
5247       end
5248 C-----------------------------------------------------------------------------
5249       subroutine unormderiv(u,ugrad,unorm,ungrad)
5250 C This subroutine computes the derivatives of a normalized vector u, given
5251 C the derivatives computed without normalization conditions, ugrad. Returns
5252 C ungrad.
5253       implicit none
5254       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5255       double precision vec(3)
5256       double precision scalar
5257       integer i,j
5258 c      write (2,*) 'ugrad',ugrad
5259 c      write (2,*) 'u',u
5260       do i=1,3
5261         vec(i)=scalar(ugrad(1,i),u(1))
5262       enddo
5263 c      write (2,*) 'vec',vec
5264       do i=1,3
5265         do j=1,3
5266           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5267         enddo
5268       enddo
5269 c      write (2,*) 'ungrad',ungrad
5270       return
5271       end
5272 C-----------------------------------------------------------------------------
5273       subroutine escp_soft_sphere(evdw2,evdw2_14)
5274 C
5275 C This subroutine calculates the excluded-volume interaction energy between
5276 C peptide-group centers and side chains and its gradient in virtual-bond and
5277 C side-chain vectors.
5278 C
5279       implicit real*8 (a-h,o-z)
5280       include 'DIMENSIONS'
5281       include 'COMMON.GEO'
5282       include 'COMMON.VAR'
5283       include 'COMMON.LOCAL'
5284       include 'COMMON.CHAIN'
5285       include 'COMMON.DERIV'
5286       include 'COMMON.INTERACT'
5287       include 'COMMON.FFIELD'
5288       include 'COMMON.IOUNITS'
5289       include 'COMMON.CONTROL'
5290       dimension ggg(3)
5291       double precision boxshift
5292       evdw2=0.0D0
5293       evdw2_14=0.0d0
5294       r0_scp=4.5d0
5295 cd    print '(a)','Enter ESCP'
5296 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5297 C      do xshift=-1,1
5298 C      do yshift=-1,1
5299 C      do zshift=-1,1
5300 c      do i=iatscp_s,iatscp_e
5301       do ikont=g_listscp_start,g_listscp_end
5302         i=newcontlistscpi(ikont)
5303         j=newcontlistscpj(ikont)
5304         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5305         iteli=itel(i)
5306         xi=0.5D0*(c(1,i)+c(1,i+1))
5307         yi=0.5D0*(c(2,i)+c(2,i+1))
5308         zi=0.5D0*(c(3,i)+c(3,i+1))
5309 C Return atom into box, boxxsize is size of box in x dimension
5310 c  134   continue
5311 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5312 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5313 C Condition for being inside the proper box
5314 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5315 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5316 c        go to 134
5317 c        endif
5318 c  135   continue
5319 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5320 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5321 C Condition for being inside the proper box
5322 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5323 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5324 c        go to 135
5325 c c       endif
5326 c  136   continue
5327 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5328 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5329 cC Condition for being inside the proper box
5330 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5331 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5332 c        go to 136
5333 c        endif
5334           call to_box(xi,yi,zi)
5335 C          xi=xi+xshift*boxxsize
5336 C          yi=yi+yshift*boxysize
5337 C          zi=zi+zshift*boxzsize
5338 c        do iint=1,nscp_gr(i)
5339
5340 c        do j=iscpstart(i,iint),iscpend(i,iint)
5341           if (itype(j).eq.ntyp1) cycle
5342           itypj=iabs(itype(j))
5343 C Uncomment following three lines for SC-p interactions
5344 c         xj=c(1,nres+j)-xi
5345 c         yj=c(2,nres+j)-yi
5346 c         zj=c(3,nres+j)-zi
5347 C Uncomment following three lines for Ca-p interactions
5348           xj=c(1,j)
5349           yj=c(2,j)
5350           zj=c(3,j)
5351           call to_box(xj,yj,zj)
5352           xj=boxshift(xj-xi,boxxsize)
5353           yj=boxshift(yj-yi,boxysize)
5354           zj=boxshift(zj-zi,boxzsize)
5355 C          xj=xj-xi
5356 C          yj=yj-yi
5357 C          zj=zj-zi
5358           rij=xj*xj+yj*yj+zj*zj
5359
5360           r0ij=r0_scp
5361           r0ijsq=r0ij*r0ij
5362           if (rij.lt.r0ijsq) then
5363             evdwij=0.25d0*(rij-r0ijsq)**2
5364             fac=rij-r0ijsq
5365           else
5366             evdwij=0.0d0
5367             fac=0.0d0
5368           endif
5369           evdw2=evdw2+evdwij
5370 C
5371 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5372 C
5373           ggg(1)=xj*fac
5374           ggg(2)=yj*fac
5375           ggg(3)=zj*fac
5376           do k=1,3
5377             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5378             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5379           enddo
5380 c        enddo
5381
5382 c        enddo ! iint
5383       enddo ! i
5384 C      enddo !zshift
5385 C      enddo !yshift
5386 C      enddo !xshift
5387       return
5388       end
5389 C-----------------------------------------------------------------------------
5390       subroutine escp(evdw2,evdw2_14)
5391 C
5392 C This subroutine calculates the excluded-volume interaction energy between
5393 C peptide-group centers and side chains and its gradient in virtual-bond and
5394 C side-chain vectors.
5395 C
5396       implicit none
5397       include 'DIMENSIONS'
5398       include 'COMMON.GEO'
5399       include 'COMMON.VAR'
5400       include 'COMMON.LOCAL'
5401       include 'COMMON.CHAIN'
5402       include 'COMMON.DERIV'
5403       include 'COMMON.INTERACT'
5404       include 'COMMON.FFIELD'
5405       include 'COMMON.IOUNITS'
5406       include 'COMMON.CONTROL'
5407       include 'COMMON.SPLITELE'
5408       double precision ggg(3)
5409       integer i,iint,j,k,iteli,itypj,subchap,ikont
5410       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5411      & fac,e1,e2,rij
5412       double precision evdw2,evdw2_14,evdwij
5413       double precision sscale,sscagrad
5414       double precision boxshift
5415       evdw2=0.0D0
5416       evdw2_14=0.0d0
5417 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5418 cd    print '(a)','Enter ESCP'
5419 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5420 C      do xshift=-1,1
5421 C      do yshift=-1,1
5422 C      do zshift=-1,1
5423       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5424 c      do i=iatscp_s,iatscp_e
5425       do ikont=g_listscp_start,g_listscp_end
5426         i=newcontlistscpi(ikont)
5427         j=newcontlistscpj(ikont)
5428         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5429         iteli=itel(i)
5430         xi=0.5D0*(c(1,i)+c(1,i+1))
5431         yi=0.5D0*(c(2,i)+c(2,i+1))
5432         zi=0.5D0*(c(3,i)+c(3,i+1))
5433         call to_box(xi,yi,zi)
5434 c        do iint=1,nscp_gr(i)
5435
5436 c        do j=iscpstart(i,iint),iscpend(i,iint)
5437           itypj=iabs(itype(j))
5438           if (itypj.eq.ntyp1) cycle
5439 C Uncomment following three lines for SC-p interactions
5440 c         xj=c(1,nres+j)-xi
5441 c         yj=c(2,nres+j)-yi
5442 c         zj=c(3,nres+j)-zi
5443 C Uncomment following three lines for Ca-p interactions
5444           xj=c(1,j)
5445           yj=c(2,j)
5446           zj=c(3,j)
5447           call to_box(xj,yj,zj)
5448           xj=boxshift(xj-xi,boxxsize)
5449           yj=boxshift(yj-yi,boxysize)
5450           zj=boxshift(zj-zi,boxzsize)
5451 c          print *,xj,yj,zj,'polozenie j'
5452           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5453 c          print *,rrij
5454           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5455 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5456 c          if (sss.eq.0) print *,'czasem jest OK'
5457           if (sss.le.0.0d0) cycle
5458           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5459           fac=rrij**expon2
5460           e1=fac*fac*aad(itypj,iteli)
5461           e2=fac*bad(itypj,iteli)
5462           if (iabs(j-i) .le. 2) then
5463             e1=scal14*e1
5464             e2=scal14*e2
5465             evdw2_14=evdw2_14+(e1+e2)*sss
5466           endif
5467           evdwij=e1+e2
5468           evdw2=evdw2+evdwij*sss
5469           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5470      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5471      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5472      &       bad(itypj,iteli)
5473 C
5474 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5475 C
5476           fac=-(evdwij+e1)*rrij*sss
5477           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5478           ggg(1)=xj*fac
5479           ggg(2)=yj*fac
5480           ggg(3)=zj*fac
5481 cgrad          if (j.lt.i) then
5482 cd          write (iout,*) 'j<i'
5483 C Uncomment following three lines for SC-p interactions
5484 c           do k=1,3
5485 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5486 c           enddo
5487 cgrad          else
5488 cd          write (iout,*) 'j>i'
5489 cgrad            do k=1,3
5490 cgrad              ggg(k)=-ggg(k)
5491 C Uncomment following line for SC-p interactions
5492 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5493 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5494 cgrad            enddo
5495 cgrad          endif
5496 cgrad          do k=1,3
5497 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5498 cgrad          enddo
5499 cgrad          kstart=min0(i+1,j)
5500 cgrad          kend=max0(i-1,j-1)
5501 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5502 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5503 cgrad          do k=kstart,kend
5504 cgrad            do l=1,3
5505 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5506 cgrad            enddo
5507 cgrad          enddo
5508           do k=1,3
5509             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5510             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5511           enddo
5512 c        endif !endif for sscale cutoff
5513 c        enddo ! j
5514
5515 c        enddo ! iint
5516       enddo ! i
5517 c      enddo !zshift
5518 c      enddo !yshift
5519 c      enddo !xshift
5520       do i=1,nct
5521         do j=1,3
5522           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5523           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5524           gradx_scp(j,i)=expon*gradx_scp(j,i)
5525         enddo
5526       enddo
5527 C******************************************************************************
5528 C
5529 C                              N O T E !!!
5530 C
5531 C To save time the factor EXPON has been extracted from ALL components
5532 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5533 C use!
5534 C
5535 C******************************************************************************
5536       return
5537       end
5538 C--------------------------------------------------------------------------
5539       subroutine edis(ehpb)
5540 C
5541 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5542 C
5543       implicit real*8 (a-h,o-z)
5544       include 'DIMENSIONS'
5545       include 'COMMON.SBRIDGE'
5546       include 'COMMON.CHAIN'
5547       include 'COMMON.DERIV'
5548       include 'COMMON.VAR'
5549       include 'COMMON.INTERACT'
5550       include 'COMMON.IOUNITS'
5551       include 'COMMON.CONTROL'
5552       dimension ggg(3),ggg_peak(3,1000)
5553       ehpb=0.0D0
5554       do i=1,3
5555        ggg(i)=0.0d0
5556       enddo
5557 c 8/21/18 AL: added explicit restraints on reference coords
5558 c      write (iout,*) "restr_on_coord",restr_on_coord
5559       if (restr_on_coord) then
5560
5561       do i=nnt,nct
5562         ecoor=0.0d0
5563         if (itype(i).eq.ntyp1) cycle
5564         do j=1,3
5565           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5566           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5567         enddo
5568         if (itype(i).ne.10) then
5569           do j=1,3
5570             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5571             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5572           enddo
5573         endif
5574         if (energy_dec) write (iout,*)
5575      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5576         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5577       enddo
5578
5579       endif
5580 C      write (iout,*) ,"link_end",link_end,constr_dist
5581 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5582 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5583 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5584 c     &  " link_end_peak",link_end_peak
5585       if (link_end.eq.0.and.link_end_peak.eq.0) return
5586       do i=link_start_peak,link_end_peak
5587         ehpb_peak=0.0d0
5588 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5589 c     &   ipeak(1,i),ipeak(2,i)
5590         do ip=ipeak(1,i),ipeak(2,i)
5591           ii=ihpb_peak(ip)
5592           jj=jhpb_peak(ip)
5593           dd=dist(ii,jj)
5594           iip=ip-ipeak(1,i)+1
5595 C iii and jjj point to the residues for which the distance is assigned.
5596 c          if (ii.gt.nres) then
5597 c            iii=ii-nres
5598 c            jjj=jj-nres
5599 c          else
5600 c            iii=ii
5601 c            jjj=jj
5602 c          endif
5603           if (ii.gt.nres) then
5604             iii=ii-nres
5605           else
5606             iii=ii
5607           endif
5608           if (jj.gt.nres) then
5609             jjj=jj-nres
5610           else
5611             jjj=jj
5612           endif
5613           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5614           aux=dexp(-scal_peak*aux)
5615           ehpb_peak=ehpb_peak+aux
5616           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5617      &      forcon_peak(ip))*aux/dd
5618           do j=1,3
5619             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5620           enddo
5621           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5622      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5623      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5624         enddo
5625 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5626         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5627         do ip=ipeak(1,i),ipeak(2,i)
5628           iip=ip-ipeak(1,i)+1
5629           do j=1,3
5630             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5631           enddo
5632           ii=ihpb_peak(ip)
5633           jj=jhpb_peak(ip)
5634 C iii and jjj point to the residues for which the distance is assigned.
5635 c          if (ii.gt.nres) then
5636 c            iii=ii-nres
5637 c            jjj=jj-nres
5638 c          else
5639 c            iii=ii
5640 c            jjj=jj
5641 c          endif
5642           if (ii.gt.nres) then
5643             iii=ii-nres
5644           else
5645             iii=ii
5646           endif
5647           if (jj.gt.nres) then
5648             jjj=jj-nres
5649           else
5650             jjj=jj
5651           endif
5652           if (iii.lt.ii) then
5653             do j=1,3
5654               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5655             enddo
5656           endif
5657           if (jjj.lt.jj) then
5658             do j=1,3
5659               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5660             enddo
5661           endif
5662           do k=1,3
5663             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5664             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5665           enddo
5666         enddo
5667       enddo
5668       do i=link_start,link_end
5669 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5670 C CA-CA distance used in regularization of structure.
5671         ii=ihpb(i)
5672         jj=jhpb(i)
5673 C iii and jjj point to the residues for which the distance is assigned.
5674         if (ii.gt.nres) then
5675           iii=ii-nres
5676         else
5677           iii=ii
5678         endif
5679         if (jj.gt.nres) then
5680           jjj=jj-nres
5681         else
5682           jjj=jj
5683         endif
5684 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5685 c     &    dhpb(i),dhpb1(i),forcon(i)
5686 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5687 C    distance and angle dependent SS bond potential.
5688 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5689 C     & iabs(itype(jjj)).eq.1) then
5690 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5691 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5692         if (.not.dyn_ss .and. i.le.nss) then
5693 C 15/02/13 CC dynamic SSbond - additional check
5694           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5695      &        iabs(itype(jjj)).eq.1) then
5696            call ssbond_ene(iii,jjj,eij)
5697            ehpb=ehpb+2*eij
5698          endif
5699 cd          write (iout,*) "eij",eij
5700 cd   &   ' waga=',waga,' fac=',fac
5701 !        else if (ii.gt.nres .and. jj.gt.nres) then
5702         else
5703 C Calculate the distance between the two points and its difference from the
5704 C target distance.
5705           dd=dist(ii,jj)
5706           if (irestr_type(i).eq.11) then
5707             ehpb=ehpb+fordepth(i)!**4.0d0
5708      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5709             fac=fordepth(i)!**4.0d0
5710      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5711             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5712      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5713      &        ehpb,irestr_type(i)
5714           else if (irestr_type(i).eq.10) then
5715 c AL 6//19/2018 cross-link restraints
5716             xdis = 0.5d0*(dd/forcon(i))**2
5717             expdis = dexp(-xdis)
5718 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5719             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5720 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5721 c     &          " wboltzd",wboltzd
5722             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5723 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5724             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5725      &           *expdis/(aux*forcon(i)**2)
5726             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5727      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5728      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5729           else if (irestr_type(i).eq.2) then
5730 c Quartic restraints
5731             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5732             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5733      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5734      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5735             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5736           else
5737 c Quadratic restraints
5738             rdis=dd-dhpb(i)
5739 C Get the force constant corresponding to this distance.
5740             waga=forcon(i)
5741 C Calculate the contribution to energy.
5742             ehpb=ehpb+0.5d0*waga*rdis*rdis
5743             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5744      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5745      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5746 C
5747 C Evaluate gradient.
5748 C
5749             fac=waga*rdis/dd
5750           endif
5751 c Calculate Cartesian gradient
5752           do j=1,3
5753             ggg(j)=fac*(c(j,jj)-c(j,ii))
5754           enddo
5755 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5756 C If this is a SC-SC distance, we need to calculate the contributions to the
5757 C Cartesian gradient in the SC vectors (ghpbx).
5758           if (iii.lt.ii) then
5759             do j=1,3
5760               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5761             enddo
5762           endif
5763           if (jjj.lt.jj) then
5764             do j=1,3
5765               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5766             enddo
5767           endif
5768           do k=1,3
5769             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5770             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5771           enddo
5772         endif
5773       enddo
5774       return
5775       end
5776 C--------------------------------------------------------------------------
5777       subroutine ssbond_ene(i,j,eij)
5778 C
5779 C Calculate the distance and angle dependent SS-bond potential energy
5780 C using a free-energy function derived based on RHF/6-31G** ab initio
5781 C calculations of diethyl disulfide.
5782 C
5783 C A. Liwo and U. Kozlowska, 11/24/03
5784 C
5785       implicit real*8 (a-h,o-z)
5786       include 'DIMENSIONS'
5787       include 'COMMON.SBRIDGE'
5788       include 'COMMON.CHAIN'
5789       include 'COMMON.DERIV'
5790       include 'COMMON.LOCAL'
5791       include 'COMMON.INTERACT'
5792       include 'COMMON.VAR'
5793       include 'COMMON.IOUNITS'
5794       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5795       itypi=iabs(itype(i))
5796       xi=c(1,nres+i)
5797       yi=c(2,nres+i)
5798       zi=c(3,nres+i)
5799       dxi=dc_norm(1,nres+i)
5800       dyi=dc_norm(2,nres+i)
5801       dzi=dc_norm(3,nres+i)
5802 c      dsci_inv=dsc_inv(itypi)
5803       dsci_inv=vbld_inv(nres+i)
5804       itypj=iabs(itype(j))
5805 c      dscj_inv=dsc_inv(itypj)
5806       dscj_inv=vbld_inv(nres+j)
5807       xj=c(1,nres+j)-xi
5808       yj=c(2,nres+j)-yi
5809       zj=c(3,nres+j)-zi
5810       dxj=dc_norm(1,nres+j)
5811       dyj=dc_norm(2,nres+j)
5812       dzj=dc_norm(3,nres+j)
5813       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5814       rij=dsqrt(rrij)
5815       erij(1)=xj*rij
5816       erij(2)=yj*rij
5817       erij(3)=zj*rij
5818       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5819       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5820       om12=dxi*dxj+dyi*dyj+dzi*dzj
5821       do k=1,3
5822         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5823         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5824       enddo
5825       rij=1.0d0/rij
5826       deltad=rij-d0cm
5827       deltat1=1.0d0-om1
5828       deltat2=1.0d0+om2
5829       deltat12=om2-om1+2.0d0
5830       cosphi=om12-om1*om2
5831       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5832      &  +akct*deltad*deltat12
5833      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5834 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5835 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5836 c     &  " deltat12",deltat12," eij",eij
5837       ed=2*akcm*deltad+akct*deltat12
5838       pom1=akct*deltad
5839       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5840       eom1=-2*akth*deltat1-pom1-om2*pom2
5841       eom2= 2*akth*deltat2+pom1-om1*pom2
5842       eom12=pom2
5843       do k=1,3
5844         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5845         ghpbx(k,i)=ghpbx(k,i)-ggk
5846      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5847      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5848         ghpbx(k,j)=ghpbx(k,j)+ggk
5849      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5850      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5851         ghpbc(k,i)=ghpbc(k,i)-ggk
5852         ghpbc(k,j)=ghpbc(k,j)+ggk
5853       enddo
5854 C
5855 C Calculate the components of the gradient in DC and X
5856 C
5857 cgrad      do k=i,j-1
5858 cgrad        do l=1,3
5859 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5860 cgrad        enddo
5861 cgrad      enddo
5862       return
5863       end
5864 C--------------------------------------------------------------------------
5865       subroutine ebond(estr)
5866 c
5867 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5868 c
5869       implicit real*8 (a-h,o-z)
5870       include 'DIMENSIONS'
5871       include 'COMMON.LOCAL'
5872       include 'COMMON.GEO'
5873       include 'COMMON.INTERACT'
5874       include 'COMMON.DERIV'
5875       include 'COMMON.VAR'
5876       include 'COMMON.CHAIN'
5877       include 'COMMON.IOUNITS'
5878       include 'COMMON.NAMES'
5879       include 'COMMON.FFIELD'
5880       include 'COMMON.CONTROL'
5881       include 'COMMON.SETUP'
5882       double precision u(3),ud(3)
5883       estr=0.0d0
5884       estr1=0.0d0
5885       do i=ibondp_start,ibondp_end
5886 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5887 c      used
5888 #ifdef FIVEDIAG
5889         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5890         diff = vbld(i)-vbldp0
5891 #else
5892         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5893 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5894 c          do j=1,3
5895 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5896 c     &      *dc(j,i-1)/vbld(i)
5897 c          enddo
5898 c          if (energy_dec) write(iout,*)
5899 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5900 c        else
5901 C       Checking if it involves dummy (NH3+ or COO-) group
5902         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5903 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5904           diff = vbld(i)-vbldpDUM
5905           if (energy_dec) write(iout,*) "dum_bond",i,diff
5906         else
5907 C NO    vbldp0 is the equlibrium length of spring for peptide group
5908           diff = vbld(i)-vbldp0
5909         endif
5910 #endif
5911         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5912      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5913         estr=estr+diff*diff
5914         do j=1,3
5915           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5916         enddo
5917 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5918 c        endif
5919       enddo
5920
5921       estr=0.5d0*AKP*estr+estr1
5922 c
5923 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5924 c
5925       do i=ibond_start,ibond_end
5926         iti=iabs(itype(i))
5927         if (iti.ne.10 .and. iti.ne.ntyp1) then
5928           nbi=nbondterm(iti)
5929           if (nbi.eq.1) then
5930             diff=vbld(i+nres)-vbldsc0(1,iti)
5931             if (energy_dec)  write (iout,*)
5932      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5933      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5934             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5935             do j=1,3
5936               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5937             enddo
5938           else
5939             do j=1,nbi
5940               diff=vbld(i+nres)-vbldsc0(j,iti)
5941               ud(j)=aksc(j,iti)*diff
5942               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5943             enddo
5944             uprod=u(1)
5945             do j=2,nbi
5946               uprod=uprod*u(j)
5947             enddo
5948             usum=0.0d0
5949             usumsqder=0.0d0
5950             do j=1,nbi
5951               uprod1=1.0d0
5952               uprod2=1.0d0
5953               do k=1,nbi
5954                 if (k.ne.j) then
5955                   uprod1=uprod1*u(k)
5956                   uprod2=uprod2*u(k)*u(k)
5957                 endif
5958               enddo
5959               usum=usum+uprod1
5960               usumsqder=usumsqder+ud(j)*uprod2
5961             enddo
5962             estr=estr+uprod/usum
5963             do j=1,3
5964              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5965             enddo
5966           endif
5967         endif
5968       enddo
5969       return
5970       end
5971 #ifdef CRYST_THETA
5972 C--------------------------------------------------------------------------
5973       subroutine ebend(etheta)
5974 C
5975 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5976 C angles gamma and its derivatives in consecutive thetas and gammas.
5977 C
5978       implicit real*8 (a-h,o-z)
5979       include 'DIMENSIONS'
5980       include 'COMMON.LOCAL'
5981       include 'COMMON.GEO'
5982       include 'COMMON.INTERACT'
5983       include 'COMMON.DERIV'
5984       include 'COMMON.VAR'
5985       include 'COMMON.CHAIN'
5986       include 'COMMON.IOUNITS'
5987       include 'COMMON.NAMES'
5988       include 'COMMON.FFIELD'
5989       include 'COMMON.CONTROL'
5990       include 'COMMON.TORCNSTR'
5991       common /calcthet/ term1,term2,termm,diffak,ratak,
5992      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5993      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5994       double precision y(2),z(2)
5995       delta=0.02d0*pi
5996 c      time11=dexp(-2*time)
5997 c      time12=1.0d0
5998       etheta=0.0D0
5999 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6000       do i=ithet_start,ithet_end
6001         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6002      &  .or.itype(i).eq.ntyp1) cycle
6003 C Zero the energy function and its derivative at 0 or pi.
6004         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6005         it=itype(i-1)
6006         ichir1=isign(1,itype(i-2))
6007         ichir2=isign(1,itype(i))
6008          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6009          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6010          if (itype(i-1).eq.10) then
6011           itype1=isign(10,itype(i-2))
6012           ichir11=isign(1,itype(i-2))
6013           ichir12=isign(1,itype(i-2))
6014           itype2=isign(10,itype(i))
6015           ichir21=isign(1,itype(i))
6016           ichir22=isign(1,itype(i))
6017          endif
6018
6019         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6020 #ifdef OSF
6021           phii=phi(i)
6022           if (phii.ne.phii) phii=150.0
6023 #else
6024           phii=phi(i)
6025 #endif
6026           y(1)=dcos(phii)
6027           y(2)=dsin(phii)
6028         else
6029           y(1)=0.0D0
6030           y(2)=0.0D0
6031         endif
6032         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6033 #ifdef OSF
6034           phii1=phi(i+1)
6035           if (phii1.ne.phii1) phii1=150.0
6036           phii1=pinorm(phii1)
6037           z(1)=cos(phii1)
6038 #else
6039           phii1=phi(i+1)
6040 #endif
6041           z(1)=dcos(phii1)
6042           z(2)=dsin(phii1)
6043         else
6044           z(1)=0.0D0
6045           z(2)=0.0D0
6046         endif
6047 C Calculate the "mean" value of theta from the part of the distribution
6048 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6049 C In following comments this theta will be referred to as t_c.
6050         thet_pred_mean=0.0d0
6051         do k=1,2
6052             athetk=athet(k,it,ichir1,ichir2)
6053             bthetk=bthet(k,it,ichir1,ichir2)
6054           if (it.eq.10) then
6055              athetk=athet(k,itype1,ichir11,ichir12)
6056              bthetk=bthet(k,itype2,ichir21,ichir22)
6057           endif
6058          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6059 c         write(iout,*) 'chuj tu', y(k),z(k)
6060         enddo
6061         dthett=thet_pred_mean*ssd
6062         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6063 C Derivatives of the "mean" values in gamma1 and gamma2.
6064         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6065      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6066          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6067      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6068          if (it.eq.10) then
6069       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6070      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6071         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6072      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6073          endif
6074         if (theta(i).gt.pi-delta) then
6075           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6076      &         E_tc0)
6077           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6078           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6079           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6080      &        E_theta)
6081           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6082      &        E_tc)
6083         else if (theta(i).lt.delta) then
6084           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6085           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6086           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6087      &        E_theta)
6088           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6089           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6090      &        E_tc)
6091         else
6092           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6093      &        E_theta,E_tc)
6094         endif
6095         etheta=etheta+ethetai
6096         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6097      &      'ebend',i,ethetai,theta(i),itype(i)
6098         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6099         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6100         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6101       enddo
6102
6103 C Ufff.... We've done all this!!!
6104       return
6105       end
6106 C---------------------------------------------------------------------------
6107       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6108      &     E_tc)
6109       implicit real*8 (a-h,o-z)
6110       include 'DIMENSIONS'
6111       include 'COMMON.LOCAL'
6112       include 'COMMON.IOUNITS'
6113       common /calcthet/ term1,term2,termm,diffak,ratak,
6114      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6115      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6116 C Calculate the contributions to both Gaussian lobes.
6117 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6118 C The "polynomial part" of the "standard deviation" of this part of
6119 C the distributioni.
6120 ccc        write (iout,*) thetai,thet_pred_mean
6121         sig=polthet(3,it)
6122         do j=2,0,-1
6123           sig=sig*thet_pred_mean+polthet(j,it)
6124         enddo
6125 C Derivative of the "interior part" of the "standard deviation of the"
6126 C gamma-dependent Gaussian lobe in t_c.
6127         sigtc=3*polthet(3,it)
6128         do j=2,1,-1
6129           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6130         enddo
6131         sigtc=sig*sigtc
6132 C Set the parameters of both Gaussian lobes of the distribution.
6133 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6134         fac=sig*sig+sigc0(it)
6135         sigcsq=fac+fac
6136         sigc=1.0D0/sigcsq
6137 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6138         sigsqtc=-4.0D0*sigcsq*sigtc
6139 c       print *,i,sig,sigtc,sigsqtc
6140 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6141         sigtc=-sigtc/(fac*fac)
6142 C Following variable is sigma(t_c)**(-2)
6143         sigcsq=sigcsq*sigcsq
6144         sig0i=sig0(it)
6145         sig0inv=1.0D0/sig0i**2
6146         delthec=thetai-thet_pred_mean
6147         delthe0=thetai-theta0i
6148         term1=-0.5D0*sigcsq*delthec*delthec
6149         term2=-0.5D0*sig0inv*delthe0*delthe0
6150 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6151 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6152 C NaNs in taking the logarithm. We extract the largest exponent which is added
6153 C to the energy (this being the log of the distribution) at the end of energy
6154 C term evaluation for this virtual-bond angle.
6155         if (term1.gt.term2) then
6156           termm=term1
6157           term2=dexp(term2-termm)
6158           term1=1.0d0
6159         else
6160           termm=term2
6161           term1=dexp(term1-termm)
6162           term2=1.0d0
6163         endif
6164 C The ratio between the gamma-independent and gamma-dependent lobes of
6165 C the distribution is a Gaussian function of thet_pred_mean too.
6166         diffak=gthet(2,it)-thet_pred_mean
6167         ratak=diffak/gthet(3,it)**2
6168         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6169 C Let's differentiate it in thet_pred_mean NOW.
6170         aktc=ak*ratak
6171 C Now put together the distribution terms to make complete distribution.
6172         termexp=term1+ak*term2
6173         termpre=sigc+ak*sig0i
6174 C Contribution of the bending energy from this theta is just the -log of
6175 C the sum of the contributions from the two lobes and the pre-exponential
6176 C factor. Simple enough, isn't it?
6177         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6178 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6179 C NOW the derivatives!!!
6180 C 6/6/97 Take into account the deformation.
6181         E_theta=(delthec*sigcsq*term1
6182      &       +ak*delthe0*sig0inv*term2)/termexp
6183         E_tc=((sigtc+aktc*sig0i)/termpre
6184      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6185      &       aktc*term2)/termexp)
6186       return
6187       end
6188 c-----------------------------------------------------------------------------
6189       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6190       implicit real*8 (a-h,o-z)
6191       include 'DIMENSIONS'
6192       include 'COMMON.LOCAL'
6193       include 'COMMON.IOUNITS'
6194       common /calcthet/ term1,term2,termm,diffak,ratak,
6195      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6196      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6197       delthec=thetai-thet_pred_mean
6198       delthe0=thetai-theta0i
6199 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6200       t3 = thetai-thet_pred_mean
6201       t6 = t3**2
6202       t9 = term1
6203       t12 = t3*sigcsq
6204       t14 = t12+t6*sigsqtc
6205       t16 = 1.0d0
6206       t21 = thetai-theta0i
6207       t23 = t21**2
6208       t26 = term2
6209       t27 = t21*t26
6210       t32 = termexp
6211       t40 = t32**2
6212       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6213      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6214      & *(-t12*t9-ak*sig0inv*t27)
6215       return
6216       end
6217 #else
6218 C--------------------------------------------------------------------------
6219       subroutine ebend(etheta)
6220 C
6221 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6222 C angles gamma and its derivatives in consecutive thetas and gammas.
6223 C ab initio-derived potentials from
6224 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6225 C
6226       implicit real*8 (a-h,o-z)
6227       include 'DIMENSIONS'
6228       include 'COMMON.LOCAL'
6229       include 'COMMON.GEO'
6230       include 'COMMON.INTERACT'
6231       include 'COMMON.DERIV'
6232       include 'COMMON.VAR'
6233       include 'COMMON.CHAIN'
6234       include 'COMMON.IOUNITS'
6235       include 'COMMON.NAMES'
6236       include 'COMMON.FFIELD'
6237       include 'COMMON.CONTROL'
6238       include 'COMMON.TORCNSTR'
6239       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6240      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6241      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6242      & sinph1ph2(maxdouble,maxdouble)
6243       logical lprn /.false./, lprn1 /.false./
6244       etheta=0.0D0
6245       do i=ithet_start,ithet_end
6246 c        print *,i,itype(i-1),itype(i),itype(i-2)
6247         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6248      &  .or.itype(i).eq.ntyp1) cycle
6249 C        print *,i,theta(i)
6250         if (iabs(itype(i+1)).eq.20) iblock=2
6251         if (iabs(itype(i+1)).ne.20) iblock=1
6252         dethetai=0.0d0
6253         dephii=0.0d0
6254         dephii1=0.0d0
6255         theti2=0.5d0*theta(i)
6256         ityp2=ithetyp((itype(i-1)))
6257         do k=1,nntheterm
6258           coskt(k)=dcos(k*theti2)
6259           sinkt(k)=dsin(k*theti2)
6260         enddo
6261 C        print *,ethetai
6262         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6263 #ifdef OSF
6264           phii=phi(i)
6265           if (phii.ne.phii) phii=150.0
6266 #else
6267           phii=phi(i)
6268 #endif
6269           ityp1=ithetyp((itype(i-2)))
6270 C propagation of chirality for glycine type
6271           do k=1,nsingle
6272             cosph1(k)=dcos(k*phii)
6273             sinph1(k)=dsin(k*phii)
6274           enddo
6275         else
6276           phii=0.0d0
6277           do k=1,nsingle
6278           ityp1=ithetyp((itype(i-2)))
6279             cosph1(k)=0.0d0
6280             sinph1(k)=0.0d0
6281           enddo
6282         endif
6283         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6284 #ifdef OSF
6285           phii1=phi(i+1)
6286           if (phii1.ne.phii1) phii1=150.0
6287           phii1=pinorm(phii1)
6288 #else
6289           phii1=phi(i+1)
6290 #endif
6291           ityp3=ithetyp((itype(i)))
6292           do k=1,nsingle
6293             cosph2(k)=dcos(k*phii1)
6294             sinph2(k)=dsin(k*phii1)
6295           enddo
6296         else
6297           phii1=0.0d0
6298           ityp3=ithetyp((itype(i)))
6299           do k=1,nsingle
6300             cosph2(k)=0.0d0
6301             sinph2(k)=0.0d0
6302           enddo
6303         endif
6304         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6305         do k=1,ndouble
6306           do l=1,k-1
6307             ccl=cosph1(l)*cosph2(k-l)
6308             ssl=sinph1(l)*sinph2(k-l)
6309             scl=sinph1(l)*cosph2(k-l)
6310             csl=cosph1(l)*sinph2(k-l)
6311             cosph1ph2(l,k)=ccl-ssl
6312             cosph1ph2(k,l)=ccl+ssl
6313             sinph1ph2(l,k)=scl+csl
6314             sinph1ph2(k,l)=scl-csl
6315           enddo
6316         enddo
6317         if (lprn) then
6318         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6319      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6320         write (iout,*) "coskt and sinkt"
6321         do k=1,nntheterm
6322           write (iout,*) k,coskt(k),sinkt(k)
6323         enddo
6324         endif
6325         do k=1,ntheterm
6326           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6327           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6328      &      *coskt(k)
6329           if (lprn)
6330      &    write (iout,*) "k",k,"
6331      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6332      &     " ethetai",ethetai
6333         enddo
6334         if (lprn) then
6335         write (iout,*) "cosph and sinph"
6336         do k=1,nsingle
6337           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6338         enddo
6339         write (iout,*) "cosph1ph2 and sinph2ph2"
6340         do k=2,ndouble
6341           do l=1,k-1
6342             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6343      &         sinph1ph2(l,k),sinph1ph2(k,l)
6344           enddo
6345         enddo
6346         write(iout,*) "ethetai",ethetai
6347         endif
6348 C       print *,ethetai
6349         do m=1,ntheterm2
6350           do k=1,nsingle
6351             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6352      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6353      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6354      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6355             ethetai=ethetai+sinkt(m)*aux
6356             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6357             dephii=dephii+k*sinkt(m)*(
6358      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6359      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6360             dephii1=dephii1+k*sinkt(m)*(
6361      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6362      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6363             if (lprn)
6364      &      write (iout,*) "m",m," k",k," bbthet",
6365      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6366      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6367      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6368      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6369 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6370           enddo
6371         enddo
6372 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6373 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6374 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6375 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6376         if (lprn)
6377      &  write(iout,*) "ethetai",ethetai
6378 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6379         do m=1,ntheterm3
6380           do k=2,ndouble
6381             do l=1,k-1
6382               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6383      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6384      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6385      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6386               ethetai=ethetai+sinkt(m)*aux
6387               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6388               dephii=dephii+l*sinkt(m)*(
6389      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6390      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6391      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6392      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6393               dephii1=dephii1+(k-l)*sinkt(m)*(
6394      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6395      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6396      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6397      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6398               if (lprn) then
6399               write (iout,*) "m",m," k",k," l",l," ffthet",
6400      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6401      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6402      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6403      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6404      &            " ethetai",ethetai
6405               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6406      &            cosph1ph2(k,l)*sinkt(m),
6407      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6408               endif
6409             enddo
6410           enddo
6411         enddo
6412 10      continue
6413 c        lprn1=.true.
6414 C        print *,ethetai
6415         if (lprn1)
6416      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6417      &   i,theta(i)*rad2deg,phii*rad2deg,
6418      &   phii1*rad2deg,ethetai
6419 c        lprn1=.false.
6420         etheta=etheta+ethetai
6421         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6422         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6423         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6424       enddo
6425
6426       return
6427       end
6428 #endif
6429 #ifdef CRYST_SC
6430 c-----------------------------------------------------------------------------
6431       subroutine esc(escloc)
6432 C Calculate the local energy of a side chain and its derivatives in the
6433 C corresponding virtual-bond valence angles THETA and the spherical angles
6434 C ALPHA and OMEGA.
6435       implicit real*8 (a-h,o-z)
6436       include 'DIMENSIONS'
6437       include 'COMMON.GEO'
6438       include 'COMMON.LOCAL'
6439       include 'COMMON.VAR'
6440       include 'COMMON.INTERACT'
6441       include 'COMMON.DERIV'
6442       include 'COMMON.CHAIN'
6443       include 'COMMON.IOUNITS'
6444       include 'COMMON.NAMES'
6445       include 'COMMON.FFIELD'
6446       include 'COMMON.CONTROL'
6447       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6448      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6449       common /sccalc/ time11,time12,time112,theti,it,nlobit
6450       delta=0.02d0*pi
6451       escloc=0.0D0
6452 c     write (iout,'(a)') 'ESC'
6453       do i=loc_start,loc_end
6454         it=itype(i)
6455         if (it.eq.ntyp1) cycle
6456         if (it.eq.10) goto 1
6457         nlobit=nlob(iabs(it))
6458 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6459 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6460         theti=theta(i+1)-pipol
6461         x(1)=dtan(theti)
6462         x(2)=alph(i)
6463         x(3)=omeg(i)
6464
6465         if (x(2).gt.pi-delta) then
6466           xtemp(1)=x(1)
6467           xtemp(2)=pi-delta
6468           xtemp(3)=x(3)
6469           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6470           xtemp(2)=pi
6471           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6472           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6473      &        escloci,dersc(2))
6474           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6475      &        ddersc0(1),dersc(1))
6476           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6477      &        ddersc0(3),dersc(3))
6478           xtemp(2)=pi-delta
6479           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6480           xtemp(2)=pi
6481           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6482           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6483      &            dersc0(2),esclocbi,dersc02)
6484           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6485      &            dersc12,dersc01)
6486           call splinthet(x(2),0.5d0*delta,ss,ssd)
6487           dersc0(1)=dersc01
6488           dersc0(2)=dersc02
6489           dersc0(3)=0.0d0
6490           do k=1,3
6491             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6492           enddo
6493           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6494 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6495 c    &             esclocbi,ss,ssd
6496           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6497 c         escloci=esclocbi
6498 c         write (iout,*) escloci
6499         else if (x(2).lt.delta) then
6500           xtemp(1)=x(1)
6501           xtemp(2)=delta
6502           xtemp(3)=x(3)
6503           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6504           xtemp(2)=0.0d0
6505           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6506           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6507      &        escloci,dersc(2))
6508           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6509      &        ddersc0(1),dersc(1))
6510           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6511      &        ddersc0(3),dersc(3))
6512           xtemp(2)=delta
6513           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6514           xtemp(2)=0.0d0
6515           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6516           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6517      &            dersc0(2),esclocbi,dersc02)
6518           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6519      &            dersc12,dersc01)
6520           dersc0(1)=dersc01
6521           dersc0(2)=dersc02
6522           dersc0(3)=0.0d0
6523           call splinthet(x(2),0.5d0*delta,ss,ssd)
6524           do k=1,3
6525             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6526           enddo
6527           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6528 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6529 c    &             esclocbi,ss,ssd
6530           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6531 c         write (iout,*) escloci
6532         else
6533           call enesc(x,escloci,dersc,ddummy,.false.)
6534         endif
6535
6536         escloc=escloc+escloci
6537         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6538      &     'escloc',i,escloci
6539 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6540
6541         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6542      &   wscloc*dersc(1)
6543         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6544         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6545     1   continue
6546       enddo
6547       return
6548       end
6549 C---------------------------------------------------------------------------
6550       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6551       implicit real*8 (a-h,o-z)
6552       include 'DIMENSIONS'
6553       include 'COMMON.GEO'
6554       include 'COMMON.LOCAL'
6555       include 'COMMON.IOUNITS'
6556       common /sccalc/ time11,time12,time112,theti,it,nlobit
6557       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6558       double precision contr(maxlob,-1:1)
6559       logical mixed
6560 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6561         escloc_i=0.0D0
6562         do j=1,3
6563           dersc(j)=0.0D0
6564           if (mixed) ddersc(j)=0.0d0
6565         enddo
6566         x3=x(3)
6567
6568 C Because of periodicity of the dependence of the SC energy in omega we have
6569 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6570 C To avoid underflows, first compute & store the exponents.
6571
6572         do iii=-1,1
6573
6574           x(3)=x3+iii*dwapi
6575
6576           do j=1,nlobit
6577             do k=1,3
6578               z(k)=x(k)-censc(k,j,it)
6579             enddo
6580             do k=1,3
6581               Axk=0.0D0
6582               do l=1,3
6583                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6584               enddo
6585               Ax(k,j,iii)=Axk
6586             enddo
6587             expfac=0.0D0
6588             do k=1,3
6589               expfac=expfac+Ax(k,j,iii)*z(k)
6590             enddo
6591             contr(j,iii)=expfac
6592           enddo ! j
6593
6594         enddo ! iii
6595
6596         x(3)=x3
6597 C As in the case of ebend, we want to avoid underflows in exponentiation and
6598 C subsequent NaNs and INFs in energy calculation.
6599 C Find the largest exponent
6600         emin=contr(1,-1)
6601         do iii=-1,1
6602           do j=1,nlobit
6603             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6604           enddo
6605         enddo
6606         emin=0.5D0*emin
6607 cd      print *,'it=',it,' emin=',emin
6608
6609 C Compute the contribution to SC energy and derivatives
6610         do iii=-1,1
6611
6612           do j=1,nlobit
6613 #ifdef OSF
6614             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6615             if(adexp.ne.adexp) adexp=1.0
6616             expfac=dexp(adexp)
6617 #else
6618             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6619 #endif
6620 cd          print *,'j=',j,' expfac=',expfac
6621             escloc_i=escloc_i+expfac
6622             do k=1,3
6623               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6624             enddo
6625             if (mixed) then
6626               do k=1,3,2
6627                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6628      &            +gaussc(k,2,j,it))*expfac
6629               enddo
6630             endif
6631           enddo
6632
6633         enddo ! iii
6634
6635         dersc(1)=dersc(1)/cos(theti)**2
6636         ddersc(1)=ddersc(1)/cos(theti)**2
6637         ddersc(3)=ddersc(3)
6638
6639         escloci=-(dlog(escloc_i)-emin)
6640         do j=1,3
6641           dersc(j)=dersc(j)/escloc_i
6642         enddo
6643         if (mixed) then
6644           do j=1,3,2
6645             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6646           enddo
6647         endif
6648       return
6649       end
6650 C------------------------------------------------------------------------------
6651       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6652       implicit real*8 (a-h,o-z)
6653       include 'DIMENSIONS'
6654       include 'COMMON.GEO'
6655       include 'COMMON.LOCAL'
6656       include 'COMMON.IOUNITS'
6657       common /sccalc/ time11,time12,time112,theti,it,nlobit
6658       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6659       double precision contr(maxlob)
6660       logical mixed
6661
6662       escloc_i=0.0D0
6663
6664       do j=1,3
6665         dersc(j)=0.0D0
6666       enddo
6667
6668       do j=1,nlobit
6669         do k=1,2
6670           z(k)=x(k)-censc(k,j,it)
6671         enddo
6672         z(3)=dwapi
6673         do k=1,3
6674           Axk=0.0D0
6675           do l=1,3
6676             Axk=Axk+gaussc(l,k,j,it)*z(l)
6677           enddo
6678           Ax(k,j)=Axk
6679         enddo
6680         expfac=0.0D0
6681         do k=1,3
6682           expfac=expfac+Ax(k,j)*z(k)
6683         enddo
6684         contr(j)=expfac
6685       enddo ! j
6686
6687 C As in the case of ebend, we want to avoid underflows in exponentiation and
6688 C subsequent NaNs and INFs in energy calculation.
6689 C Find the largest exponent
6690       emin=contr(1)
6691       do j=1,nlobit
6692         if (emin.gt.contr(j)) emin=contr(j)
6693       enddo
6694       emin=0.5D0*emin
6695
6696 C Compute the contribution to SC energy and derivatives
6697
6698       dersc12=0.0d0
6699       do j=1,nlobit
6700         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6701         escloc_i=escloc_i+expfac
6702         do k=1,2
6703           dersc(k)=dersc(k)+Ax(k,j)*expfac
6704         enddo
6705         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6706      &            +gaussc(1,2,j,it))*expfac
6707         dersc(3)=0.0d0
6708       enddo
6709
6710       dersc(1)=dersc(1)/cos(theti)**2
6711       dersc12=dersc12/cos(theti)**2
6712       escloci=-(dlog(escloc_i)-emin)
6713       do j=1,2
6714         dersc(j)=dersc(j)/escloc_i
6715       enddo
6716       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6717       return
6718       end
6719 #else
6720 c----------------------------------------------------------------------------------
6721       subroutine esc(escloc)
6722 C Calculate the local energy of a side chain and its derivatives in the
6723 C corresponding virtual-bond valence angles THETA and the spherical angles
6724 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6725 C added by Urszula Kozlowska. 07/11/2007
6726 C
6727       implicit real*8 (a-h,o-z)
6728       include 'DIMENSIONS'
6729       include 'COMMON.GEO'
6730       include 'COMMON.LOCAL'
6731       include 'COMMON.VAR'
6732       include 'COMMON.SCROT'
6733       include 'COMMON.INTERACT'
6734       include 'COMMON.DERIV'
6735       include 'COMMON.CHAIN'
6736       include 'COMMON.IOUNITS'
6737       include 'COMMON.NAMES'
6738       include 'COMMON.FFIELD'
6739       include 'COMMON.CONTROL'
6740       include 'COMMON.VECTORS'
6741       double precision x_prime(3),y_prime(3),z_prime(3)
6742      &    , sumene,dsc_i,dp2_i,x(65),
6743      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6744      &    de_dxx,de_dyy,de_dzz,de_dt
6745       double precision s1_t,s1_6_t,s2_t,s2_6_t
6746       double precision
6747      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6748      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6749      & dt_dCi(3),dt_dCi1(3)
6750       common /sccalc/ time11,time12,time112,theti,it,nlobit
6751       delta=0.02d0*pi
6752       escloc=0.0D0
6753       do i=loc_start,loc_end
6754         if (itype(i).eq.ntyp1) cycle
6755         costtab(i+1) =dcos(theta(i+1))
6756         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6757         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6758         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6759         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6760         cosfac=dsqrt(cosfac2)
6761         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6762         sinfac=dsqrt(sinfac2)
6763         it=iabs(itype(i))
6764         if (it.eq.10) goto 1
6765 c
6766 C  Compute the axes of tghe local cartesian coordinates system; store in
6767 c   x_prime, y_prime and z_prime
6768 c
6769         do j=1,3
6770           x_prime(j) = 0.00
6771           y_prime(j) = 0.00
6772           z_prime(j) = 0.00
6773         enddo
6774 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6775 C     &   dc_norm(3,i+nres)
6776         do j = 1,3
6777           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6778           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6779         enddo
6780         do j = 1,3
6781           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6782         enddo
6783 c       write (2,*) "i",i
6784 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6785 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6786 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6787 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6788 c      & " xy",scalar(x_prime(1),y_prime(1)),
6789 c      & " xz",scalar(x_prime(1),z_prime(1)),
6790 c      & " yy",scalar(y_prime(1),y_prime(1)),
6791 c      & " yz",scalar(y_prime(1),z_prime(1)),
6792 c      & " zz",scalar(z_prime(1),z_prime(1))
6793 c
6794 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6795 C to local coordinate system. Store in xx, yy, zz.
6796 c
6797         xx=0.0d0
6798         yy=0.0d0
6799         zz=0.0d0
6800         do j = 1,3
6801           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6802           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6803           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6804         enddo
6805
6806         xxtab(i)=xx
6807         yytab(i)=yy
6808         zztab(i)=zz
6809 C
6810 C Compute the energy of the ith side cbain
6811 C
6812 c        write (2,*) "xx",xx," yy",yy," zz",zz
6813         it=iabs(itype(i))
6814         do j = 1,65
6815           x(j) = sc_parmin(j,it)
6816         enddo
6817 #ifdef CHECK_COORD
6818 Cc diagnostics - remove later
6819         xx1 = dcos(alph(2))
6820         yy1 = dsin(alph(2))*dcos(omeg(2))
6821         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6822         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6823      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6824      &    xx1,yy1,zz1
6825 C,"  --- ", xx_w,yy_w,zz_w
6826 c end diagnostics
6827 #endif
6828         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6829      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6830      &   + x(10)*yy*zz
6831         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6832      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6833      & + x(20)*yy*zz
6834         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6835      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6836      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6837      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6838      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6839      &  +x(40)*xx*yy*zz
6840         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6841      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6842      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6843      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6844      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6845      &  +x(60)*xx*yy*zz
6846         dsc_i   = 0.743d0+x(61)
6847         dp2_i   = 1.9d0+x(62)
6848         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6849      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6850         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6851      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6852         s1=(1+x(63))/(0.1d0 + dscp1)
6853         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6854         s2=(1+x(65))/(0.1d0 + dscp2)
6855         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6856         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6857      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6858 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6859 c     &   sumene4,
6860 c     &   dscp1,dscp2,sumene
6861 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6862         escloc = escloc + sumene
6863         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6864      &   " escloc",sumene,escloc,it,itype(i)
6865 c     & ,zz,xx,yy
6866 c#define DEBUG
6867 #ifdef DEBUG
6868 C
6869 C This section to check the numerical derivatives of the energy of ith side
6870 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6871 C #define DEBUG in the code to turn it on.
6872 C
6873         write (2,*) "sumene               =",sumene
6874         aincr=1.0d-7
6875         xxsave=xx
6876         xx=xx+aincr
6877         write (2,*) xx,yy,zz
6878         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6879         de_dxx_num=(sumenep-sumene)/aincr
6880         xx=xxsave
6881         write (2,*) "xx+ sumene from enesc=",sumenep
6882         yysave=yy
6883         yy=yy+aincr
6884         write (2,*) xx,yy,zz
6885         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6886         de_dyy_num=(sumenep-sumene)/aincr
6887         yy=yysave
6888         write (2,*) "yy+ sumene from enesc=",sumenep
6889         zzsave=zz
6890         zz=zz+aincr
6891         write (2,*) xx,yy,zz
6892         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6893         de_dzz_num=(sumenep-sumene)/aincr
6894         zz=zzsave
6895         write (2,*) "zz+ sumene from enesc=",sumenep
6896         costsave=cost2tab(i+1)
6897         sintsave=sint2tab(i+1)
6898         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6899         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6900         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6901         de_dt_num=(sumenep-sumene)/aincr
6902         write (2,*) " t+ sumene from enesc=",sumenep
6903         cost2tab(i+1)=costsave
6904         sint2tab(i+1)=sintsave
6905 C End of diagnostics section.
6906 #endif
6907 C
6908 C Compute the gradient of esc
6909 C
6910 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6911         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6912         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6913         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6914         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6915         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6916         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6917         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6918         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6919         pom1=(sumene3*sint2tab(i+1)+sumene1)
6920      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6921         pom2=(sumene4*cost2tab(i+1)+sumene2)
6922      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6923         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6924         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6925      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6926      &  +x(40)*yy*zz
6927         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6928         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6929      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6930      &  +x(60)*yy*zz
6931         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6932      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6933      &        +(pom1+pom2)*pom_dx
6934 #ifdef DEBUG
6935         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6936 #endif
6937 C
6938         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6939         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6940      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6941      &  +x(40)*xx*zz
6942         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6943         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6944      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6945      &  +x(59)*zz**2 +x(60)*xx*zz
6946         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6947      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6948      &        +(pom1-pom2)*pom_dy
6949 #ifdef DEBUG
6950         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6951 #endif
6952 C
6953         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6954      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6955      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6956      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6957      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6958      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6959      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6960      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6961 #ifdef DEBUG
6962         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6963 #endif
6964 C
6965         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6966      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6967      &  +pom1*pom_dt1+pom2*pom_dt2
6968 #ifdef DEBUG
6969         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6970 #endif
6971 c#undef DEBUG
6972 c
6973 C
6974        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6975        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6976        cosfac2xx=cosfac2*xx
6977        sinfac2yy=sinfac2*yy
6978        do k = 1,3
6979          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6980      &      vbld_inv(i+1)
6981          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6982      &      vbld_inv(i)
6983          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6984          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6985 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6986 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6987 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6988 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6989          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6990          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6991          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6992          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6993          dZZ_Ci1(k)=0.0d0
6994          dZZ_Ci(k)=0.0d0
6995          do j=1,3
6996            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6997      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6998            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6999      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7000          enddo
7001
7002          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7003          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7004          dZZ_XYZ(k)=vbld_inv(i+nres)*
7005      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7006 c
7007          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7008          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7009        enddo
7010
7011        do k=1,3
7012          dXX_Ctab(k,i)=dXX_Ci(k)
7013          dXX_C1tab(k,i)=dXX_Ci1(k)
7014          dYY_Ctab(k,i)=dYY_Ci(k)
7015          dYY_C1tab(k,i)=dYY_Ci1(k)
7016          dZZ_Ctab(k,i)=dZZ_Ci(k)
7017          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7018          dXX_XYZtab(k,i)=dXX_XYZ(k)
7019          dYY_XYZtab(k,i)=dYY_XYZ(k)
7020          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7021        enddo
7022
7023        do k = 1,3
7024 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7025 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7026 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7027 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7028 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7029 c     &    dt_dci(k)
7030 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7031 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7032          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7033      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7034          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7035      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7036          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7037      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7038        enddo
7039 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7040 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7041
7042 C to check gradient call subroutine check_grad
7043
7044     1 continue
7045       enddo
7046       return
7047       end
7048 c------------------------------------------------------------------------------
7049       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7050       implicit none
7051       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7052      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7053       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7054      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7055      &   + x(10)*yy*zz
7056       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7057      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7058      & + x(20)*yy*zz
7059       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7060      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7061      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7062      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7063      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7064      &  +x(40)*xx*yy*zz
7065       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7066      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7067      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7068      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7069      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7070      &  +x(60)*xx*yy*zz
7071       dsc_i   = 0.743d0+x(61)
7072       dp2_i   = 1.9d0+x(62)
7073       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7074      &          *(xx*cost2+yy*sint2))
7075       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7076      &          *(xx*cost2-yy*sint2))
7077       s1=(1+x(63))/(0.1d0 + dscp1)
7078       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7079       s2=(1+x(65))/(0.1d0 + dscp2)
7080       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7081       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7082      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7083       enesc=sumene
7084       return
7085       end
7086 #endif
7087 c------------------------------------------------------------------------------
7088       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7089 C
7090 C This procedure calculates two-body contact function g(rij) and its derivative:
7091 C
7092 C           eps0ij                                     !       x < -1
7093 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7094 C            0                                         !       x > 1
7095 C
7096 C where x=(rij-r0ij)/delta
7097 C
7098 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7099 C
7100       implicit none
7101       double precision rij,r0ij,eps0ij,fcont,fprimcont
7102       double precision x,x2,x4,delta
7103 c     delta=0.02D0*r0ij
7104 c      delta=0.2D0*r0ij
7105       x=(rij-r0ij)/delta
7106       if (x.lt.-1.0D0) then
7107         fcont=eps0ij
7108         fprimcont=0.0D0
7109       else if (x.le.1.0D0) then
7110         x2=x*x
7111         x4=x2*x2
7112         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7113         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7114       else
7115         fcont=0.0D0
7116         fprimcont=0.0D0
7117       endif
7118       return
7119       end
7120 c------------------------------------------------------------------------------
7121       subroutine splinthet(theti,delta,ss,ssder)
7122       implicit real*8 (a-h,o-z)
7123       include 'DIMENSIONS'
7124       include 'COMMON.VAR'
7125       include 'COMMON.GEO'
7126       thetup=pi-delta
7127       thetlow=delta
7128       if (theti.gt.pipol) then
7129         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7130       else
7131         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7132         ssder=-ssder
7133       endif
7134       return
7135       end
7136 c------------------------------------------------------------------------------
7137       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7138       implicit none
7139       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7140       double precision ksi,ksi2,ksi3,a1,a2,a3
7141       a1=fprim0*delta/(f1-f0)
7142       a2=3.0d0-2.0d0*a1
7143       a3=a1-2.0d0
7144       ksi=(x-x0)/delta
7145       ksi2=ksi*ksi
7146       ksi3=ksi2*ksi
7147       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7148       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7149       return
7150       end
7151 c------------------------------------------------------------------------------
7152       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7153       implicit none
7154       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7155       double precision ksi,ksi2,ksi3,a1,a2,a3
7156       ksi=(x-x0)/delta
7157       ksi2=ksi*ksi
7158       ksi3=ksi2*ksi
7159       a1=fprim0x*delta
7160       a2=3*(f1x-f0x)-2*fprim0x*delta
7161       a3=fprim0x*delta-2*(f1x-f0x)
7162       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7163       return
7164       end
7165 C-----------------------------------------------------------------------------
7166 #ifdef CRYST_TOR
7167 C-----------------------------------------------------------------------------
7168       subroutine etor(etors)
7169       implicit real*8 (a-h,o-z)
7170       include 'DIMENSIONS'
7171       include 'COMMON.VAR'
7172       include 'COMMON.GEO'
7173       include 'COMMON.LOCAL'
7174       include 'COMMON.TORSION'
7175       include 'COMMON.INTERACT'
7176       include 'COMMON.DERIV'
7177       include 'COMMON.CHAIN'
7178       include 'COMMON.NAMES'
7179       include 'COMMON.IOUNITS'
7180       include 'COMMON.FFIELD'
7181       include 'COMMON.TORCNSTR'
7182       include 'COMMON.CONTROL'
7183       logical lprn
7184 C Set lprn=.true. for debugging
7185       lprn=.false.
7186 c      lprn=.true.
7187       etors=0.0D0
7188       do i=iphi_start,iphi_end
7189       etors_ii=0.0D0
7190         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7191      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7192         itori=itortyp(itype(i-2))
7193         itori1=itortyp(itype(i-1))
7194         phii=phi(i)
7195         gloci=0.0D0
7196 C Proline-Proline pair is a special case...
7197         if (itori.eq.3 .and. itori1.eq.3) then
7198           if (phii.gt.-dwapi3) then
7199             cosphi=dcos(3*phii)
7200             fac=1.0D0/(1.0D0-cosphi)
7201             etorsi=v1(1,3,3)*fac
7202             etorsi=etorsi+etorsi
7203             etors=etors+etorsi-v1(1,3,3)
7204             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7205             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7206           endif
7207           do j=1,3
7208             v1ij=v1(j+1,itori,itori1)
7209             v2ij=v2(j+1,itori,itori1)
7210             cosphi=dcos(j*phii)
7211             sinphi=dsin(j*phii)
7212             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7213             if (energy_dec) etors_ii=etors_ii+
7214      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7215             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7216           enddo
7217         else
7218           do j=1,nterm_old
7219             v1ij=v1(j,itori,itori1)
7220             v2ij=v2(j,itori,itori1)
7221             cosphi=dcos(j*phii)
7222             sinphi=dsin(j*phii)
7223             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7224             if (energy_dec) etors_ii=etors_ii+
7225      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7226             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7227           enddo
7228         endif
7229         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7230              'etor',i,etors_ii
7231         if (lprn)
7232      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7233      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7234      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7235         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7236 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7237       enddo
7238       return
7239       end
7240 c------------------------------------------------------------------------------
7241       subroutine etor_d(etors_d)
7242       etors_d=0.0d0
7243       return
7244       end
7245 c----------------------------------------------------------------------------
7246 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7247       subroutine e_modeller(ehomology_constr)
7248       ehomology_constr=0.0d0
7249       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7250       return
7251       end
7252 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7253
7254 c------------------------------------------------------------------------------
7255       subroutine etor_d(etors_d)
7256       etors_d=0.0d0
7257       return
7258       end
7259 c----------------------------------------------------------------------------
7260 #else
7261       subroutine etor(etors)
7262       implicit real*8 (a-h,o-z)
7263       include 'DIMENSIONS'
7264       include 'COMMON.VAR'
7265       include 'COMMON.GEO'
7266       include 'COMMON.LOCAL'
7267       include 'COMMON.TORSION'
7268       include 'COMMON.INTERACT'
7269       include 'COMMON.DERIV'
7270       include 'COMMON.CHAIN'
7271       include 'COMMON.NAMES'
7272       include 'COMMON.IOUNITS'
7273       include 'COMMON.FFIELD'
7274       include 'COMMON.TORCNSTR'
7275       include 'COMMON.CONTROL'
7276       logical lprn
7277 C Set lprn=.true. for debugging
7278       lprn=.false.
7279 c     lprn=.true.
7280       etors=0.0D0
7281       do i=iphi_start,iphi_end
7282 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7283 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7284 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7285 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7286         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7287      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7288 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7289 C For introducing the NH3+ and COO- group please check the etor_d for reference
7290 C and guidance
7291         etors_ii=0.0D0
7292          if (iabs(itype(i)).eq.20) then
7293          iblock=2
7294          else
7295          iblock=1
7296          endif
7297         itori=itortyp(itype(i-2))
7298         itori1=itortyp(itype(i-1))
7299         phii=phi(i)
7300         gloci=0.0D0
7301 C Regular cosine and sine terms
7302         do j=1,nterm(itori,itori1,iblock)
7303           v1ij=v1(j,itori,itori1,iblock)
7304           v2ij=v2(j,itori,itori1,iblock)
7305           cosphi=dcos(j*phii)
7306           sinphi=dsin(j*phii)
7307           etors=etors+v1ij*cosphi+v2ij*sinphi
7308           if (energy_dec) etors_ii=etors_ii+
7309      &                v1ij*cosphi+v2ij*sinphi
7310           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7311         enddo
7312 C Lorentz terms
7313 C                         v1
7314 C  E = SUM ----------------------------------- - v1
7315 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7316 C
7317         cosphi=dcos(0.5d0*phii)
7318         sinphi=dsin(0.5d0*phii)
7319         do j=1,nlor(itori,itori1,iblock)
7320           vl1ij=vlor1(j,itori,itori1)
7321           vl2ij=vlor2(j,itori,itori1)
7322           vl3ij=vlor3(j,itori,itori1)
7323           pom=vl2ij*cosphi+vl3ij*sinphi
7324           pom1=1.0d0/(pom*pom+1.0d0)
7325           etors=etors+vl1ij*pom1
7326           if (energy_dec) etors_ii=etors_ii+
7327      &                vl1ij*pom1
7328           pom=-pom*pom1*pom1
7329           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7330         enddo
7331 C Subtract the constant term
7332         etors=etors-v0(itori,itori1,iblock)
7333           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7334      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7335         if (lprn)
7336      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7337      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7338      &  (v1(j,itori,itori1,iblock),j=1,6),
7339      &  (v2(j,itori,itori1,iblock),j=1,6)
7340         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7341 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7342       enddo
7343       return
7344       end
7345 c----------------------------------------------------------------------------
7346       subroutine etor_d(etors_d)
7347 C 6/23/01 Compute double torsional energy
7348       implicit real*8 (a-h,o-z)
7349       include 'DIMENSIONS'
7350       include 'COMMON.VAR'
7351       include 'COMMON.GEO'
7352       include 'COMMON.LOCAL'
7353       include 'COMMON.TORSION'
7354       include 'COMMON.INTERACT'
7355       include 'COMMON.DERIV'
7356       include 'COMMON.CHAIN'
7357       include 'COMMON.NAMES'
7358       include 'COMMON.IOUNITS'
7359       include 'COMMON.FFIELD'
7360       include 'COMMON.TORCNSTR'
7361       logical lprn
7362 C Set lprn=.true. for debugging
7363       lprn=.false.
7364 c     lprn=.true.
7365       etors_d=0.0D0
7366 c      write(iout,*) "a tu??"
7367       do i=iphid_start,iphid_end
7368 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7369 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7370 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7371 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7372 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7373          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7374      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7375      &  (itype(i+1).eq.ntyp1)) cycle
7376 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7377         itori=itortyp(itype(i-2))
7378         itori1=itortyp(itype(i-1))
7379         itori2=itortyp(itype(i))
7380         phii=phi(i)
7381         phii1=phi(i+1)
7382         gloci1=0.0D0
7383         gloci2=0.0D0
7384         iblock=1
7385         if (iabs(itype(i+1)).eq.20) iblock=2
7386 C Iblock=2 Proline type
7387 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7388 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7389 C        if (itype(i+1).eq.ntyp1) iblock=3
7390 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7391 C IS or IS NOT need for this
7392 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7393 C        is (itype(i-3).eq.ntyp1) ntblock=2
7394 C        ntblock is N-terminal blocking group
7395
7396 C Regular cosine and sine terms
7397         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7398 C Example of changes for NH3+ blocking group
7399 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7400 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7401           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7402           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7403           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7404           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7405           cosphi1=dcos(j*phii)
7406           sinphi1=dsin(j*phii)
7407           cosphi2=dcos(j*phii1)
7408           sinphi2=dsin(j*phii1)
7409           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7410      &     v2cij*cosphi2+v2sij*sinphi2
7411           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7412           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7413         enddo
7414         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7415           do l=1,k-1
7416             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7417             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7418             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7419             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7420             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7421             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7422             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7423             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7424             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7425      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7426             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7427      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7428             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7429      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7430           enddo
7431         enddo
7432         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7433         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7434       enddo
7435       return
7436       end
7437 #endif
7438 C----------------------------------------------------------------------------------
7439 C The rigorous attempt to derive energy function
7440       subroutine etor_kcc(etors)
7441       implicit real*8 (a-h,o-z)
7442       include 'DIMENSIONS'
7443       include 'COMMON.VAR'
7444       include 'COMMON.GEO'
7445       include 'COMMON.LOCAL'
7446       include 'COMMON.TORSION'
7447       include 'COMMON.INTERACT'
7448       include 'COMMON.DERIV'
7449       include 'COMMON.CHAIN'
7450       include 'COMMON.NAMES'
7451       include 'COMMON.IOUNITS'
7452       include 'COMMON.FFIELD'
7453       include 'COMMON.TORCNSTR'
7454       include 'COMMON.CONTROL'
7455       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7456       logical lprn
7457 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7458 C Set lprn=.true. for debugging
7459       lprn=energy_dec
7460 c     lprn=.true.
7461 C      print *,"wchodze kcc"
7462       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7463       etors=0.0D0
7464       do i=iphi_start,iphi_end
7465 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7466 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7467 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7468 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7469         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7470      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7471         itori=itortyp(itype(i-2))
7472         itori1=itortyp(itype(i-1))
7473         phii=phi(i)
7474         glocig=0.0D0
7475         glocit1=0.0d0
7476         glocit2=0.0d0
7477 C to avoid multiple devision by 2
7478 c        theti22=0.5d0*theta(i)
7479 C theta 12 is the theta_1 /2
7480 C theta 22 is theta_2 /2
7481 c        theti12=0.5d0*theta(i-1)
7482 C and appropriate sinus function
7483         sinthet1=dsin(theta(i-1))
7484         sinthet2=dsin(theta(i))
7485         costhet1=dcos(theta(i-1))
7486         costhet2=dcos(theta(i))
7487 C to speed up lets store its mutliplication
7488         sint1t2=sinthet2*sinthet1
7489         sint1t2n=1.0d0
7490 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7491 C +d_n*sin(n*gamma)) *
7492 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7493 C we have two sum 1) Non-Chebyshev which is with n and gamma
7494         nval=nterm_kcc_Tb(itori,itori1)
7495         c1(0)=0.0d0
7496         c2(0)=0.0d0
7497         c1(1)=1.0d0
7498         c2(1)=1.0d0
7499         do j=2,nval
7500           c1(j)=c1(j-1)*costhet1
7501           c2(j)=c2(j-1)*costhet2
7502         enddo
7503         etori=0.0d0
7504         do j=1,nterm_kcc(itori,itori1)
7505           cosphi=dcos(j*phii)
7506           sinphi=dsin(j*phii)
7507           sint1t2n1=sint1t2n
7508           sint1t2n=sint1t2n*sint1t2
7509           sumvalc=0.0d0
7510           gradvalct1=0.0d0
7511           gradvalct2=0.0d0
7512           do k=1,nval
7513             do l=1,nval
7514               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7515               gradvalct1=gradvalct1+
7516      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7517               gradvalct2=gradvalct2+
7518      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7519             enddo
7520           enddo
7521           gradvalct1=-gradvalct1*sinthet1
7522           gradvalct2=-gradvalct2*sinthet2
7523           sumvals=0.0d0
7524           gradvalst1=0.0d0
7525           gradvalst2=0.0d0
7526           do k=1,nval
7527             do l=1,nval
7528               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7529               gradvalst1=gradvalst1+
7530      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7531               gradvalst2=gradvalst2+
7532      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7533             enddo
7534           enddo
7535           gradvalst1=-gradvalst1*sinthet1
7536           gradvalst2=-gradvalst2*sinthet2
7537           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7538           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7539 C glocig is the gradient local i site in gamma
7540           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7541 C now gradient over theta_1
7542           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7543      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7544           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7545      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7546         enddo ! j
7547         etors=etors+etori
7548 C derivative over gamma
7549         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7550 C derivative over theta1
7551         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7552 C now derivative over theta2
7553         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7554         if (lprn) then
7555           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7556      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7557           write (iout,*) "c1",(c1(k),k=0,nval),
7558      &    " c2",(c2(k),k=0,nval)
7559         endif
7560       enddo
7561       return
7562       end
7563 c---------------------------------------------------------------------------------------------
7564       subroutine etor_constr(edihcnstr)
7565       implicit real*8 (a-h,o-z)
7566       include 'DIMENSIONS'
7567       include 'COMMON.VAR'
7568       include 'COMMON.GEO'
7569       include 'COMMON.LOCAL'
7570       include 'COMMON.TORSION'
7571       include 'COMMON.INTERACT'
7572       include 'COMMON.DERIV'
7573       include 'COMMON.CHAIN'
7574       include 'COMMON.NAMES'
7575       include 'COMMON.IOUNITS'
7576       include 'COMMON.FFIELD'
7577       include 'COMMON.TORCNSTR'
7578       include 'COMMON.BOUNDS'
7579       include 'COMMON.CONTROL'
7580 ! 6/20/98 - dihedral angle constraints
7581       edihcnstr=0.0d0
7582 c      do i=1,ndih_constr
7583       if (raw_psipred) then
7584         do i=idihconstr_start,idihconstr_end
7585           itori=idih_constr(i)
7586           phii=phi(itori)
7587           gaudih_i=vpsipred(1,i)
7588           gauder_i=0.0d0
7589           do j=1,2
7590             s = sdihed(j,i)
7591             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7592             dexpcos_i=dexp(-cos_i*cos_i)
7593             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7594             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7595      &            *cos_i*dexpcos_i/s**2
7596           enddo
7597           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7598           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7599           if (energy_dec)
7600      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7601      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7602      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7603      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7604      &     -wdihc*dlog(gaudih_i)
7605         enddo
7606       else
7607
7608       do i=idihconstr_start,idihconstr_end
7609         itori=idih_constr(i)
7610         phii=phi(itori)
7611         difi=pinorm(phii-phi0(i))
7612         if (difi.gt.drange(i)) then
7613           difi=difi-drange(i)
7614           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7615           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7616         else if (difi.lt.-drange(i)) then
7617           difi=difi+drange(i)
7618           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7619           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7620         else
7621           difi=0.0
7622         endif
7623       enddo
7624
7625       endif
7626
7627       return
7628       end
7629 c----------------------------------------------------------------------------
7630 c MODELLER restraint function
7631       subroutine e_modeller(ehomology_constr)
7632       implicit none
7633       include 'DIMENSIONS'
7634
7635       double precision ehomology_constr
7636       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7637       integer katy, odleglosci, test7
7638       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7639       real*8 Eval,Erot
7640       real*8 distance(max_template),distancek(max_template),
7641      &    min_odl,godl(max_template),dih_diff(max_template)
7642
7643 c
7644 c     FP - 30/10/2014 Temporary specifications for homology restraints
7645 c
7646       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7647      &                 sgtheta
7648       double precision, dimension (maxres) :: guscdiff,usc_diff
7649       double precision, dimension (max_template) ::
7650      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7651      &           theta_diff
7652       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7653      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7654      & betai,sum_sgodl,dij
7655       double precision dist,pinorm
7656 c
7657       include 'COMMON.SBRIDGE'
7658       include 'COMMON.CHAIN'
7659       include 'COMMON.GEO'
7660       include 'COMMON.DERIV'
7661       include 'COMMON.LOCAL'
7662       include 'COMMON.INTERACT'
7663       include 'COMMON.VAR'
7664       include 'COMMON.IOUNITS'
7665 c      include 'COMMON.MD'
7666       include 'COMMON.CONTROL'
7667       include 'COMMON.HOMOLOGY'
7668       include 'COMMON.QRESTR'
7669 c
7670 c     From subroutine Econstr_back
7671 c
7672       include 'COMMON.NAMES'
7673       include 'COMMON.TIME1'
7674 c
7675
7676
7677       do i=1,max_template
7678         distancek(i)=9999999.9
7679       enddo
7680
7681
7682       odleg=0.0d0
7683
7684 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7685 c function)
7686 C AL 5/2/14 - Introduce list of restraints
7687 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7688 #ifdef DEBUG
7689       write(iout,*) "------- dist restrs start -------"
7690 #endif
7691       do ii = link_start_homo,link_end_homo
7692          i = ires_homo(ii)
7693          j = jres_homo(ii)
7694          dij=dist(i,j)
7695 c        write (iout,*) "dij(",i,j,") =",dij
7696          nexl=0
7697          do k=1,constr_homology
7698 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7699            if(.not.l_homo(k,ii)) then
7700              nexl=nexl+1
7701              cycle
7702            endif
7703            distance(k)=odl(k,ii)-dij
7704 c          write (iout,*) "distance(",k,") =",distance(k)
7705 c
7706 c          For Gaussian-type Urestr
7707 c
7708            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7709 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7710 c          write (iout,*) "distancek(",k,") =",distancek(k)
7711 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7712 c
7713 c          For Lorentzian-type Urestr
7714 c
7715            if (waga_dist.lt.0.0d0) then
7716               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7717               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7718      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7719            endif
7720          enddo
7721
7722 c         min_odl=minval(distancek)
7723          if (nexl.gt.0) then
7724            min_odl=0.0d0
7725          else
7726            do kk=1,constr_homology
7727             if(l_homo(kk,ii)) then
7728               min_odl=distancek(kk)
7729               exit
7730             endif
7731            enddo
7732            do kk=1,constr_homology
7733             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7734      &              min_odl=distancek(kk)
7735            enddo
7736          endif
7737
7738 c        write (iout,* )"min_odl",min_odl
7739 #ifdef DEBUG
7740          write (iout,*) "ij dij",i,j,dij
7741          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7742          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7743          write (iout,* )"min_odl",min_odl
7744 #endif
7745 #ifdef OLDRESTR
7746          odleg2=0.0d0
7747 #else
7748          if (waga_dist.ge.0.0d0) then
7749            odleg2=nexl
7750          else
7751            odleg2=0.0d0
7752          endif
7753 #endif
7754          do k=1,constr_homology
7755 c Nie wiem po co to liczycie jeszcze raz!
7756 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7757 c     &              (2*(sigma_odl(i,j,k))**2))
7758            if(.not.l_homo(k,ii)) cycle
7759            if (waga_dist.ge.0.0d0) then
7760 c
7761 c          For Gaussian-type Urestr
7762 c
7763             godl(k)=dexp(-distancek(k)+min_odl)
7764             odleg2=odleg2+godl(k)
7765 c
7766 c          For Lorentzian-type Urestr
7767 c
7768            else
7769             odleg2=odleg2+distancek(k)
7770            endif
7771
7772 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7773 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7774 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7775 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7776
7777          enddo
7778 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7779 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7780 #ifdef DEBUG
7781          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7782          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7783 #endif
7784            if (waga_dist.ge.0.0d0) then
7785 c
7786 c          For Gaussian-type Urestr
7787 c
7788               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7789 c
7790 c          For Lorentzian-type Urestr
7791 c
7792            else
7793               odleg=odleg+odleg2/constr_homology
7794            endif
7795 c
7796 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7797 c Gradient
7798 c
7799 c          For Gaussian-type Urestr
7800 c
7801          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7802          sum_sgodl=0.0d0
7803          do k=1,constr_homology
7804 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7805 c     &           *waga_dist)+min_odl
7806 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7807 c
7808          if(.not.l_homo(k,ii)) cycle
7809          if (waga_dist.ge.0.0d0) then
7810 c          For Gaussian-type Urestr
7811 c
7812            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7813 c
7814 c          For Lorentzian-type Urestr
7815 c
7816          else
7817            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7818      &           sigma_odlir(k,ii)**2)**2)
7819          endif
7820            sum_sgodl=sum_sgodl+sgodl
7821
7822 c            sgodl2=sgodl2+sgodl
7823 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7824 c      write(iout,*) "constr_homology=",constr_homology
7825 c      write(iout,*) i, j, k, "TEST K"
7826          enddo
7827          if (waga_dist.ge.0.0d0) then
7828 c
7829 c          For Gaussian-type Urestr
7830 c
7831             grad_odl3=waga_homology(iset)*waga_dist
7832      &                *sum_sgodl/(sum_godl*dij)
7833 c
7834 c          For Lorentzian-type Urestr
7835 c
7836          else
7837 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7838 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7839             grad_odl3=-waga_homology(iset)*waga_dist*
7840      &                sum_sgodl/(constr_homology*dij)
7841          endif
7842 c
7843 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7844
7845
7846 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7847 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7848 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7849
7850 ccc      write(iout,*) godl, sgodl, grad_odl3
7851
7852 c          grad_odl=grad_odl+grad_odl3
7853
7854          do jik=1,3
7855             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7856 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7857 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7858 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7859             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7860             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7861 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7862 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7863 c         if (i.eq.25.and.j.eq.27) then
7864 c         write(iout,*) "jik",jik,"i",i,"j",j
7865 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7866 c         write(iout,*) "grad_odl3",grad_odl3
7867 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7868 c         write(iout,*) "ggodl",ggodl
7869 c         write(iout,*) "ghpbc(",jik,i,")",
7870 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7871 c     &                 ghpbc(jik,j)
7872 c         endif
7873          enddo
7874 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7875 ccc     & dLOG(odleg2),"-odleg=", -odleg
7876
7877       enddo ! ii-loop for dist
7878 #ifdef DEBUG
7879       write(iout,*) "------- dist restrs end -------"
7880 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7881 c    &     waga_d.eq.1.0d0) call sum_gradient
7882 #endif
7883 c Pseudo-energy and gradient from dihedral-angle restraints from
7884 c homology templates
7885 c      write (iout,*) "End of distance loop"
7886 c      call flush(iout)
7887       kat=0.0d0
7888 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7889 #ifdef DEBUG
7890       write(iout,*) "------- dih restrs start -------"
7891       do i=idihconstr_start_homo,idihconstr_end_homo
7892         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7893       enddo
7894 #endif
7895       do i=idihconstr_start_homo,idihconstr_end_homo
7896         kat2=0.0d0
7897 c        betai=beta(i,i+1,i+2,i+3)
7898         betai = phi(i)
7899 c       write (iout,*) "betai =",betai
7900         do k=1,constr_homology
7901           dih_diff(k)=pinorm(dih(k,i)-betai)
7902 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7903 cd     &                  ,sigma_dih(k,i)
7904 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7905 c     &                                   -(6.28318-dih_diff(i,k))
7906 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7907 c     &                                   6.28318+dih_diff(i,k)
7908 #ifdef OLD_DIHED
7909           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7910 #else
7911           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7912 #endif
7913 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7914           gdih(k)=dexp(kat3)
7915           kat2=kat2+gdih(k)
7916 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7917 c          write(*,*)""
7918         enddo
7919 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7920 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7921 #ifdef DEBUG
7922         write (iout,*) "i",i," betai",betai," kat2",kat2
7923         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7924 #endif
7925         if (kat2.le.1.0d-14) cycle
7926         kat=kat-dLOG(kat2/constr_homology)
7927 c       write (iout,*) "kat",kat ! sum of -ln-s
7928
7929 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7930 ccc     & dLOG(kat2), "-kat=", -kat
7931
7932 c ----------------------------------------------------------------------
7933 c Gradient
7934 c ----------------------------------------------------------------------
7935
7936         sum_gdih=kat2
7937         sum_sgdih=0.0d0
7938         do k=1,constr_homology
7939 #ifdef OLD_DIHED
7940           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7941 #else
7942           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7943 #endif
7944 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7945           sum_sgdih=sum_sgdih+sgdih
7946         enddo
7947 c       grad_dih3=sum_sgdih/sum_gdih
7948         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7949
7950 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7951 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7952 ccc     & gloc(nphi+i-3,icg)
7953         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7954 c        if (i.eq.25) then
7955 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7956 c        endif
7957 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7958 ccc     & gloc(nphi+i-3,icg)
7959
7960       enddo ! i-loop for dih
7961 #ifdef DEBUG
7962       write(iout,*) "------- dih restrs end -------"
7963 #endif
7964
7965 c Pseudo-energy and gradient for theta angle restraints from
7966 c homology templates
7967 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7968 c adapted
7969
7970 c
7971 c     For constr_homology reference structures (FP)
7972 c
7973 c     Uconst_back_tot=0.0d0
7974       Eval=0.0d0
7975       Erot=0.0d0
7976 c     Econstr_back legacy
7977       do i=1,nres
7978 c     do i=ithet_start,ithet_end
7979        dutheta(i)=0.0d0
7980 c     enddo
7981 c     do i=loc_start,loc_end
7982         do j=1,3
7983           duscdiff(j,i)=0.0d0
7984           duscdiffx(j,i)=0.0d0
7985         enddo
7986       enddo
7987 c
7988 c     do iref=1,nref
7989 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7990 c     write (iout,*) "waga_theta",waga_theta
7991       if (waga_theta.gt.0.0d0) then
7992 #ifdef DEBUG
7993       write (iout,*) "usampl",usampl
7994       write(iout,*) "------- theta restrs start -------"
7995 c     do i=ithet_start,ithet_end
7996 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7997 c     enddo
7998 #endif
7999 c     write (iout,*) "maxres",maxres,"nres",nres
8000
8001       do i=ithet_start,ithet_end
8002 c
8003 c     do i=1,nfrag_back
8004 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8005 c
8006 c Deviation of theta angles wrt constr_homology ref structures
8007 c
8008         utheta_i=0.0d0 ! argument of Gaussian for single k
8009         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8010 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8011 c       over residues in a fragment
8012 c       write (iout,*) "theta(",i,")=",theta(i)
8013         do k=1,constr_homology
8014 c
8015 c         dtheta_i=theta(j)-thetaref(j,iref)
8016 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8017           theta_diff(k)=thetatpl(k,i)-theta(i)
8018 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8019 cd     &                  ,sigma_theta(k,i)
8020
8021 c
8022           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8023 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8024           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8025           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8026 c         Gradient for single Gaussian restraint in subr Econstr_back
8027 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8028 c
8029         enddo
8030 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8031 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8032
8033 c
8034 c         Gradient for multiple Gaussian restraint
8035         sum_gtheta=gutheta_i
8036         sum_sgtheta=0.0d0
8037         do k=1,constr_homology
8038 c        New generalized expr for multiple Gaussian from Econstr_back
8039          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8040 c
8041 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8042           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8043         enddo
8044 c       Final value of gradient using same var as in Econstr_back
8045         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8046      &      +sum_sgtheta/sum_gtheta*waga_theta
8047      &               *waga_homology(iset)
8048 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8049 c     &               *waga_homology(iset)
8050 c       dutheta(i)=sum_sgtheta/sum_gtheta
8051 c
8052 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8053         Eval=Eval-dLOG(gutheta_i/constr_homology)
8054 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8055 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8056 c       Uconst_back=Uconst_back+utheta(i)
8057       enddo ! (i-loop for theta)
8058 #ifdef DEBUG
8059       write(iout,*) "------- theta restrs end -------"
8060 #endif
8061       endif
8062 c
8063 c Deviation of local SC geometry
8064 c
8065 c Separation of two i-loops (instructed by AL - 11/3/2014)
8066 c
8067 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8068 c     write (iout,*) "waga_d",waga_d
8069
8070 #ifdef DEBUG
8071       write(iout,*) "------- SC restrs start -------"
8072       write (iout,*) "Initial duscdiff,duscdiffx"
8073       do i=loc_start,loc_end
8074         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8075      &                 (duscdiffx(jik,i),jik=1,3)
8076       enddo
8077 #endif
8078       do i=loc_start,loc_end
8079         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8080         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8081 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8082 c       write(iout,*) "xxtab, yytab, zztab"
8083 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8084         do k=1,constr_homology
8085 c
8086           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8087 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8088           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8089           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8090 c         write(iout,*) "dxx, dyy, dzz"
8091 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8092 c
8093           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8094 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8095 c         uscdiffk(k)=usc_diff(i)
8096           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8097 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8098 c     &       " guscdiff2",guscdiff2(k)
8099           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8100 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8101 c     &      xxref(j),yyref(j),zzref(j)
8102         enddo
8103 c
8104 c       Gradient
8105 c
8106 c       Generalized expression for multiple Gaussian acc to that for a single
8107 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8108 c
8109 c       Original implementation
8110 c       sum_guscdiff=guscdiff(i)
8111 c
8112 c       sum_sguscdiff=0.0d0
8113 c       do k=1,constr_homology
8114 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8115 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8116 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8117 c       enddo
8118 c
8119 c       Implementation of new expressions for gradient (Jan. 2015)
8120 c
8121 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8122         do k=1,constr_homology
8123 c
8124 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8125 c       before. Now the drivatives should be correct
8126 c
8127           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8128 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8129           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8130           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8131 c
8132 c         New implementation
8133 c
8134           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8135      &                 sigma_d(k,i) ! for the grad wrt r'
8136 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8137 c
8138 c
8139 c        New implementation
8140          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8141          do jik=1,3
8142             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8143      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8144      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8145             duscdiff(jik,i)=duscdiff(jik,i)+
8146      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8147      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8148             duscdiffx(jik,i)=duscdiffx(jik,i)+
8149      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8150      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8151 c
8152 #ifdef DEBUG
8153              write(iout,*) "jik",jik,"i",i
8154              write(iout,*) "dxx, dyy, dzz"
8155              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8156              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8157 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8158 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8159 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8160 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8161 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8162 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8163 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8164 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8165 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8166 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8167 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8168 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8169 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8170 c            endif
8171 #endif
8172          enddo
8173         enddo
8174 c
8175 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8176 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8177 c
8178 c        write (iout,*) i," uscdiff",uscdiff(i)
8179 c
8180 c Put together deviations from local geometry
8181
8182 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8183 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8184         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8185 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8186 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8187 c       Uconst_back=Uconst_back+usc_diff(i)
8188 c
8189 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8190 c
8191 c     New implment: multiplied by sum_sguscdiff
8192 c
8193
8194       enddo ! (i-loop for dscdiff)
8195
8196 c      endif
8197
8198 #ifdef DEBUG
8199       write(iout,*) "------- SC restrs end -------"
8200         write (iout,*) "------ After SC loop in e_modeller ------"
8201         do i=loc_start,loc_end
8202          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8203          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8204         enddo
8205       if (waga_theta.eq.1.0d0) then
8206       write (iout,*) "in e_modeller after SC restr end: dutheta"
8207       do i=ithet_start,ithet_end
8208         write (iout,*) i,dutheta(i)
8209       enddo
8210       endif
8211       if (waga_d.eq.1.0d0) then
8212       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8213       do i=1,nres
8214         write (iout,*) i,(duscdiff(j,i),j=1,3)
8215         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8216       enddo
8217       endif
8218 #endif
8219
8220 c Total energy from homology restraints
8221 #ifdef DEBUG
8222       write (iout,*) "odleg",odleg," kat",kat
8223 #endif
8224 c
8225 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8226 c
8227 c     ehomology_constr=odleg+kat
8228 c
8229 c     For Lorentzian-type Urestr
8230 c
8231
8232       if (waga_dist.ge.0.0d0) then
8233 c
8234 c          For Gaussian-type Urestr
8235 c
8236         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8237      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8238 c     write (iout,*) "ehomology_constr=",ehomology_constr
8239       else
8240 c
8241 c          For Lorentzian-type Urestr
8242 c
8243         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8244      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8245 c     write (iout,*) "ehomology_constr=",ehomology_constr
8246       endif
8247 #ifdef DEBUG
8248       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8249      & "Eval",waga_theta,eval,
8250      &   "Erot",waga_d,Erot
8251       write (iout,*) "ehomology_constr",ehomology_constr
8252 #endif
8253       return
8254 c
8255 c FP 01/15 end
8256 c
8257   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8258   747 format(a12,i4,i4,i4,f8.3,f8.3)
8259   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8260   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8261   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8262      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8263       end
8264 c----------------------------------------------------------------------------
8265 C The rigorous attempt to derive energy function
8266       subroutine ebend_kcc(etheta)
8267
8268       implicit real*8 (a-h,o-z)
8269       include 'DIMENSIONS'
8270       include 'COMMON.VAR'
8271       include 'COMMON.GEO'
8272       include 'COMMON.LOCAL'
8273       include 'COMMON.TORSION'
8274       include 'COMMON.INTERACT'
8275       include 'COMMON.DERIV'
8276       include 'COMMON.CHAIN'
8277       include 'COMMON.NAMES'
8278       include 'COMMON.IOUNITS'
8279       include 'COMMON.FFIELD'
8280       include 'COMMON.TORCNSTR'
8281       include 'COMMON.CONTROL'
8282       logical lprn
8283       double precision thybt1(maxang_kcc)
8284 C Set lprn=.true. for debugging
8285       lprn=energy_dec
8286 c     lprn=.true.
8287 C      print *,"wchodze kcc"
8288       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8289       etheta=0.0D0
8290       do i=ithet_start,ithet_end
8291 c        print *,i,itype(i-1),itype(i),itype(i-2)
8292         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8293      &  .or.itype(i).eq.ntyp1) cycle
8294         iti=iabs(itortyp(itype(i-1)))
8295         sinthet=dsin(theta(i))
8296         costhet=dcos(theta(i))
8297         do j=1,nbend_kcc_Tb(iti)
8298           thybt1(j)=v1bend_chyb(j,iti)
8299         enddo
8300         sumth1thyb=v1bend_chyb(0,iti)+
8301      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8302         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8303      &    sumth1thyb
8304         ihelp=nbend_kcc_Tb(iti)-1
8305         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8306         etheta=etheta+sumth1thyb
8307 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8308         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8309       enddo
8310       return
8311       end
8312 c-------------------------------------------------------------------------------------
8313       subroutine etheta_constr(ethetacnstr)
8314
8315       implicit real*8 (a-h,o-z)
8316       include 'DIMENSIONS'
8317       include 'COMMON.VAR'
8318       include 'COMMON.GEO'
8319       include 'COMMON.LOCAL'
8320       include 'COMMON.TORSION'
8321       include 'COMMON.INTERACT'
8322       include 'COMMON.DERIV'
8323       include 'COMMON.CHAIN'
8324       include 'COMMON.NAMES'
8325       include 'COMMON.IOUNITS'
8326       include 'COMMON.FFIELD'
8327       include 'COMMON.TORCNSTR'
8328       include 'COMMON.CONTROL'
8329       ethetacnstr=0.0d0
8330 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8331       do i=ithetaconstr_start,ithetaconstr_end
8332         itheta=itheta_constr(i)
8333         thetiii=theta(itheta)
8334         difi=pinorm(thetiii-theta_constr0(i))
8335         if (difi.gt.theta_drange(i)) then
8336           difi=difi-theta_drange(i)
8337           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8338           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8339      &    +for_thet_constr(i)*difi**3
8340         else if (difi.lt.-drange(i)) then
8341           difi=difi+drange(i)
8342           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8343           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8344      &    +for_thet_constr(i)*difi**3
8345         else
8346           difi=0.0
8347         endif
8348        if (energy_dec) then
8349         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8350      &    i,itheta,rad2deg*thetiii,
8351      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8352      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8353      &    gloc(itheta+nphi-2,icg)
8354         endif
8355       enddo
8356       return
8357       end
8358 c------------------------------------------------------------------------------
8359       subroutine eback_sc_corr(esccor)
8360 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8361 c        conformational states; temporarily implemented as differences
8362 c        between UNRES torsional potentials (dependent on three types of
8363 c        residues) and the torsional potentials dependent on all 20 types
8364 c        of residues computed from AM1  energy surfaces of terminally-blocked
8365 c        amino-acid residues.
8366       implicit real*8 (a-h,o-z)
8367       include 'DIMENSIONS'
8368       include 'COMMON.VAR'
8369       include 'COMMON.GEO'
8370       include 'COMMON.LOCAL'
8371       include 'COMMON.TORSION'
8372       include 'COMMON.SCCOR'
8373       include 'COMMON.INTERACT'
8374       include 'COMMON.DERIV'
8375       include 'COMMON.CHAIN'
8376       include 'COMMON.NAMES'
8377       include 'COMMON.IOUNITS'
8378       include 'COMMON.FFIELD'
8379       include 'COMMON.CONTROL'
8380       logical lprn
8381 C Set lprn=.true. for debugging
8382       lprn=.false.
8383 c      lprn=.true.
8384 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8385       esccor=0.0D0
8386       do i=itau_start,itau_end
8387         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8388         esccor_ii=0.0D0
8389         isccori=isccortyp(itype(i-2))
8390         isccori1=isccortyp(itype(i-1))
8391 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8392         phii=phi(i)
8393         do intertyp=1,3 !intertyp
8394 cc Added 09 May 2012 (Adasko)
8395 cc  Intertyp means interaction type of backbone mainchain correlation:
8396 c   1 = SC...Ca...Ca...Ca
8397 c   2 = Ca...Ca...Ca...SC
8398 c   3 = SC...Ca...Ca...SCi
8399         gloci=0.0D0
8400         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8401      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8402      &      (itype(i-1).eq.ntyp1)))
8403      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8404      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8405      &     .or.(itype(i).eq.ntyp1)))
8406      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8407      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8408      &      (itype(i-3).eq.ntyp1)))) cycle
8409         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8410         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8411      & cycle
8412        do j=1,nterm_sccor(isccori,isccori1)
8413           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8414           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8415           cosphi=dcos(j*tauangle(intertyp,i))
8416           sinphi=dsin(j*tauangle(intertyp,i))
8417           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8418           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8419         enddo
8420 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8421         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8422         if (lprn)
8423      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8424      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8425      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8426      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8427         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8428        enddo !intertyp
8429       enddo
8430
8431       return
8432       end
8433 #ifdef FOURBODY
8434 c----------------------------------------------------------------------------
8435       subroutine multibody(ecorr)
8436 C This subroutine calculates multi-body contributions to energy following
8437 C the idea of Skolnick et al. If side chains I and J make a contact and
8438 C at the same time side chains I+1 and J+1 make a contact, an extra
8439 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8440       implicit real*8 (a-h,o-z)
8441       include 'DIMENSIONS'
8442       include 'COMMON.IOUNITS'
8443       include 'COMMON.DERIV'
8444       include 'COMMON.INTERACT'
8445       include 'COMMON.CONTACTS'
8446       include 'COMMON.CONTMAT'
8447       include 'COMMON.CORRMAT'
8448       double precision gx(3),gx1(3)
8449       logical lprn
8450
8451 C Set lprn=.true. for debugging
8452       lprn=.false.
8453
8454       if (lprn) then
8455         write (iout,'(a)') 'Contact function values:'
8456         do i=nnt,nct-2
8457           write (iout,'(i2,20(1x,i2,f10.5))')
8458      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8459         enddo
8460       endif
8461       ecorr=0.0D0
8462       do i=nnt,nct
8463         do j=1,3
8464           gradcorr(j,i)=0.0D0
8465           gradxorr(j,i)=0.0D0
8466         enddo
8467       enddo
8468       do i=nnt,nct-2
8469
8470         DO ISHIFT = 3,4
8471
8472         i1=i+ishift
8473         num_conti=num_cont(i)
8474         num_conti1=num_cont(i1)
8475         do jj=1,num_conti
8476           j=jcont(jj,i)
8477           do kk=1,num_conti1
8478             j1=jcont(kk,i1)
8479             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8480 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8481 cd   &                   ' ishift=',ishift
8482 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8483 C The system gains extra energy.
8484               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8485             endif   ! j1==j+-ishift
8486           enddo     ! kk
8487         enddo       ! jj
8488
8489         ENDDO ! ISHIFT
8490
8491       enddo         ! i
8492       return
8493       end
8494 c------------------------------------------------------------------------------
8495       double precision function esccorr(i,j,k,l,jj,kk)
8496       implicit real*8 (a-h,o-z)
8497       include 'DIMENSIONS'
8498       include 'COMMON.IOUNITS'
8499       include 'COMMON.DERIV'
8500       include 'COMMON.INTERACT'
8501       include 'COMMON.CONTACTS'
8502       include 'COMMON.CONTMAT'
8503       include 'COMMON.CORRMAT'
8504       include 'COMMON.SHIELD'
8505       double precision gx(3),gx1(3)
8506       logical lprn
8507       lprn=.false.
8508       eij=facont(jj,i)
8509       ekl=facont(kk,k)
8510 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8511 C Calculate the multi-body contribution to energy.
8512 C Calculate multi-body contributions to the gradient.
8513 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8514 cd   & k,l,(gacont(m,kk,k),m=1,3)
8515       do m=1,3
8516         gx(m) =ekl*gacont(m,jj,i)
8517         gx1(m)=eij*gacont(m,kk,k)
8518         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8519         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8520         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8521         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8522       enddo
8523       do m=i,j-1
8524         do ll=1,3
8525           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8526         enddo
8527       enddo
8528       do m=k,l-1
8529         do ll=1,3
8530           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8531         enddo
8532       enddo
8533       esccorr=-eij*ekl
8534       return
8535       end
8536 c------------------------------------------------------------------------------
8537       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8538 C This subroutine calculates multi-body contributions to hydrogen-bonding
8539       implicit real*8 (a-h,o-z)
8540       include 'DIMENSIONS'
8541       include 'COMMON.IOUNITS'
8542 #ifdef MPI
8543       include "mpif.h"
8544       parameter (max_cont=maxconts)
8545       parameter (max_dim=26)
8546       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8547       double precision zapas(max_dim,maxconts,max_fg_procs),
8548      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8549       common /przechowalnia/ zapas
8550       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8551      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8552 #endif
8553       include 'COMMON.SETUP'
8554       include 'COMMON.FFIELD'
8555       include 'COMMON.DERIV'
8556       include 'COMMON.INTERACT'
8557       include 'COMMON.CONTACTS'
8558       include 'COMMON.CONTMAT'
8559       include 'COMMON.CORRMAT'
8560       include 'COMMON.CONTROL'
8561       include 'COMMON.LOCAL'
8562       double precision gx(3),gx1(3),time00
8563       logical lprn,ldone
8564
8565 C Set lprn=.true. for debugging
8566       lprn=.false.
8567 #ifdef MPI
8568       n_corr=0
8569       n_corr1=0
8570       if (nfgtasks.le.1) goto 30
8571       if (lprn) then
8572         write (iout,'(a)') 'Contact function values before RECEIVE:'
8573         do i=nnt,nct-2
8574           write (iout,'(2i3,50(1x,i2,f5.2))')
8575      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8576      &    j=1,num_cont_hb(i))
8577         enddo
8578         call flush(iout)
8579       endif
8580       do i=1,ntask_cont_from
8581         ncont_recv(i)=0
8582       enddo
8583       do i=1,ntask_cont_to
8584         ncont_sent(i)=0
8585       enddo
8586 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8587 c     & ntask_cont_to
8588 C Make the list of contacts to send to send to other procesors
8589 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8590 c      call flush(iout)
8591       do i=iturn3_start,iturn3_end
8592 c        write (iout,*) "make contact list turn3",i," num_cont",
8593 c     &    num_cont_hb(i)
8594         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8595       enddo
8596       do i=iturn4_start,iturn4_end
8597 c        write (iout,*) "make contact list turn4",i," num_cont",
8598 c     &   num_cont_hb(i)
8599         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8600       enddo
8601       do ii=1,nat_sent
8602         i=iat_sent(ii)
8603 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8604 c     &    num_cont_hb(i)
8605         do j=1,num_cont_hb(i)
8606         do k=1,4
8607           jjc=jcont_hb(j,i)
8608           iproc=iint_sent_local(k,jjc,ii)
8609 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8610           if (iproc.gt.0) then
8611             ncont_sent(iproc)=ncont_sent(iproc)+1
8612             nn=ncont_sent(iproc)
8613             zapas(1,nn,iproc)=i
8614             zapas(2,nn,iproc)=jjc
8615             zapas(3,nn,iproc)=facont_hb(j,i)
8616             zapas(4,nn,iproc)=ees0p(j,i)
8617             zapas(5,nn,iproc)=ees0m(j,i)
8618             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8619             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8620             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8621             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8622             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8623             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8624             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8625             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8626             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8627             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8628             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8629             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8630             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8631             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8632             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8633             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8634             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8635             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8636             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8637             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8638             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8639           endif
8640         enddo
8641         enddo
8642       enddo
8643       if (lprn) then
8644       write (iout,*)
8645      &  "Numbers of contacts to be sent to other processors",
8646      &  (ncont_sent(i),i=1,ntask_cont_to)
8647       write (iout,*) "Contacts sent"
8648       do ii=1,ntask_cont_to
8649         nn=ncont_sent(ii)
8650         iproc=itask_cont_to(ii)
8651         write (iout,*) nn," contacts to processor",iproc,
8652      &   " of CONT_TO_COMM group"
8653         do i=1,nn
8654           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8655         enddo
8656       enddo
8657       call flush(iout)
8658       endif
8659       CorrelType=477
8660       CorrelID=fg_rank+1
8661       CorrelType1=478
8662       CorrelID1=nfgtasks+fg_rank+1
8663       ireq=0
8664 C Receive the numbers of needed contacts from other processors
8665       do ii=1,ntask_cont_from
8666         iproc=itask_cont_from(ii)
8667         ireq=ireq+1
8668         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8669      &    FG_COMM,req(ireq),IERR)
8670       enddo
8671 c      write (iout,*) "IRECV ended"
8672 c      call flush(iout)
8673 C Send the number of contacts needed by other processors
8674       do ii=1,ntask_cont_to
8675         iproc=itask_cont_to(ii)
8676         ireq=ireq+1
8677         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8678      &    FG_COMM,req(ireq),IERR)
8679       enddo
8680 c      write (iout,*) "ISEND ended"
8681 c      write (iout,*) "number of requests (nn)",ireq
8682 c      call flush(iout)
8683       if (ireq.gt.0)
8684      &  call MPI_Waitall(ireq,req,status_array,ierr)
8685 c      write (iout,*)
8686 c     &  "Numbers of contacts to be received from other processors",
8687 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8688 c      call flush(iout)
8689 C Receive contacts
8690       ireq=0
8691       do ii=1,ntask_cont_from
8692         iproc=itask_cont_from(ii)
8693         nn=ncont_recv(ii)
8694 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8695 c     &   " of CONT_TO_COMM group"
8696 c        call flush(iout)
8697         if (nn.gt.0) then
8698           ireq=ireq+1
8699           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8700      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8701 c          write (iout,*) "ireq,req",ireq,req(ireq)
8702         endif
8703       enddo
8704 C Send the contacts to processors that need them
8705       do ii=1,ntask_cont_to
8706         iproc=itask_cont_to(ii)
8707         nn=ncont_sent(ii)
8708 c        write (iout,*) nn," contacts to processor",iproc,
8709 c     &   " of CONT_TO_COMM group"
8710         if (nn.gt.0) then
8711           ireq=ireq+1
8712           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8713      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8714 c          write (iout,*) "ireq,req",ireq,req(ireq)
8715 c          do i=1,nn
8716 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8717 c          enddo
8718         endif
8719       enddo
8720 c      write (iout,*) "number of requests (contacts)",ireq
8721 c      write (iout,*) "req",(req(i),i=1,4)
8722 c      call flush(iout)
8723       if (ireq.gt.0)
8724      & call MPI_Waitall(ireq,req,status_array,ierr)
8725       do iii=1,ntask_cont_from
8726         iproc=itask_cont_from(iii)
8727         nn=ncont_recv(iii)
8728         if (lprn) then
8729         write (iout,*) "Received",nn," contacts from processor",iproc,
8730      &   " of CONT_FROM_COMM group"
8731         call flush(iout)
8732         do i=1,nn
8733           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8734         enddo
8735         call flush(iout)
8736         endif
8737         do i=1,nn
8738           ii=zapas_recv(1,i,iii)
8739 c Flag the received contacts to prevent double-counting
8740           jj=-zapas_recv(2,i,iii)
8741 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8742 c          call flush(iout)
8743           nnn=num_cont_hb(ii)+1
8744           num_cont_hb(ii)=nnn
8745           jcont_hb(nnn,ii)=jj
8746           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8747           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8748           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8749           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8750           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8751           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8752           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8753           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8754           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8755           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8756           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8757           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8758           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8759           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8760           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8761           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8762           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8763           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8764           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8765           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8766           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8767           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8768           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8769           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8770         enddo
8771       enddo
8772       if (lprn) then
8773         write (iout,'(a)') 'Contact function values after receive:'
8774         do i=nnt,nct-2
8775           write (iout,'(2i3,50(1x,i3,f5.2))')
8776      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8777      &    j=1,num_cont_hb(i))
8778         enddo
8779         call flush(iout)
8780       endif
8781    30 continue
8782 #endif
8783       if (lprn) then
8784         write (iout,'(a)') 'Contact function values:'
8785         do i=nnt,nct-2
8786           write (iout,'(2i3,50(1x,i3,f5.2))')
8787      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8788      &    j=1,num_cont_hb(i))
8789         enddo
8790         call flush(iout)
8791       endif
8792       ecorr=0.0D0
8793 C Remove the loop below after debugging !!!
8794       do i=nnt,nct
8795         do j=1,3
8796           gradcorr(j,i)=0.0D0
8797           gradxorr(j,i)=0.0D0
8798         enddo
8799       enddo
8800 C Calculate the local-electrostatic correlation terms
8801       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8802         i1=i+1
8803         num_conti=num_cont_hb(i)
8804         num_conti1=num_cont_hb(i+1)
8805         do jj=1,num_conti
8806           j=jcont_hb(jj,i)
8807           jp=iabs(j)
8808           do kk=1,num_conti1
8809             j1=jcont_hb(kk,i1)
8810             jp1=iabs(j1)
8811 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8812 c     &         ' jj=',jj,' kk=',kk
8813 c            call flush(iout)
8814             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8815      &          .or. j.lt.0 .and. j1.gt.0) .and.
8816      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8817 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8818 C The system gains extra energy.
8819               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8820               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8821      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8822               n_corr=n_corr+1
8823             else if (j1.eq.j) then
8824 C Contacts I-J and I-(J+1) occur simultaneously.
8825 C The system loses extra energy.
8826 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8827             endif
8828           enddo ! kk
8829           do kk=1,num_conti
8830             j1=jcont_hb(kk,i)
8831 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8832 c    &         ' jj=',jj,' kk=',kk
8833             if (j1.eq.j+1) then
8834 C Contacts I-J and (I+1)-J occur simultaneously.
8835 C The system loses extra energy.
8836 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8837             endif ! j1==j+1
8838           enddo ! kk
8839         enddo ! jj
8840       enddo ! i
8841       return
8842       end
8843 c------------------------------------------------------------------------------
8844       subroutine add_hb_contact(ii,jj,itask)
8845       implicit real*8 (a-h,o-z)
8846       include "DIMENSIONS"
8847       include "COMMON.IOUNITS"
8848       integer max_cont
8849       integer max_dim
8850       parameter (max_cont=maxconts)
8851       parameter (max_dim=26)
8852       include "COMMON.CONTACTS"
8853       include 'COMMON.CONTMAT'
8854       include 'COMMON.CORRMAT'
8855       double precision zapas(max_dim,maxconts,max_fg_procs),
8856      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8857       common /przechowalnia/ zapas
8858       integer i,j,ii,jj,iproc,itask(4),nn
8859 c      write (iout,*) "itask",itask
8860       do i=1,2
8861         iproc=itask(i)
8862         if (iproc.gt.0) then
8863           do j=1,num_cont_hb(ii)
8864             jjc=jcont_hb(j,ii)
8865 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8866             if (jjc.eq.jj) then
8867               ncont_sent(iproc)=ncont_sent(iproc)+1
8868               nn=ncont_sent(iproc)
8869               zapas(1,nn,iproc)=ii
8870               zapas(2,nn,iproc)=jjc
8871               zapas(3,nn,iproc)=facont_hb(j,ii)
8872               zapas(4,nn,iproc)=ees0p(j,ii)
8873               zapas(5,nn,iproc)=ees0m(j,ii)
8874               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8875               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8876               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8877               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8878               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8879               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8880               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8881               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8882               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8883               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8884               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8885               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8886               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8887               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8888               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8889               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8890               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8891               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8892               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8893               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8894               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8895               exit
8896             endif
8897           enddo
8898         endif
8899       enddo
8900       return
8901       end
8902 c------------------------------------------------------------------------------
8903       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8904      &  n_corr1)
8905 C This subroutine calculates multi-body contributions to hydrogen-bonding
8906       implicit real*8 (a-h,o-z)
8907       include 'DIMENSIONS'
8908       include 'COMMON.IOUNITS'
8909 #ifdef MPI
8910       include "mpif.h"
8911       parameter (max_cont=maxconts)
8912       parameter (max_dim=70)
8913       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8914       double precision zapas(max_dim,maxconts,max_fg_procs),
8915      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8916       common /przechowalnia/ zapas
8917       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8918      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8919 #endif
8920       include 'COMMON.SETUP'
8921       include 'COMMON.FFIELD'
8922       include 'COMMON.DERIV'
8923       include 'COMMON.LOCAL'
8924       include 'COMMON.INTERACT'
8925       include 'COMMON.CONTACTS'
8926       include 'COMMON.CONTMAT'
8927       include 'COMMON.CORRMAT'
8928       include 'COMMON.CHAIN'
8929       include 'COMMON.CONTROL'
8930       include 'COMMON.SHIELD'
8931       double precision gx(3),gx1(3)
8932       integer num_cont_hb_old(maxres)
8933       logical lprn,ldone
8934       double precision eello4,eello5,eelo6,eello_turn6
8935       external eello4,eello5,eello6,eello_turn6
8936 C Set lprn=.true. for debugging
8937       lprn=.false.
8938       eturn6=0.0d0
8939 #ifdef MPI
8940       do i=1,nres
8941         num_cont_hb_old(i)=num_cont_hb(i)
8942       enddo
8943       n_corr=0
8944       n_corr1=0
8945       if (nfgtasks.le.1) goto 30
8946       if (lprn) then
8947         write (iout,'(a)') 'Contact function values before RECEIVE:'
8948         do i=nnt,nct-2
8949           write (iout,'(2i3,50(1x,i2,f5.2))')
8950      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8951      &    j=1,num_cont_hb(i))
8952         enddo
8953       endif
8954       do i=1,ntask_cont_from
8955         ncont_recv(i)=0
8956       enddo
8957       do i=1,ntask_cont_to
8958         ncont_sent(i)=0
8959       enddo
8960 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8961 c     & ntask_cont_to
8962 C Make the list of contacts to send to send to other procesors
8963       do i=iturn3_start,iturn3_end
8964 c        write (iout,*) "make contact list turn3",i," num_cont",
8965 c     &    num_cont_hb(i)
8966         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8967       enddo
8968       do i=iturn4_start,iturn4_end
8969 c        write (iout,*) "make contact list turn4",i," num_cont",
8970 c     &   num_cont_hb(i)
8971         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8972       enddo
8973       do ii=1,nat_sent
8974         i=iat_sent(ii)
8975 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8976 c     &    num_cont_hb(i)
8977         do j=1,num_cont_hb(i)
8978         do k=1,4
8979           jjc=jcont_hb(j,i)
8980           iproc=iint_sent_local(k,jjc,ii)
8981 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8982           if (iproc.ne.0) then
8983             ncont_sent(iproc)=ncont_sent(iproc)+1
8984             nn=ncont_sent(iproc)
8985             zapas(1,nn,iproc)=i
8986             zapas(2,nn,iproc)=jjc
8987             zapas(3,nn,iproc)=d_cont(j,i)
8988             ind=3
8989             do kk=1,3
8990               ind=ind+1
8991               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8992             enddo
8993             do kk=1,2
8994               do ll=1,2
8995                 ind=ind+1
8996                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8997               enddo
8998             enddo
8999             do jj=1,5
9000               do kk=1,3
9001                 do ll=1,2
9002                   do mm=1,2
9003                     ind=ind+1
9004                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9005                   enddo
9006                 enddo
9007               enddo
9008             enddo
9009           endif
9010         enddo
9011         enddo
9012       enddo
9013       if (lprn) then
9014       write (iout,*)
9015      &  "Numbers of contacts to be sent to other processors",
9016      &  (ncont_sent(i),i=1,ntask_cont_to)
9017       write (iout,*) "Contacts sent"
9018       do ii=1,ntask_cont_to
9019         nn=ncont_sent(ii)
9020         iproc=itask_cont_to(ii)
9021         write (iout,*) nn," contacts to processor",iproc,
9022      &   " of CONT_TO_COMM group"
9023         do i=1,nn
9024           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9025         enddo
9026       enddo
9027       call flush(iout)
9028       endif
9029       CorrelType=477
9030       CorrelID=fg_rank+1
9031       CorrelType1=478
9032       CorrelID1=nfgtasks+fg_rank+1
9033       ireq=0
9034 C Receive the numbers of needed contacts from other processors
9035       do ii=1,ntask_cont_from
9036         iproc=itask_cont_from(ii)
9037         ireq=ireq+1
9038         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9039      &    FG_COMM,req(ireq),IERR)
9040       enddo
9041 c      write (iout,*) "IRECV ended"
9042 c      call flush(iout)
9043 C Send the number of contacts needed by other processors
9044       do ii=1,ntask_cont_to
9045         iproc=itask_cont_to(ii)
9046         ireq=ireq+1
9047         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9048      &    FG_COMM,req(ireq),IERR)
9049       enddo
9050 c      write (iout,*) "ISEND ended"
9051 c      write (iout,*) "number of requests (nn)",ireq
9052 c      call flush(iout)
9053       if (ireq.gt.0)
9054      &  call MPI_Waitall(ireq,req,status_array,ierr)
9055 c      write (iout,*)
9056 c     &  "Numbers of contacts to be received from other processors",
9057 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9058 c      call flush(iout)
9059 C Receive contacts
9060       ireq=0
9061       do ii=1,ntask_cont_from
9062         iproc=itask_cont_from(ii)
9063         nn=ncont_recv(ii)
9064 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9065 c     &   " of CONT_TO_COMM group"
9066 c        call flush(iout)
9067         if (nn.gt.0) then
9068           ireq=ireq+1
9069           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9070      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9071 c          write (iout,*) "ireq,req",ireq,req(ireq)
9072         endif
9073       enddo
9074 C Send the contacts to processors that need them
9075       do ii=1,ntask_cont_to
9076         iproc=itask_cont_to(ii)
9077         nn=ncont_sent(ii)
9078 c        write (iout,*) nn," contacts to processor",iproc,
9079 c     &   " of CONT_TO_COMM group"
9080         if (nn.gt.0) then
9081           ireq=ireq+1
9082           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9083      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9084 c          write (iout,*) "ireq,req",ireq,req(ireq)
9085 c          do i=1,nn
9086 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9087 c          enddo
9088         endif
9089       enddo
9090 c      write (iout,*) "number of requests (contacts)",ireq
9091 c      write (iout,*) "req",(req(i),i=1,4)
9092 c      call flush(iout)
9093       if (ireq.gt.0)
9094      & call MPI_Waitall(ireq,req,status_array,ierr)
9095       do iii=1,ntask_cont_from
9096         iproc=itask_cont_from(iii)
9097         nn=ncont_recv(iii)
9098         if (lprn) then
9099         write (iout,*) "Received",nn," contacts from processor",iproc,
9100      &   " of CONT_FROM_COMM group"
9101         call flush(iout)
9102         do i=1,nn
9103           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9104         enddo
9105         call flush(iout)
9106         endif
9107         do i=1,nn
9108           ii=zapas_recv(1,i,iii)
9109 c Flag the received contacts to prevent double-counting
9110           jj=-zapas_recv(2,i,iii)
9111 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9112 c          call flush(iout)
9113           nnn=num_cont_hb(ii)+1
9114           num_cont_hb(ii)=nnn
9115           jcont_hb(nnn,ii)=jj
9116           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9117           ind=3
9118           do kk=1,3
9119             ind=ind+1
9120             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9121           enddo
9122           do kk=1,2
9123             do ll=1,2
9124               ind=ind+1
9125               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9126             enddo
9127           enddo
9128           do jj=1,5
9129             do kk=1,3
9130               do ll=1,2
9131                 do mm=1,2
9132                   ind=ind+1
9133                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9134                 enddo
9135               enddo
9136             enddo
9137           enddo
9138         enddo
9139       enddo
9140       if (lprn) then
9141         write (iout,'(a)') 'Contact function values after receive:'
9142         do i=nnt,nct-2
9143           write (iout,'(2i3,50(1x,i3,5f6.3))')
9144      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9145      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9146         enddo
9147         call flush(iout)
9148       endif
9149    30 continue
9150 #endif
9151       if (lprn) then
9152         write (iout,'(a)') 'Contact function values:'
9153         do i=nnt,nct-2
9154           write (iout,'(2i3,50(1x,i2,5f6.3))')
9155      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9156      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9157         enddo
9158       endif
9159       ecorr=0.0D0
9160       ecorr5=0.0d0
9161       ecorr6=0.0d0
9162 C Remove the loop below after debugging !!!
9163       do i=nnt,nct
9164         do j=1,3
9165           gradcorr(j,i)=0.0D0
9166           gradxorr(j,i)=0.0D0
9167         enddo
9168       enddo
9169 C Calculate the dipole-dipole interaction energies
9170       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9171       do i=iatel_s,iatel_e+1
9172         num_conti=num_cont_hb(i)
9173         do jj=1,num_conti
9174           j=jcont_hb(jj,i)
9175 #ifdef MOMENT
9176           call dipole(i,j,jj)
9177 #endif
9178         enddo
9179       enddo
9180       endif
9181 C Calculate the local-electrostatic correlation terms
9182 c                write (iout,*) "gradcorr5 in eello5 before loop"
9183 c                do iii=1,nres
9184 c                  write (iout,'(i5,3f10.5)')
9185 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9186 c                enddo
9187       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9188 c        write (iout,*) "corr loop i",i
9189         i1=i+1
9190         num_conti=num_cont_hb(i)
9191         num_conti1=num_cont_hb(i+1)
9192         do jj=1,num_conti
9193           j=jcont_hb(jj,i)
9194           jp=iabs(j)
9195           do kk=1,num_conti1
9196             j1=jcont_hb(kk,i1)
9197             jp1=iabs(j1)
9198 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9199 c     &         ' jj=',jj,' kk=',kk
9200 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9201             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9202      &          .or. j.lt.0 .and. j1.gt.0) .and.
9203      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9204 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9205 C The system gains extra energy.
9206               n_corr=n_corr+1
9207               sqd1=dsqrt(d_cont(jj,i))
9208               sqd2=dsqrt(d_cont(kk,i1))
9209               sred_geom = sqd1*sqd2
9210               IF (sred_geom.lt.cutoff_corr) THEN
9211                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9212      &            ekont,fprimcont)
9213 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9214 cd     &         ' jj=',jj,' kk=',kk
9215                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9216                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9217                 do l=1,3
9218                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9219                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9220                 enddo
9221                 n_corr1=n_corr1+1
9222 cd               write (iout,*) 'sred_geom=',sred_geom,
9223 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9224 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9225 cd               write (iout,*) "g_contij",g_contij
9226 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9227 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9228                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9229                 if (wcorr4.gt.0.0d0)
9230      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9231 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9232                   if (energy_dec.and.wcorr4.gt.0.0d0)
9233      1                 write (iout,'(a6,4i5,0pf7.3)')
9234      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9235 c                write (iout,*) "gradcorr5 before eello5"
9236 c                do iii=1,nres
9237 c                  write (iout,'(i5,3f10.5)')
9238 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9239 c                enddo
9240                 if (wcorr5.gt.0.0d0)
9241      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9242 c                write (iout,*) "gradcorr5 after eello5"
9243 c                do iii=1,nres
9244 c                  write (iout,'(i5,3f10.5)')
9245 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9246 c                enddo
9247                   if (energy_dec.and.wcorr5.gt.0.0d0)
9248      1                 write (iout,'(a6,4i5,0pf7.3)')
9249      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9250 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9251 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9252                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9253      &               .or. wturn6.eq.0.0d0))then
9254 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9255                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9256                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9257      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9258 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9259 cd     &            'ecorr6=',ecorr6
9260 cd                write (iout,'(4e15.5)') sred_geom,
9261 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9262 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9263 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9264                 else if (wturn6.gt.0.0d0
9265      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9266 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9267                   eturn6=eturn6+eello_turn6(i,jj,kk)
9268                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9269      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9270 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9271                 endif
9272               ENDIF
9273 1111          continue
9274             endif
9275           enddo ! kk
9276         enddo ! jj
9277       enddo ! i
9278       do i=1,nres
9279         num_cont_hb(i)=num_cont_hb_old(i)
9280       enddo
9281 c                write (iout,*) "gradcorr5 in eello5"
9282 c                do iii=1,nres
9283 c                  write (iout,'(i5,3f10.5)')
9284 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9285 c                enddo
9286       return
9287       end
9288 c------------------------------------------------------------------------------
9289       subroutine add_hb_contact_eello(ii,jj,itask)
9290       implicit real*8 (a-h,o-z)
9291       include "DIMENSIONS"
9292       include "COMMON.IOUNITS"
9293       integer max_cont
9294       integer max_dim
9295       parameter (max_cont=maxconts)
9296       parameter (max_dim=70)
9297       include "COMMON.CONTACTS"
9298       include 'COMMON.CONTMAT'
9299       include 'COMMON.CORRMAT'
9300       double precision zapas(max_dim,maxconts,max_fg_procs),
9301      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9302       common /przechowalnia/ zapas
9303       integer i,j,ii,jj,iproc,itask(4),nn
9304 c      write (iout,*) "itask",itask
9305       do i=1,2
9306         iproc=itask(i)
9307         if (iproc.gt.0) then
9308           do j=1,num_cont_hb(ii)
9309             jjc=jcont_hb(j,ii)
9310 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9311             if (jjc.eq.jj) then
9312               ncont_sent(iproc)=ncont_sent(iproc)+1
9313               nn=ncont_sent(iproc)
9314               zapas(1,nn,iproc)=ii
9315               zapas(2,nn,iproc)=jjc
9316               zapas(3,nn,iproc)=d_cont(j,ii)
9317               ind=3
9318               do kk=1,3
9319                 ind=ind+1
9320                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9321               enddo
9322               do kk=1,2
9323                 do ll=1,2
9324                   ind=ind+1
9325                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9326                 enddo
9327               enddo
9328               do jj=1,5
9329                 do kk=1,3
9330                   do ll=1,2
9331                     do mm=1,2
9332                       ind=ind+1
9333                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9334                     enddo
9335                   enddo
9336                 enddo
9337               enddo
9338               exit
9339             endif
9340           enddo
9341         endif
9342       enddo
9343       return
9344       end
9345 c------------------------------------------------------------------------------
9346       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9347       implicit real*8 (a-h,o-z)
9348       include 'DIMENSIONS'
9349       include 'COMMON.IOUNITS'
9350       include 'COMMON.DERIV'
9351       include 'COMMON.INTERACT'
9352       include 'COMMON.CONTACTS'
9353       include 'COMMON.CONTMAT'
9354       include 'COMMON.CORRMAT'
9355       include 'COMMON.SHIELD'
9356       include 'COMMON.CONTROL'
9357       double precision gx(3),gx1(3)
9358       logical lprn
9359       lprn=.false.
9360 C      print *,"wchodze",fac_shield(i),shield_mode
9361       eij=facont_hb(jj,i)
9362       ekl=facont_hb(kk,k)
9363       ees0pij=ees0p(jj,i)
9364       ees0pkl=ees0p(kk,k)
9365       ees0mij=ees0m(jj,i)
9366       ees0mkl=ees0m(kk,k)
9367       ekont=eij*ekl
9368       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9369 C*
9370 C     & fac_shield(i)**2*fac_shield(j)**2
9371 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9372 C Following 4 lines for diagnostics.
9373 cd    ees0pkl=0.0D0
9374 cd    ees0pij=1.0D0
9375 cd    ees0mkl=0.0D0
9376 cd    ees0mij=1.0D0
9377 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9378 c     & 'Contacts ',i,j,
9379 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9380 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9381 c     & 'gradcorr_long'
9382 C Calculate the multi-body contribution to energy.
9383 C      ecorr=ecorr+ekont*ees
9384 C Calculate multi-body contributions to the gradient.
9385       coeffpees0pij=coeffp*ees0pij
9386       coeffmees0mij=coeffm*ees0mij
9387       coeffpees0pkl=coeffp*ees0pkl
9388       coeffmees0mkl=coeffm*ees0mkl
9389       do ll=1,3
9390 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9391         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9392      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9393      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9394         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9395      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9396      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9397 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9398         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9399      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9400      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9401         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9402      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9403      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9404         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9405      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9406      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9407         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9408         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9409         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9410      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9411      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9412         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9413         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9414 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9415       enddo
9416 c      write (iout,*)
9417 cgrad      do m=i+1,j-1
9418 cgrad        do ll=1,3
9419 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9420 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9421 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9422 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9423 cgrad        enddo
9424 cgrad      enddo
9425 cgrad      do m=k+1,l-1
9426 cgrad        do ll=1,3
9427 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9428 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9429 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9430 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9431 cgrad        enddo
9432 cgrad      enddo
9433 c      write (iout,*) "ehbcorr",ekont*ees
9434 C      print *,ekont,ees,i,k
9435       ehbcorr=ekont*ees
9436 C now gradient over shielding
9437 C      return
9438       if (shield_mode.gt.0) then
9439        j=ees0plist(jj,i)
9440        l=ees0plist(kk,k)
9441 C        print *,i,j,fac_shield(i),fac_shield(j),
9442 C     &fac_shield(k),fac_shield(l)
9443         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9444      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9445           do ilist=1,ishield_list(i)
9446            iresshield=shield_list(ilist,i)
9447            do m=1,3
9448            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9449 C     &      *2.0
9450            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9451      &              rlocshield
9452      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9453             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9454      &+rlocshield
9455            enddo
9456           enddo
9457           do ilist=1,ishield_list(j)
9458            iresshield=shield_list(ilist,j)
9459            do m=1,3
9460            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9461 C     &     *2.0
9462            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9463      &              rlocshield
9464      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9465            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9466      &     +rlocshield
9467            enddo
9468           enddo
9469
9470           do ilist=1,ishield_list(k)
9471            iresshield=shield_list(ilist,k)
9472            do m=1,3
9473            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9474 C     &     *2.0
9475            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9476      &              rlocshield
9477      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9478            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9479      &     +rlocshield
9480            enddo
9481           enddo
9482           do ilist=1,ishield_list(l)
9483            iresshield=shield_list(ilist,l)
9484            do m=1,3
9485            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9486 C     &     *2.0
9487            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9488      &              rlocshield
9489      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9490            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9491      &     +rlocshield
9492            enddo
9493           enddo
9494 C          print *,gshieldx(m,iresshield)
9495           do m=1,3
9496             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9497      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9498             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9499      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9500             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9501      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9502             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9503      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9504
9505             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9506      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9507             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9508      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9509             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9510      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9511             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9512      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9513
9514            enddo
9515       endif
9516       endif
9517       return
9518       end
9519 #ifdef MOMENT
9520 C---------------------------------------------------------------------------
9521       subroutine dipole(i,j,jj)
9522       implicit real*8 (a-h,o-z)
9523       include 'DIMENSIONS'
9524       include 'COMMON.IOUNITS'
9525       include 'COMMON.CHAIN'
9526       include 'COMMON.FFIELD'
9527       include 'COMMON.DERIV'
9528       include 'COMMON.INTERACT'
9529       include 'COMMON.CONTACTS'
9530       include 'COMMON.CONTMAT'
9531       include 'COMMON.CORRMAT'
9532       include 'COMMON.TORSION'
9533       include 'COMMON.VAR'
9534       include 'COMMON.GEO'
9535       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9536      &  auxmat(2,2)
9537       iti1 = itortyp(itype(i+1))
9538       if (j.lt.nres-1) then
9539         itj1 = itype2loc(itype(j+1))
9540       else
9541         itj1=nloctyp
9542       endif
9543       do iii=1,2
9544         dipi(iii,1)=Ub2(iii,i)
9545         dipderi(iii)=Ub2der(iii,i)
9546         dipi(iii,2)=b1(iii,i+1)
9547         dipj(iii,1)=Ub2(iii,j)
9548         dipderj(iii)=Ub2der(iii,j)
9549         dipj(iii,2)=b1(iii,j+1)
9550       enddo
9551       kkk=0
9552       do iii=1,2
9553         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9554         do jjj=1,2
9555           kkk=kkk+1
9556           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9557         enddo
9558       enddo
9559       do kkk=1,5
9560         do lll=1,3
9561           mmm=0
9562           do iii=1,2
9563             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9564      &        auxvec(1))
9565             do jjj=1,2
9566               mmm=mmm+1
9567               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9568             enddo
9569           enddo
9570         enddo
9571       enddo
9572       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9573       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9574       do iii=1,2
9575         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9576       enddo
9577       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9578       do iii=1,2
9579         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9580       enddo
9581       return
9582       end
9583 #endif
9584 C---------------------------------------------------------------------------
9585       subroutine calc_eello(i,j,k,l,jj,kk)
9586 C
9587 C This subroutine computes matrices and vectors needed to calculate
9588 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9589 C
9590       implicit real*8 (a-h,o-z)
9591       include 'DIMENSIONS'
9592       include 'COMMON.IOUNITS'
9593       include 'COMMON.CHAIN'
9594       include 'COMMON.DERIV'
9595       include 'COMMON.INTERACT'
9596       include 'COMMON.CONTACTS'
9597       include 'COMMON.CONTMAT'
9598       include 'COMMON.CORRMAT'
9599       include 'COMMON.TORSION'
9600       include 'COMMON.VAR'
9601       include 'COMMON.GEO'
9602       include 'COMMON.FFIELD'
9603       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9604      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9605       logical lprn
9606       common /kutas/ lprn
9607 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9608 cd     & ' jj=',jj,' kk=',kk
9609 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9610 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9611 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9612       do iii=1,2
9613         do jjj=1,2
9614           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9615           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9616         enddo
9617       enddo
9618       call transpose2(aa1(1,1),aa1t(1,1))
9619       call transpose2(aa2(1,1),aa2t(1,1))
9620       do kkk=1,5
9621         do lll=1,3
9622           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9623      &      aa1tder(1,1,lll,kkk))
9624           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9625      &      aa2tder(1,1,lll,kkk))
9626         enddo
9627       enddo
9628       if (l.eq.j+1) then
9629 C parallel orientation of the two CA-CA-CA frames.
9630         if (i.gt.1) then
9631           iti=itype2loc(itype(i))
9632         else
9633           iti=nloctyp
9634         endif
9635         itk1=itype2loc(itype(k+1))
9636         itj=itype2loc(itype(j))
9637         if (l.lt.nres-1) then
9638           itl1=itype2loc(itype(l+1))
9639         else
9640           itl1=nloctyp
9641         endif
9642 C A1 kernel(j+1) A2T
9643 cd        do iii=1,2
9644 cd          write (iout,'(3f10.5,5x,3f10.5)')
9645 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9646 cd        enddo
9647         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9648      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9649      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9650 C Following matrices are needed only for 6-th order cumulants
9651         IF (wcorr6.gt.0.0d0) THEN
9652         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9653      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9654      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9655         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9656      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9657      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9658      &   ADtEAderx(1,1,1,1,1,1))
9659         lprn=.false.
9660         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9661      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9662      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9663      &   ADtEA1derx(1,1,1,1,1,1))
9664         ENDIF
9665 C End 6-th order cumulants
9666 cd        lprn=.false.
9667 cd        if (lprn) then
9668 cd        write (2,*) 'In calc_eello6'
9669 cd        do iii=1,2
9670 cd          write (2,*) 'iii=',iii
9671 cd          do kkk=1,5
9672 cd            write (2,*) 'kkk=',kkk
9673 cd            do jjj=1,2
9674 cd              write (2,'(3(2f10.5),5x)')
9675 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9676 cd            enddo
9677 cd          enddo
9678 cd        enddo
9679 cd        endif
9680         call transpose2(EUgder(1,1,k),auxmat(1,1))
9681         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9682         call transpose2(EUg(1,1,k),auxmat(1,1))
9683         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9684         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9685 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9686 c    in theta; to be sriten later.
9687 c#ifdef NEWCORR
9688 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9689 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9690 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9691 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9692 c#endif
9693         do iii=1,2
9694           do kkk=1,5
9695             do lll=1,3
9696               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9697      &          EAEAderx(1,1,lll,kkk,iii,1))
9698             enddo
9699           enddo
9700         enddo
9701 C A1T kernel(i+1) A2
9702         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9703      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9704      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9705 C Following matrices are needed only for 6-th order cumulants
9706         IF (wcorr6.gt.0.0d0) THEN
9707         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9708      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9709      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9710         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9711      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9712      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9713      &   ADtEAderx(1,1,1,1,1,2))
9714         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9715      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9716      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9717      &   ADtEA1derx(1,1,1,1,1,2))
9718         ENDIF
9719 C End 6-th order cumulants
9720         call transpose2(EUgder(1,1,l),auxmat(1,1))
9721         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9722         call transpose2(EUg(1,1,l),auxmat(1,1))
9723         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9724         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9725         do iii=1,2
9726           do kkk=1,5
9727             do lll=1,3
9728               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9729      &          EAEAderx(1,1,lll,kkk,iii,2))
9730             enddo
9731           enddo
9732         enddo
9733 C AEAb1 and AEAb2
9734 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9735 C They are needed only when the fifth- or the sixth-order cumulants are
9736 C indluded.
9737         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9738         call transpose2(AEA(1,1,1),auxmat(1,1))
9739         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9740         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9741         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9742         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9743         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9744         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9745         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9746         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9747         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9748         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9749         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9750         call transpose2(AEA(1,1,2),auxmat(1,1))
9751         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9752         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9753         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9754         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9755         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9756         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9757         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9758         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9759         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9760         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9761         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9762 C Calculate the Cartesian derivatives of the vectors.
9763         do iii=1,2
9764           do kkk=1,5
9765             do lll=1,3
9766               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9767               call matvec2(auxmat(1,1),b1(1,i),
9768      &          AEAb1derx(1,lll,kkk,iii,1,1))
9769               call matvec2(auxmat(1,1),Ub2(1,i),
9770      &          AEAb2derx(1,lll,kkk,iii,1,1))
9771               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9772      &          AEAb1derx(1,lll,kkk,iii,2,1))
9773               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9774      &          AEAb2derx(1,lll,kkk,iii,2,1))
9775               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9776               call matvec2(auxmat(1,1),b1(1,j),
9777      &          AEAb1derx(1,lll,kkk,iii,1,2))
9778               call matvec2(auxmat(1,1),Ub2(1,j),
9779      &          AEAb2derx(1,lll,kkk,iii,1,2))
9780               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9781      &          AEAb1derx(1,lll,kkk,iii,2,2))
9782               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9783      &          AEAb2derx(1,lll,kkk,iii,2,2))
9784             enddo
9785           enddo
9786         enddo
9787         ENDIF
9788 C End vectors
9789       else
9790 C Antiparallel orientation of the two CA-CA-CA frames.
9791         if (i.gt.1) then
9792           iti=itype2loc(itype(i))
9793         else
9794           iti=nloctyp
9795         endif
9796         itk1=itype2loc(itype(k+1))
9797         itl=itype2loc(itype(l))
9798         itj=itype2loc(itype(j))
9799         if (j.lt.nres-1) then
9800           itj1=itype2loc(itype(j+1))
9801         else
9802           itj1=nloctyp
9803         endif
9804 C A2 kernel(j-1)T A1T
9805         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9806      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9807      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9808 C Following matrices are needed only for 6-th order cumulants
9809         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9810      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9811         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9812      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9813      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9814         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9815      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9816      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9817      &   ADtEAderx(1,1,1,1,1,1))
9818         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9819      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9820      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9821      &   ADtEA1derx(1,1,1,1,1,1))
9822         ENDIF
9823 C End 6-th order cumulants
9824         call transpose2(EUgder(1,1,k),auxmat(1,1))
9825         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9826         call transpose2(EUg(1,1,k),auxmat(1,1))
9827         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9828         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9829         do iii=1,2
9830           do kkk=1,5
9831             do lll=1,3
9832               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9833      &          EAEAderx(1,1,lll,kkk,iii,1))
9834             enddo
9835           enddo
9836         enddo
9837 C A2T kernel(i+1)T A1
9838         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9839      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9840      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9841 C Following matrices are needed only for 6-th order cumulants
9842         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9843      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9844         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9845      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9846      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9847         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9848      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9849      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9850      &   ADtEAderx(1,1,1,1,1,2))
9851         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9852      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9853      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9854      &   ADtEA1derx(1,1,1,1,1,2))
9855         ENDIF
9856 C End 6-th order cumulants
9857         call transpose2(EUgder(1,1,j),auxmat(1,1))
9858         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9859         call transpose2(EUg(1,1,j),auxmat(1,1))
9860         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9861         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9862         do iii=1,2
9863           do kkk=1,5
9864             do lll=1,3
9865               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9866      &          EAEAderx(1,1,lll,kkk,iii,2))
9867             enddo
9868           enddo
9869         enddo
9870 C AEAb1 and AEAb2
9871 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9872 C They are needed only when the fifth- or the sixth-order cumulants are
9873 C indluded.
9874         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9875      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9876         call transpose2(AEA(1,1,1),auxmat(1,1))
9877         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9878         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9879         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9880         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9881         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9882         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9883         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9884         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9885         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9886         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9887         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9888         call transpose2(AEA(1,1,2),auxmat(1,1))
9889         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9890         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9891         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9892         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9893         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9894         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9895         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9896         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9897         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9898         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9899         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9900 C Calculate the Cartesian derivatives of the vectors.
9901         do iii=1,2
9902           do kkk=1,5
9903             do lll=1,3
9904               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9905               call matvec2(auxmat(1,1),b1(1,i),
9906      &          AEAb1derx(1,lll,kkk,iii,1,1))
9907               call matvec2(auxmat(1,1),Ub2(1,i),
9908      &          AEAb2derx(1,lll,kkk,iii,1,1))
9909               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9910      &          AEAb1derx(1,lll,kkk,iii,2,1))
9911               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9912      &          AEAb2derx(1,lll,kkk,iii,2,1))
9913               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9914               call matvec2(auxmat(1,1),b1(1,l),
9915      &          AEAb1derx(1,lll,kkk,iii,1,2))
9916               call matvec2(auxmat(1,1),Ub2(1,l),
9917      &          AEAb2derx(1,lll,kkk,iii,1,2))
9918               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9919      &          AEAb1derx(1,lll,kkk,iii,2,2))
9920               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9921      &          AEAb2derx(1,lll,kkk,iii,2,2))
9922             enddo
9923           enddo
9924         enddo
9925         ENDIF
9926 C End vectors
9927       endif
9928       return
9929       end
9930 C---------------------------------------------------------------------------
9931       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9932      &  KK,KKderg,AKA,AKAderg,AKAderx)
9933       implicit none
9934       integer nderg
9935       logical transp
9936       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9937      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9938      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9939       integer iii,kkk,lll
9940       integer jjj,mmm
9941       logical lprn
9942       common /kutas/ lprn
9943       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9944       do iii=1,nderg
9945         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9946      &    AKAderg(1,1,iii))
9947       enddo
9948 cd      if (lprn) write (2,*) 'In kernel'
9949       do kkk=1,5
9950 cd        if (lprn) write (2,*) 'kkk=',kkk
9951         do lll=1,3
9952           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9953      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9954 cd          if (lprn) then
9955 cd            write (2,*) 'lll=',lll
9956 cd            write (2,*) 'iii=1'
9957 cd            do jjj=1,2
9958 cd              write (2,'(3(2f10.5),5x)')
9959 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9960 cd            enddo
9961 cd          endif
9962           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9963      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9964 cd          if (lprn) then
9965 cd            write (2,*) 'lll=',lll
9966 cd            write (2,*) 'iii=2'
9967 cd            do jjj=1,2
9968 cd              write (2,'(3(2f10.5),5x)')
9969 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9970 cd            enddo
9971 cd          endif
9972         enddo
9973       enddo
9974       return
9975       end
9976 C---------------------------------------------------------------------------
9977       double precision function eello4(i,j,k,l,jj,kk)
9978       implicit real*8 (a-h,o-z)
9979       include 'DIMENSIONS'
9980       include 'COMMON.IOUNITS'
9981       include 'COMMON.CHAIN'
9982       include 'COMMON.DERIV'
9983       include 'COMMON.INTERACT'
9984       include 'COMMON.CONTACTS'
9985       include 'COMMON.CONTMAT'
9986       include 'COMMON.CORRMAT'
9987       include 'COMMON.TORSION'
9988       include 'COMMON.VAR'
9989       include 'COMMON.GEO'
9990       double precision pizda(2,2),ggg1(3),ggg2(3)
9991 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9992 cd        eello4=0.0d0
9993 cd        return
9994 cd      endif
9995 cd      print *,'eello4:',i,j,k,l,jj,kk
9996 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9997 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9998 cold      eij=facont_hb(jj,i)
9999 cold      ekl=facont_hb(kk,k)
10000 cold      ekont=eij*ekl
10001       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10002 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10003       gcorr_loc(k-1)=gcorr_loc(k-1)
10004      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10005       if (l.eq.j+1) then
10006         gcorr_loc(l-1)=gcorr_loc(l-1)
10007      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10008 C Al 4/16/16: Derivatives in theta, to be added later.
10009 c#ifdef NEWCORR
10010 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10011 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10012 c#endif
10013       else
10014         gcorr_loc(j-1)=gcorr_loc(j-1)
10015      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10016 c#ifdef NEWCORR
10017 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10018 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10019 c#endif
10020       endif
10021       do iii=1,2
10022         do kkk=1,5
10023           do lll=1,3
10024             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10025      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10026 cd            derx(lll,kkk,iii)=0.0d0
10027           enddo
10028         enddo
10029       enddo
10030 cd      gcorr_loc(l-1)=0.0d0
10031 cd      gcorr_loc(j-1)=0.0d0
10032 cd      gcorr_loc(k-1)=0.0d0
10033 cd      eel4=1.0d0
10034 cd      write (iout,*)'Contacts have occurred for peptide groups',
10035 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10036 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10037       if (j.lt.nres-1) then
10038         j1=j+1
10039         j2=j-1
10040       else
10041         j1=j-1
10042         j2=j-2
10043       endif
10044       if (l.lt.nres-1) then
10045         l1=l+1
10046         l2=l-1
10047       else
10048         l1=l-1
10049         l2=l-2
10050       endif
10051       do ll=1,3
10052 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10053 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10054         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10055         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10056 cgrad        ghalf=0.5d0*ggg1(ll)
10057         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10058         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10059         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10060         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10061         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10062         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10063 cgrad        ghalf=0.5d0*ggg2(ll)
10064         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10065         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10066         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10067         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10068         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10069         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10070       enddo
10071 cgrad      do m=i+1,j-1
10072 cgrad        do ll=1,3
10073 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10074 cgrad        enddo
10075 cgrad      enddo
10076 cgrad      do m=k+1,l-1
10077 cgrad        do ll=1,3
10078 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10079 cgrad        enddo
10080 cgrad      enddo
10081 cgrad      do m=i+2,j2
10082 cgrad        do ll=1,3
10083 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10084 cgrad        enddo
10085 cgrad      enddo
10086 cgrad      do m=k+2,l2
10087 cgrad        do ll=1,3
10088 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10089 cgrad        enddo
10090 cgrad      enddo
10091 cd      do iii=1,nres-3
10092 cd        write (2,*) iii,gcorr_loc(iii)
10093 cd      enddo
10094       eello4=ekont*eel4
10095 cd      write (2,*) 'ekont',ekont
10096 cd      write (iout,*) 'eello4',ekont*eel4
10097       return
10098       end
10099 C---------------------------------------------------------------------------
10100       double precision function eello5(i,j,k,l,jj,kk)
10101       implicit real*8 (a-h,o-z)
10102       include 'DIMENSIONS'
10103       include 'COMMON.IOUNITS'
10104       include 'COMMON.CHAIN'
10105       include 'COMMON.DERIV'
10106       include 'COMMON.INTERACT'
10107       include 'COMMON.CONTACTS'
10108       include 'COMMON.CONTMAT'
10109       include 'COMMON.CORRMAT'
10110       include 'COMMON.TORSION'
10111       include 'COMMON.VAR'
10112       include 'COMMON.GEO'
10113       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10114       double precision ggg1(3),ggg2(3)
10115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10116 C                                                                              C
10117 C                            Parallel chains                                   C
10118 C                                                                              C
10119 C          o             o                   o             o                   C
10120 C         /l\           / \             \   / \           / \   /              C
10121 C        /   \         /   \             \ /   \         /   \ /               C
10122 C       j| o |l1       | o |              o| o |         | o |o                C
10123 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10124 C      \i/   \         /   \ /             /   \         /   \                 C
10125 C       o    k1             o                                                  C
10126 C         (I)          (II)                (III)          (IV)                 C
10127 C                                                                              C
10128 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10129 C                                                                              C
10130 C                            Antiparallel chains                               C
10131 C                                                                              C
10132 C          o             o                   o             o                   C
10133 C         /j\           / \             \   / \           / \   /              C
10134 C        /   \         /   \             \ /   \         /   \ /               C
10135 C      j1| o |l        | o |              o| o |         | o |o                C
10136 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10137 C      \i/   \         /   \ /             /   \         /   \                 C
10138 C       o     k1            o                                                  C
10139 C         (I)          (II)                (III)          (IV)                 C
10140 C                                                                              C
10141 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10142 C                                                                              C
10143 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10144 C                                                                              C
10145 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10146 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10147 cd        eello5=0.0d0
10148 cd        return
10149 cd      endif
10150 cd      write (iout,*)
10151 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10152 cd     &   ' and',k,l
10153       itk=itype2loc(itype(k))
10154       itl=itype2loc(itype(l))
10155       itj=itype2loc(itype(j))
10156       eello5_1=0.0d0
10157       eello5_2=0.0d0
10158       eello5_3=0.0d0
10159       eello5_4=0.0d0
10160 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10161 cd     &   eel5_3_num,eel5_4_num)
10162       do iii=1,2
10163         do kkk=1,5
10164           do lll=1,3
10165             derx(lll,kkk,iii)=0.0d0
10166           enddo
10167         enddo
10168       enddo
10169 cd      eij=facont_hb(jj,i)
10170 cd      ekl=facont_hb(kk,k)
10171 cd      ekont=eij*ekl
10172 cd      write (iout,*)'Contacts have occurred for peptide groups',
10173 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10174 cd      goto 1111
10175 C Contribution from the graph I.
10176 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10177 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10178       call transpose2(EUg(1,1,k),auxmat(1,1))
10179       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10180       vv(1)=pizda(1,1)-pizda(2,2)
10181       vv(2)=pizda(1,2)+pizda(2,1)
10182       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10183      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10184 C Explicit gradient in virtual-dihedral angles.
10185       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10186      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10187      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10188       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10189       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10190       vv(1)=pizda(1,1)-pizda(2,2)
10191       vv(2)=pizda(1,2)+pizda(2,1)
10192       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10193      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10194      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10195       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10196       vv(1)=pizda(1,1)-pizda(2,2)
10197       vv(2)=pizda(1,2)+pizda(2,1)
10198       if (l.eq.j+1) then
10199         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10200      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10201      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10202       else
10203         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10204      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10205      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10206       endif
10207 C Cartesian gradient
10208       do iii=1,2
10209         do kkk=1,5
10210           do lll=1,3
10211             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10212      &        pizda(1,1))
10213             vv(1)=pizda(1,1)-pizda(2,2)
10214             vv(2)=pizda(1,2)+pizda(2,1)
10215             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10216      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10217      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10218           enddo
10219         enddo
10220       enddo
10221 c      goto 1112
10222 c1111  continue
10223 C Contribution from graph II
10224       call transpose2(EE(1,1,k),auxmat(1,1))
10225       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10226       vv(1)=pizda(1,1)+pizda(2,2)
10227       vv(2)=pizda(2,1)-pizda(1,2)
10228       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10229      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10230 C Explicit gradient in virtual-dihedral angles.
10231       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10232      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10233       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10234       vv(1)=pizda(1,1)+pizda(2,2)
10235       vv(2)=pizda(2,1)-pizda(1,2)
10236       if (l.eq.j+1) then
10237         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10238      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10239      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10240       else
10241         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10242      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10243      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10244       endif
10245 C Cartesian gradient
10246       do iii=1,2
10247         do kkk=1,5
10248           do lll=1,3
10249             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10250      &        pizda(1,1))
10251             vv(1)=pizda(1,1)+pizda(2,2)
10252             vv(2)=pizda(2,1)-pizda(1,2)
10253             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10254      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10255      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10256           enddo
10257         enddo
10258       enddo
10259 cd      goto 1112
10260 cd1111  continue
10261       if (l.eq.j+1) then
10262 cd        goto 1110
10263 C Parallel orientation
10264 C Contribution from graph III
10265         call transpose2(EUg(1,1,l),auxmat(1,1))
10266         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10267         vv(1)=pizda(1,1)-pizda(2,2)
10268         vv(2)=pizda(1,2)+pizda(2,1)
10269         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10270      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10271 C Explicit gradient in virtual-dihedral angles.
10272         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10273      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10274      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10275         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10276         vv(1)=pizda(1,1)-pizda(2,2)
10277         vv(2)=pizda(1,2)+pizda(2,1)
10278         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10279      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10280      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10281         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10282         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10283         vv(1)=pizda(1,1)-pizda(2,2)
10284         vv(2)=pizda(1,2)+pizda(2,1)
10285         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10286      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10287      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10288 C Cartesian gradient
10289         do iii=1,2
10290           do kkk=1,5
10291             do lll=1,3
10292               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10293      &          pizda(1,1))
10294               vv(1)=pizda(1,1)-pizda(2,2)
10295               vv(2)=pizda(1,2)+pizda(2,1)
10296               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10297      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10298      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10299             enddo
10300           enddo
10301         enddo
10302 cd        goto 1112
10303 C Contribution from graph IV
10304 cd1110    continue
10305         call transpose2(EE(1,1,l),auxmat(1,1))
10306         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10307         vv(1)=pizda(1,1)+pizda(2,2)
10308         vv(2)=pizda(2,1)-pizda(1,2)
10309         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10310      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10311 C Explicit gradient in virtual-dihedral angles.
10312         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10313      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10314         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10315         vv(1)=pizda(1,1)+pizda(2,2)
10316         vv(2)=pizda(2,1)-pizda(1,2)
10317         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10318      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10319      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10320 C Cartesian gradient
10321         do iii=1,2
10322           do kkk=1,5
10323             do lll=1,3
10324               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10325      &          pizda(1,1))
10326               vv(1)=pizda(1,1)+pizda(2,2)
10327               vv(2)=pizda(2,1)-pizda(1,2)
10328               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10329      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10330      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10331             enddo
10332           enddo
10333         enddo
10334       else
10335 C Antiparallel orientation
10336 C Contribution from graph III
10337 c        goto 1110
10338         call transpose2(EUg(1,1,j),auxmat(1,1))
10339         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10340         vv(1)=pizda(1,1)-pizda(2,2)
10341         vv(2)=pizda(1,2)+pizda(2,1)
10342         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10343      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10344 C Explicit gradient in virtual-dihedral angles.
10345         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10346      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10347      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10348         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10349         vv(1)=pizda(1,1)-pizda(2,2)
10350         vv(2)=pizda(1,2)+pizda(2,1)
10351         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10352      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10353      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10354         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10355         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10356         vv(1)=pizda(1,1)-pizda(2,2)
10357         vv(2)=pizda(1,2)+pizda(2,1)
10358         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10359      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10360      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10361 C Cartesian gradient
10362         do iii=1,2
10363           do kkk=1,5
10364             do lll=1,3
10365               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10366      &          pizda(1,1))
10367               vv(1)=pizda(1,1)-pizda(2,2)
10368               vv(2)=pizda(1,2)+pizda(2,1)
10369               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10370      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10371      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10372             enddo
10373           enddo
10374         enddo
10375 cd        goto 1112
10376 C Contribution from graph IV
10377 1110    continue
10378         call transpose2(EE(1,1,j),auxmat(1,1))
10379         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10380         vv(1)=pizda(1,1)+pizda(2,2)
10381         vv(2)=pizda(2,1)-pizda(1,2)
10382         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10383      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10384 C Explicit gradient in virtual-dihedral angles.
10385         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10386      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10387         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10388         vv(1)=pizda(1,1)+pizda(2,2)
10389         vv(2)=pizda(2,1)-pizda(1,2)
10390         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10391      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10392      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10393 C Cartesian gradient
10394         do iii=1,2
10395           do kkk=1,5
10396             do lll=1,3
10397               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10398      &          pizda(1,1))
10399               vv(1)=pizda(1,1)+pizda(2,2)
10400               vv(2)=pizda(2,1)-pizda(1,2)
10401               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10402      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10403      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10404             enddo
10405           enddo
10406         enddo
10407       endif
10408 1112  continue
10409       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10410 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10411 cd        write (2,*) 'ijkl',i,j,k,l
10412 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10413 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10414 cd      endif
10415 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10416 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10417 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10418 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10419       if (j.lt.nres-1) then
10420         j1=j+1
10421         j2=j-1
10422       else
10423         j1=j-1
10424         j2=j-2
10425       endif
10426       if (l.lt.nres-1) then
10427         l1=l+1
10428         l2=l-1
10429       else
10430         l1=l-1
10431         l2=l-2
10432       endif
10433 cd      eij=1.0d0
10434 cd      ekl=1.0d0
10435 cd      ekont=1.0d0
10436 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10437 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10438 C        summed up outside the subrouine as for the other subroutines
10439 C        handling long-range interactions. The old code is commented out
10440 C        with "cgrad" to keep track of changes.
10441       do ll=1,3
10442 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10443 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10444         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10445         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10446 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10447 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10448 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10449 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10450 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10451 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10452 c     &   gradcorr5ij,
10453 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10454 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10455 cgrad        ghalf=0.5d0*ggg1(ll)
10456 cd        ghalf=0.0d0
10457         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10458         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10459         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10460         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10461         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10462         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10463 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10464 cgrad        ghalf=0.5d0*ggg2(ll)
10465 cd        ghalf=0.0d0
10466         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10467         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10468         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10469         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10470         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10471         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10472       enddo
10473 cd      goto 1112
10474 cgrad      do m=i+1,j-1
10475 cgrad        do ll=1,3
10476 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10477 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10478 cgrad        enddo
10479 cgrad      enddo
10480 cgrad      do m=k+1,l-1
10481 cgrad        do ll=1,3
10482 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10483 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10484 cgrad        enddo
10485 cgrad      enddo
10486 c1112  continue
10487 cgrad      do m=i+2,j2
10488 cgrad        do ll=1,3
10489 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10490 cgrad        enddo
10491 cgrad      enddo
10492 cgrad      do m=k+2,l2
10493 cgrad        do ll=1,3
10494 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10495 cgrad        enddo
10496 cgrad      enddo
10497 cd      do iii=1,nres-3
10498 cd        write (2,*) iii,g_corr5_loc(iii)
10499 cd      enddo
10500       eello5=ekont*eel5
10501 cd      write (2,*) 'ekont',ekont
10502 cd      write (iout,*) 'eello5',ekont*eel5
10503       return
10504       end
10505 c--------------------------------------------------------------------------
10506       double precision function eello6(i,j,k,l,jj,kk)
10507       implicit real*8 (a-h,o-z)
10508       include 'DIMENSIONS'
10509       include 'COMMON.IOUNITS'
10510       include 'COMMON.CHAIN'
10511       include 'COMMON.DERIV'
10512       include 'COMMON.INTERACT'
10513       include 'COMMON.CONTACTS'
10514       include 'COMMON.CONTMAT'
10515       include 'COMMON.CORRMAT'
10516       include 'COMMON.TORSION'
10517       include 'COMMON.VAR'
10518       include 'COMMON.GEO'
10519       include 'COMMON.FFIELD'
10520       double precision ggg1(3),ggg2(3)
10521 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10522 cd        eello6=0.0d0
10523 cd        return
10524 cd      endif
10525 cd      write (iout,*)
10526 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10527 cd     &   ' and',k,l
10528       eello6_1=0.0d0
10529       eello6_2=0.0d0
10530       eello6_3=0.0d0
10531       eello6_4=0.0d0
10532       eello6_5=0.0d0
10533       eello6_6=0.0d0
10534 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10535 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10536       do iii=1,2
10537         do kkk=1,5
10538           do lll=1,3
10539             derx(lll,kkk,iii)=0.0d0
10540           enddo
10541         enddo
10542       enddo
10543 cd      eij=facont_hb(jj,i)
10544 cd      ekl=facont_hb(kk,k)
10545 cd      ekont=eij*ekl
10546 cd      eij=1.0d0
10547 cd      ekl=1.0d0
10548 cd      ekont=1.0d0
10549       if (l.eq.j+1) then
10550         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10551         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10552         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10553         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10554         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10555         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10556       else
10557         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10558         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10559         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10560         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10561         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10562           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10563         else
10564           eello6_5=0.0d0
10565         endif
10566         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10567       endif
10568 C If turn contributions are considered, they will be handled separately.
10569       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10570 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10571 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10572 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10573 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10574 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10575 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10576 cd      goto 1112
10577       if (j.lt.nres-1) then
10578         j1=j+1
10579         j2=j-1
10580       else
10581         j1=j-1
10582         j2=j-2
10583       endif
10584       if (l.lt.nres-1) then
10585         l1=l+1
10586         l2=l-1
10587       else
10588         l1=l-1
10589         l2=l-2
10590       endif
10591       do ll=1,3
10592 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10593 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10594 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10595 cgrad        ghalf=0.5d0*ggg1(ll)
10596 cd        ghalf=0.0d0
10597         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10598         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10599         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10600         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10601         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10602         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10603         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10604         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10605 cgrad        ghalf=0.5d0*ggg2(ll)
10606 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10607 cd        ghalf=0.0d0
10608         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10609         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10610         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10611         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10612         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10613         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10614       enddo
10615 cd      goto 1112
10616 cgrad      do m=i+1,j-1
10617 cgrad        do ll=1,3
10618 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10619 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10620 cgrad        enddo
10621 cgrad      enddo
10622 cgrad      do m=k+1,l-1
10623 cgrad        do ll=1,3
10624 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10625 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10626 cgrad        enddo
10627 cgrad      enddo
10628 cgrad1112  continue
10629 cgrad      do m=i+2,j2
10630 cgrad        do ll=1,3
10631 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10632 cgrad        enddo
10633 cgrad      enddo
10634 cgrad      do m=k+2,l2
10635 cgrad        do ll=1,3
10636 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10637 cgrad        enddo
10638 cgrad      enddo
10639 cd      do iii=1,nres-3
10640 cd        write (2,*) iii,g_corr6_loc(iii)
10641 cd      enddo
10642       eello6=ekont*eel6
10643 cd      write (2,*) 'ekont',ekont
10644 cd      write (iout,*) 'eello6',ekont*eel6
10645       return
10646       end
10647 c--------------------------------------------------------------------------
10648       double precision function eello6_graph1(i,j,k,l,imat,swap)
10649       implicit real*8 (a-h,o-z)
10650       include 'DIMENSIONS'
10651       include 'COMMON.IOUNITS'
10652       include 'COMMON.CHAIN'
10653       include 'COMMON.DERIV'
10654       include 'COMMON.INTERACT'
10655       include 'COMMON.CONTACTS'
10656       include 'COMMON.CONTMAT'
10657       include 'COMMON.CORRMAT'
10658       include 'COMMON.TORSION'
10659       include 'COMMON.VAR'
10660       include 'COMMON.GEO'
10661       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10662       logical swap
10663       logical lprn
10664       common /kutas/ lprn
10665 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10666 C                                                                              C
10667 C      Parallel       Antiparallel                                             C
10668 C                                                                              C
10669 C          o             o                                                     C
10670 C         /l\           /j\                                                    C
10671 C        /   \         /   \                                                   C
10672 C       /| o |         | o |\                                                  C
10673 C     \ j|/k\|  /   \  |/k\|l /                                                C
10674 C      \ /   \ /     \ /   \ /                                                 C
10675 C       o     o       o     o                                                  C
10676 C       i             i                                                        C
10677 C                                                                              C
10678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10679       itk=itype2loc(itype(k))
10680       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10681       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10682       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10683       call transpose2(EUgC(1,1,k),auxmat(1,1))
10684       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10685       vv1(1)=pizda1(1,1)-pizda1(2,2)
10686       vv1(2)=pizda1(1,2)+pizda1(2,1)
10687       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10688       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10689       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10690       s5=scalar2(vv(1),Dtobr2(1,i))
10691 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10692       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10693       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10694      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10695      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10696      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10697      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10698      & +scalar2(vv(1),Dtobr2der(1,i)))
10699       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10700       vv1(1)=pizda1(1,1)-pizda1(2,2)
10701       vv1(2)=pizda1(1,2)+pizda1(2,1)
10702       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10703       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10704       if (l.eq.j+1) then
10705         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10706      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10707      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10708      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10709      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10710       else
10711         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10712      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10713      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10714      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10715      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10716       endif
10717       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10718       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10719       vv1(1)=pizda1(1,1)-pizda1(2,2)
10720       vv1(2)=pizda1(1,2)+pizda1(2,1)
10721       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10722      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10723      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10724      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10725       do iii=1,2
10726         if (swap) then
10727           ind=3-iii
10728         else
10729           ind=iii
10730         endif
10731         do kkk=1,5
10732           do lll=1,3
10733             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10734             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10735             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10736             call transpose2(EUgC(1,1,k),auxmat(1,1))
10737             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10738      &        pizda1(1,1))
10739             vv1(1)=pizda1(1,1)-pizda1(2,2)
10740             vv1(2)=pizda1(1,2)+pizda1(2,1)
10741             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10742             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10743      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10744             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10745      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10746             s5=scalar2(vv(1),Dtobr2(1,i))
10747             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10748           enddo
10749         enddo
10750       enddo
10751       return
10752       end
10753 c----------------------------------------------------------------------------
10754       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10755       implicit real*8 (a-h,o-z)
10756       include 'DIMENSIONS'
10757       include 'COMMON.IOUNITS'
10758       include 'COMMON.CHAIN'
10759       include 'COMMON.DERIV'
10760       include 'COMMON.INTERACT'
10761       include 'COMMON.CONTACTS'
10762       include 'COMMON.CONTMAT'
10763       include 'COMMON.CORRMAT'
10764       include 'COMMON.TORSION'
10765       include 'COMMON.VAR'
10766       include 'COMMON.GEO'
10767       logical swap
10768       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10769      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10770       logical lprn
10771       common /kutas/ lprn
10772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10773 C                                                                              C
10774 C      Parallel       Antiparallel                                             C
10775 C                                                                              C
10776 C          o             o                                                     C
10777 C     \   /l\           /j\   /                                                C
10778 C      \ /   \         /   \ /                                                 C
10779 C       o| o |         | o |o                                                  C
10780 C     \ j|/k\|      \  |/k\|l                                                  C
10781 C      \ /   \       \ /   \                                                   C
10782 C       o             o                                                        C
10783 C       i             i                                                        C
10784 C                                                                              C
10785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10786 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10787 C AL 7/4/01 s1 would occur in the sixth-order moment,
10788 C           but not in a cluster cumulant
10789 #ifdef MOMENT
10790       s1=dip(1,jj,i)*dip(1,kk,k)
10791 #endif
10792       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10793       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10794       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10795       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10796       call transpose2(EUg(1,1,k),auxmat(1,1))
10797       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10798       vv(1)=pizda(1,1)-pizda(2,2)
10799       vv(2)=pizda(1,2)+pizda(2,1)
10800       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10801 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10802 #ifdef MOMENT
10803       eello6_graph2=-(s1+s2+s3+s4)
10804 #else
10805       eello6_graph2=-(s2+s3+s4)
10806 #endif
10807 c      eello6_graph2=-s3
10808 C Derivatives in gamma(i-1)
10809       if (i.gt.1) then
10810 #ifdef MOMENT
10811         s1=dipderg(1,jj,i)*dip(1,kk,k)
10812 #endif
10813         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10814         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10815         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10816         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10817 #ifdef MOMENT
10818         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10819 #else
10820         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10821 #endif
10822 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10823       endif
10824 C Derivatives in gamma(k-1)
10825 #ifdef MOMENT
10826       s1=dip(1,jj,i)*dipderg(1,kk,k)
10827 #endif
10828       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10829       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10830       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10831       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10832       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10833       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10834       vv(1)=pizda(1,1)-pizda(2,2)
10835       vv(2)=pizda(1,2)+pizda(2,1)
10836       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10837 #ifdef MOMENT
10838       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10839 #else
10840       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10841 #endif
10842 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10843 C Derivatives in gamma(j-1) or gamma(l-1)
10844       if (j.gt.1) then
10845 #ifdef MOMENT
10846         s1=dipderg(3,jj,i)*dip(1,kk,k)
10847 #endif
10848         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10849         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10850         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10851         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10852         vv(1)=pizda(1,1)-pizda(2,2)
10853         vv(2)=pizda(1,2)+pizda(2,1)
10854         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10855 #ifdef MOMENT
10856         if (swap) then
10857           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10858         else
10859           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10860         endif
10861 #endif
10862         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10863 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10864       endif
10865 C Derivatives in gamma(l-1) or gamma(j-1)
10866       if (l.gt.1) then
10867 #ifdef MOMENT
10868         s1=dip(1,jj,i)*dipderg(3,kk,k)
10869 #endif
10870         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10871         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10872         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10873         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10874         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10875         vv(1)=pizda(1,1)-pizda(2,2)
10876         vv(2)=pizda(1,2)+pizda(2,1)
10877         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10878 #ifdef MOMENT
10879         if (swap) then
10880           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10881         else
10882           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10883         endif
10884 #endif
10885         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10886 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10887       endif
10888 C Cartesian derivatives.
10889       if (lprn) then
10890         write (2,*) 'In eello6_graph2'
10891         do iii=1,2
10892           write (2,*) 'iii=',iii
10893           do kkk=1,5
10894             write (2,*) 'kkk=',kkk
10895             do jjj=1,2
10896               write (2,'(3(2f10.5),5x)')
10897      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10898             enddo
10899           enddo
10900         enddo
10901       endif
10902       do iii=1,2
10903         do kkk=1,5
10904           do lll=1,3
10905 #ifdef MOMENT
10906             if (iii.eq.1) then
10907               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10908             else
10909               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10910             endif
10911 #endif
10912             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10913      &        auxvec(1))
10914             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10915             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10916      &        auxvec(1))
10917             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10918             call transpose2(EUg(1,1,k),auxmat(1,1))
10919             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10920      &        pizda(1,1))
10921             vv(1)=pizda(1,1)-pizda(2,2)
10922             vv(2)=pizda(1,2)+pizda(2,1)
10923             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10924 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10925 #ifdef MOMENT
10926             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10927 #else
10928             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10929 #endif
10930             if (swap) then
10931               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10932             else
10933               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10934             endif
10935           enddo
10936         enddo
10937       enddo
10938       return
10939       end
10940 c----------------------------------------------------------------------------
10941       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10942       implicit real*8 (a-h,o-z)
10943       include 'DIMENSIONS'
10944       include 'COMMON.IOUNITS'
10945       include 'COMMON.CHAIN'
10946       include 'COMMON.DERIV'
10947       include 'COMMON.INTERACT'
10948       include 'COMMON.CONTACTS'
10949       include 'COMMON.CONTMAT'
10950       include 'COMMON.CORRMAT'
10951       include 'COMMON.TORSION'
10952       include 'COMMON.VAR'
10953       include 'COMMON.GEO'
10954       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10955       logical swap
10956 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10957 C                                                                              C
10958 C      Parallel       Antiparallel                                             C
10959 C                                                                              C
10960 C          o             o                                                     C
10961 C         /l\   /   \   /j\                                                    C
10962 C        /   \ /     \ /   \                                                   C
10963 C       /| o |o       o| o |\                                                  C
10964 C       j|/k\|  /      |/k\|l /                                                C
10965 C        /   \ /       /   \ /                                                 C
10966 C       /     o       /     o                                                  C
10967 C       i             i                                                        C
10968 C                                                                              C
10969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10970 C
10971 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10972 C           energy moment and not to the cluster cumulant.
10973       iti=itortyp(itype(i))
10974       if (j.lt.nres-1) then
10975         itj1=itype2loc(itype(j+1))
10976       else
10977         itj1=nloctyp
10978       endif
10979       itk=itype2loc(itype(k))
10980       itk1=itype2loc(itype(k+1))
10981       if (l.lt.nres-1) then
10982         itl1=itype2loc(itype(l+1))
10983       else
10984         itl1=nloctyp
10985       endif
10986 #ifdef MOMENT
10987       s1=dip(4,jj,i)*dip(4,kk,k)
10988 #endif
10989       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10990       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10991       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10992       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10993       call transpose2(EE(1,1,k),auxmat(1,1))
10994       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10995       vv(1)=pizda(1,1)+pizda(2,2)
10996       vv(2)=pizda(2,1)-pizda(1,2)
10997       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10998 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10999 cd     & "sum",-(s2+s3+s4)
11000 #ifdef MOMENT
11001       eello6_graph3=-(s1+s2+s3+s4)
11002 #else
11003       eello6_graph3=-(s2+s3+s4)
11004 #endif
11005 c      eello6_graph3=-s4
11006 C Derivatives in gamma(k-1)
11007       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11008       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11009       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11010       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11011 C Derivatives in gamma(l-1)
11012       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11013       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11014       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11015       vv(1)=pizda(1,1)+pizda(2,2)
11016       vv(2)=pizda(2,1)-pizda(1,2)
11017       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11018       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11019 C Cartesian derivatives.
11020       do iii=1,2
11021         do kkk=1,5
11022           do lll=1,3
11023 #ifdef MOMENT
11024             if (iii.eq.1) then
11025               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11026             else
11027               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11028             endif
11029 #endif
11030             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11031      &        auxvec(1))
11032             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11033             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11034      &        auxvec(1))
11035             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11036             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11037      &        pizda(1,1))
11038             vv(1)=pizda(1,1)+pizda(2,2)
11039             vv(2)=pizda(2,1)-pizda(1,2)
11040             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11041 #ifdef MOMENT
11042             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11043 #else
11044             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11045 #endif
11046             if (swap) then
11047               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11048             else
11049               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11050             endif
11051 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11052           enddo
11053         enddo
11054       enddo
11055       return
11056       end
11057 c----------------------------------------------------------------------------
11058       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11059       implicit real*8 (a-h,o-z)
11060       include 'DIMENSIONS'
11061       include 'COMMON.IOUNITS'
11062       include 'COMMON.CHAIN'
11063       include 'COMMON.DERIV'
11064       include 'COMMON.INTERACT'
11065       include 'COMMON.CONTACTS'
11066       include 'COMMON.CONTMAT'
11067       include 'COMMON.CORRMAT'
11068       include 'COMMON.TORSION'
11069       include 'COMMON.VAR'
11070       include 'COMMON.GEO'
11071       include 'COMMON.FFIELD'
11072       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11073      & auxvec1(2),auxmat1(2,2)
11074       logical swap
11075 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11076 C                                                                              C
11077 C      Parallel       Antiparallel                                             C
11078 C                                                                              C
11079 C          o             o                                                     C
11080 C         /l\   /   \   /j\                                                    C
11081 C        /   \ /     \ /   \                                                   C
11082 C       /| o |o       o| o |\                                                  C
11083 C     \ j|/k\|      \  |/k\|l                                                  C
11084 C      \ /   \       \ /   \                                                   C
11085 C       o     \       o     \                                                  C
11086 C       i             i                                                        C
11087 C                                                                              C
11088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11089 C
11090 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11091 C           energy moment and not to the cluster cumulant.
11092 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11093       iti=itype2loc(itype(i))
11094       itj=itype2loc(itype(j))
11095       if (j.lt.nres-1) then
11096         itj1=itype2loc(itype(j+1))
11097       else
11098         itj1=nloctyp
11099       endif
11100       itk=itype2loc(itype(k))
11101       if (k.lt.nres-1) then
11102         itk1=itype2loc(itype(k+1))
11103       else
11104         itk1=nloctyp
11105       endif
11106       itl=itype2loc(itype(l))
11107       if (l.lt.nres-1) then
11108         itl1=itype2loc(itype(l+1))
11109       else
11110         itl1=nloctyp
11111       endif
11112 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11113 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11114 cd     & ' itl',itl,' itl1',itl1
11115 #ifdef MOMENT
11116       if (imat.eq.1) then
11117         s1=dip(3,jj,i)*dip(3,kk,k)
11118       else
11119         s1=dip(2,jj,j)*dip(2,kk,l)
11120       endif
11121 #endif
11122       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11123       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11124       if (j.eq.l+1) then
11125         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11126         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11127       else
11128         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11129         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11130       endif
11131       call transpose2(EUg(1,1,k),auxmat(1,1))
11132       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11133       vv(1)=pizda(1,1)-pizda(2,2)
11134       vv(2)=pizda(2,1)+pizda(1,2)
11135       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11136 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11137 #ifdef MOMENT
11138       eello6_graph4=-(s1+s2+s3+s4)
11139 #else
11140       eello6_graph4=-(s2+s3+s4)
11141 #endif
11142 C Derivatives in gamma(i-1)
11143       if (i.gt.1) then
11144 #ifdef MOMENT
11145         if (imat.eq.1) then
11146           s1=dipderg(2,jj,i)*dip(3,kk,k)
11147         else
11148           s1=dipderg(4,jj,j)*dip(2,kk,l)
11149         endif
11150 #endif
11151         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11152         if (j.eq.l+1) then
11153           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11154           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11155         else
11156           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11157           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11158         endif
11159         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11160         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11161 cd          write (2,*) 'turn6 derivatives'
11162 #ifdef MOMENT
11163           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11164 #else
11165           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11166 #endif
11167         else
11168 #ifdef MOMENT
11169           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11170 #else
11171           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11172 #endif
11173         endif
11174       endif
11175 C Derivatives in gamma(k-1)
11176 #ifdef MOMENT
11177       if (imat.eq.1) then
11178         s1=dip(3,jj,i)*dipderg(2,kk,k)
11179       else
11180         s1=dip(2,jj,j)*dipderg(4,kk,l)
11181       endif
11182 #endif
11183       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11184       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11185       if (j.eq.l+1) then
11186         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11187         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11188       else
11189         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11190         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11191       endif
11192       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11193       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11194       vv(1)=pizda(1,1)-pizda(2,2)
11195       vv(2)=pizda(2,1)+pizda(1,2)
11196       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11197       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11198 #ifdef MOMENT
11199         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11200 #else
11201         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11202 #endif
11203       else
11204 #ifdef MOMENT
11205         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11206 #else
11207         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11208 #endif
11209       endif
11210 C Derivatives in gamma(j-1) or gamma(l-1)
11211       if (l.eq.j+1 .and. l.gt.1) then
11212         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11213         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11214         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11215         vv(1)=pizda(1,1)-pizda(2,2)
11216         vv(2)=pizda(2,1)+pizda(1,2)
11217         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11218         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11219       else if (j.gt.1) then
11220         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11221         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11222         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11223         vv(1)=pizda(1,1)-pizda(2,2)
11224         vv(2)=pizda(2,1)+pizda(1,2)
11225         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11226         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11227           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11228         else
11229           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11230         endif
11231       endif
11232 C Cartesian derivatives.
11233       do iii=1,2
11234         do kkk=1,5
11235           do lll=1,3
11236 #ifdef MOMENT
11237             if (iii.eq.1) then
11238               if (imat.eq.1) then
11239                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11240               else
11241                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11242               endif
11243             else
11244               if (imat.eq.1) then
11245                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11246               else
11247                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11248               endif
11249             endif
11250 #endif
11251             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11252      &        auxvec(1))
11253             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11254             if (j.eq.l+1) then
11255               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11256      &          b1(1,j+1),auxvec(1))
11257               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11258             else
11259               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11260      &          b1(1,l+1),auxvec(1))
11261               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11262             endif
11263             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11264      &        pizda(1,1))
11265             vv(1)=pizda(1,1)-pizda(2,2)
11266             vv(2)=pizda(2,1)+pizda(1,2)
11267             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11268             if (swap) then
11269               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11270 #ifdef MOMENT
11271                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11272      &             -(s1+s2+s4)
11273 #else
11274                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11275      &             -(s2+s4)
11276 #endif
11277                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11278               else
11279 #ifdef MOMENT
11280                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11281 #else
11282                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11283 #endif
11284                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11285               endif
11286             else
11287 #ifdef MOMENT
11288               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11289 #else
11290               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11291 #endif
11292               if (l.eq.j+1) then
11293                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11294               else
11295                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11296               endif
11297             endif
11298           enddo
11299         enddo
11300       enddo
11301       return
11302       end
11303 c----------------------------------------------------------------------------
11304       double precision function eello_turn6(i,jj,kk)
11305       implicit real*8 (a-h,o-z)
11306       include 'DIMENSIONS'
11307       include 'COMMON.IOUNITS'
11308       include 'COMMON.CHAIN'
11309       include 'COMMON.DERIV'
11310       include 'COMMON.INTERACT'
11311       include 'COMMON.CONTACTS'
11312       include 'COMMON.CONTMAT'
11313       include 'COMMON.CORRMAT'
11314       include 'COMMON.TORSION'
11315       include 'COMMON.VAR'
11316       include 'COMMON.GEO'
11317       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11318      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11319      &  ggg1(3),ggg2(3)
11320       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11321      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11322 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11323 C           the respective energy moment and not to the cluster cumulant.
11324       s1=0.0d0
11325       s8=0.0d0
11326       s13=0.0d0
11327 c
11328       eello_turn6=0.0d0
11329       j=i+4
11330       k=i+1
11331       l=i+3
11332       iti=itype2loc(itype(i))
11333       itk=itype2loc(itype(k))
11334       itk1=itype2loc(itype(k+1))
11335       itl=itype2loc(itype(l))
11336       itj=itype2loc(itype(j))
11337 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11338 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11339 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11340 cd        eello6=0.0d0
11341 cd        return
11342 cd      endif
11343 cd      write (iout,*)
11344 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11345 cd     &   ' and',k,l
11346 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11347       do iii=1,2
11348         do kkk=1,5
11349           do lll=1,3
11350             derx_turn(lll,kkk,iii)=0.0d0
11351           enddo
11352         enddo
11353       enddo
11354 cd      eij=1.0d0
11355 cd      ekl=1.0d0
11356 cd      ekont=1.0d0
11357       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11358 cd      eello6_5=0.0d0
11359 cd      write (2,*) 'eello6_5',eello6_5
11360 #ifdef MOMENT
11361       call transpose2(AEA(1,1,1),auxmat(1,1))
11362       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11363       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11364       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11365 #endif
11366       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11367       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11368       s2 = scalar2(b1(1,k),vtemp1(1))
11369 #ifdef MOMENT
11370       call transpose2(AEA(1,1,2),atemp(1,1))
11371       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11372       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11373       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11374 #endif
11375       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11376       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11377       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11378 #ifdef MOMENT
11379       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11380       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11381       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11382       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11383       ss13 = scalar2(b1(1,k),vtemp4(1))
11384       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11385 #endif
11386 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11387 c      s1=0.0d0
11388 c      s2=0.0d0
11389 c      s8=0.0d0
11390 c      s12=0.0d0
11391 c      s13=0.0d0
11392       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11393 C Derivatives in gamma(i+2)
11394       s1d =0.0d0
11395       s8d =0.0d0
11396 #ifdef MOMENT
11397       call transpose2(AEA(1,1,1),auxmatd(1,1))
11398       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11399       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11400       call transpose2(AEAderg(1,1,2),atempd(1,1))
11401       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11402       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11403 #endif
11404       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11405       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11406       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11407 c      s1d=0.0d0
11408 c      s2d=0.0d0
11409 c      s8d=0.0d0
11410 c      s12d=0.0d0
11411 c      s13d=0.0d0
11412       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11413 C Derivatives in gamma(i+3)
11414 #ifdef MOMENT
11415       call transpose2(AEA(1,1,1),auxmatd(1,1))
11416       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11417       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11418       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11419 #endif
11420       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11421       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11422       s2d = scalar2(b1(1,k),vtemp1d(1))
11423 #ifdef MOMENT
11424       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11425       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11426 #endif
11427       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11428 #ifdef MOMENT
11429       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11430       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11431       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11432 #endif
11433 c      s1d=0.0d0
11434 c      s2d=0.0d0
11435 c      s8d=0.0d0
11436 c      s12d=0.0d0
11437 c      s13d=0.0d0
11438 #ifdef MOMENT
11439       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11440      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11441 #else
11442       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11443      &               -0.5d0*ekont*(s2d+s12d)
11444 #endif
11445 C Derivatives in gamma(i+4)
11446       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11447       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11448       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11449 #ifdef MOMENT
11450       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11451       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11452       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11453 #endif
11454 c      s1d=0.0d0
11455 c      s2d=0.0d0
11456 c      s8d=0.0d0
11457 C      s12d=0.0d0
11458 c      s13d=0.0d0
11459 #ifdef MOMENT
11460       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11461 #else
11462       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11463 #endif
11464 C Derivatives in gamma(i+5)
11465 #ifdef MOMENT
11466       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11467       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11468       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11469 #endif
11470       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11471       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11472       s2d = scalar2(b1(1,k),vtemp1d(1))
11473 #ifdef MOMENT
11474       call transpose2(AEA(1,1,2),atempd(1,1))
11475       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11476       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11477 #endif
11478       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11479       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11480 #ifdef MOMENT
11481       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11482       ss13d = scalar2(b1(1,k),vtemp4d(1))
11483       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11484 #endif
11485 c      s1d=0.0d0
11486 c      s2d=0.0d0
11487 c      s8d=0.0d0
11488 c      s12d=0.0d0
11489 c      s13d=0.0d0
11490 #ifdef MOMENT
11491       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11492      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11493 #else
11494       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11495      &               -0.5d0*ekont*(s2d+s12d)
11496 #endif
11497 C Cartesian derivatives
11498       do iii=1,2
11499         do kkk=1,5
11500           do lll=1,3
11501 #ifdef MOMENT
11502             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11503             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11504             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11505 #endif
11506             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11507             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11508      &          vtemp1d(1))
11509             s2d = scalar2(b1(1,k),vtemp1d(1))
11510 #ifdef MOMENT
11511             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11512             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11513             s8d = -(atempd(1,1)+atempd(2,2))*
11514      &           scalar2(cc(1,1,l),vtemp2(1))
11515 #endif
11516             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11517      &           auxmatd(1,1))
11518             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11519             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11520 c      s1d=0.0d0
11521 c      s2d=0.0d0
11522 c      s8d=0.0d0
11523 c      s12d=0.0d0
11524 c      s13d=0.0d0
11525 #ifdef MOMENT
11526             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11527      &        - 0.5d0*(s1d+s2d)
11528 #else
11529             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11530      &        - 0.5d0*s2d
11531 #endif
11532 #ifdef MOMENT
11533             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11534      &        - 0.5d0*(s8d+s12d)
11535 #else
11536             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11537      &        - 0.5d0*s12d
11538 #endif
11539           enddo
11540         enddo
11541       enddo
11542 #ifdef MOMENT
11543       do kkk=1,5
11544         do lll=1,3
11545           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11546      &      achuj_tempd(1,1))
11547           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11548           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11549           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11550           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11551           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11552      &      vtemp4d(1))
11553           ss13d = scalar2(b1(1,k),vtemp4d(1))
11554           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11555           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11556         enddo
11557       enddo
11558 #endif
11559 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11560 cd     &  16*eel_turn6_num
11561 cd      goto 1112
11562       if (j.lt.nres-1) then
11563         j1=j+1
11564         j2=j-1
11565       else
11566         j1=j-1
11567         j2=j-2
11568       endif
11569       if (l.lt.nres-1) then
11570         l1=l+1
11571         l2=l-1
11572       else
11573         l1=l-1
11574         l2=l-2
11575       endif
11576       do ll=1,3
11577 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11578 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11579 cgrad        ghalf=0.5d0*ggg1(ll)
11580 cd        ghalf=0.0d0
11581         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11582         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11583         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11584      &    +ekont*derx_turn(ll,2,1)
11585         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11586         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11587      &    +ekont*derx_turn(ll,4,1)
11588         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11589         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11590         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11591 cgrad        ghalf=0.5d0*ggg2(ll)
11592 cd        ghalf=0.0d0
11593         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11594      &    +ekont*derx_turn(ll,2,2)
11595         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11596         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11597      &    +ekont*derx_turn(ll,4,2)
11598         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11599         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11600         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11601       enddo
11602 cd      goto 1112
11603 cgrad      do m=i+1,j-1
11604 cgrad        do ll=1,3
11605 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11606 cgrad        enddo
11607 cgrad      enddo
11608 cgrad      do m=k+1,l-1
11609 cgrad        do ll=1,3
11610 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11611 cgrad        enddo
11612 cgrad      enddo
11613 cgrad1112  continue
11614 cgrad      do m=i+2,j2
11615 cgrad        do ll=1,3
11616 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11617 cgrad        enddo
11618 cgrad      enddo
11619 cgrad      do m=k+2,l2
11620 cgrad        do ll=1,3
11621 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11622 cgrad        enddo
11623 cgrad      enddo
11624 cd      do iii=1,nres-3
11625 cd        write (2,*) iii,g_corr6_loc(iii)
11626 cd      enddo
11627       eello_turn6=ekont*eel_turn6
11628 cd      write (2,*) 'ekont',ekont
11629 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11630       return
11631       end
11632 C-----------------------------------------------------------------------------
11633 #endif
11634       double precision function scalar(u,v)
11635 !DIR$ INLINEALWAYS scalar
11636 #ifndef OSF
11637 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11638 #endif
11639       implicit none
11640       double precision u(3),v(3)
11641 cd      double precision sc
11642 cd      integer i
11643 cd      sc=0.0d0
11644 cd      do i=1,3
11645 cd        sc=sc+u(i)*v(i)
11646 cd      enddo
11647 cd      scalar=sc
11648
11649       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11650       return
11651       end
11652 crc-------------------------------------------------
11653       SUBROUTINE MATVEC2(A1,V1,V2)
11654 !DIR$ INLINEALWAYS MATVEC2
11655 #ifndef OSF
11656 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11657 #endif
11658       implicit real*8 (a-h,o-z)
11659       include 'DIMENSIONS'
11660       DIMENSION A1(2,2),V1(2),V2(2)
11661 c      DO 1 I=1,2
11662 c        VI=0.0
11663 c        DO 3 K=1,2
11664 c    3     VI=VI+A1(I,K)*V1(K)
11665 c        Vaux(I)=VI
11666 c    1 CONTINUE
11667
11668       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11669       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11670
11671       v2(1)=vaux1
11672       v2(2)=vaux2
11673       END
11674 C---------------------------------------
11675       SUBROUTINE MATMAT2(A1,A2,A3)
11676 #ifndef OSF
11677 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11678 #endif
11679       implicit real*8 (a-h,o-z)
11680       include 'DIMENSIONS'
11681       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11682 c      DIMENSION AI3(2,2)
11683 c        DO  J=1,2
11684 c          A3IJ=0.0
11685 c          DO K=1,2
11686 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11687 c          enddo
11688 c          A3(I,J)=A3IJ
11689 c       enddo
11690 c      enddo
11691
11692       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11693       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11694       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11695       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11696
11697       A3(1,1)=AI3_11
11698       A3(2,1)=AI3_21
11699       A3(1,2)=AI3_12
11700       A3(2,2)=AI3_22
11701       END
11702
11703 c-------------------------------------------------------------------------
11704       double precision function scalar2(u,v)
11705 !DIR$ INLINEALWAYS scalar2
11706       implicit none
11707       double precision u(2),v(2)
11708       double precision sc
11709       integer i
11710       scalar2=u(1)*v(1)+u(2)*v(2)
11711       return
11712       end
11713
11714 C-----------------------------------------------------------------------------
11715
11716       subroutine transpose2(a,at)
11717 !DIR$ INLINEALWAYS transpose2
11718 #ifndef OSF
11719 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11720 #endif
11721       implicit none
11722       double precision a(2,2),at(2,2)
11723       at(1,1)=a(1,1)
11724       at(1,2)=a(2,1)
11725       at(2,1)=a(1,2)
11726       at(2,2)=a(2,2)
11727       return
11728       end
11729 c--------------------------------------------------------------------------
11730       subroutine transpose(n,a,at)
11731       implicit none
11732       integer n,i,j
11733       double precision a(n,n),at(n,n)
11734       do i=1,n
11735         do j=1,n
11736           at(j,i)=a(i,j)
11737         enddo
11738       enddo
11739       return
11740       end
11741 C---------------------------------------------------------------------------
11742       subroutine prodmat3(a1,a2,kk,transp,prod)
11743 !DIR$ INLINEALWAYS prodmat3
11744 #ifndef OSF
11745 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11746 #endif
11747       implicit none
11748       integer i,j
11749       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11750       logical transp
11751 crc      double precision auxmat(2,2),prod_(2,2)
11752
11753       if (transp) then
11754 crc        call transpose2(kk(1,1),auxmat(1,1))
11755 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11756 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11757
11758            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11759      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11760            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11761      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11762            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11763      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11764            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11765      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11766
11767       else
11768 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11769 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11770
11771            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11772      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11773            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11774      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11775            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11776      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11777            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11778      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11779
11780       endif
11781 c      call transpose2(a2(1,1),a2t(1,1))
11782
11783 crc      print *,transp
11784 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11785 crc      print *,((prod(i,j),i=1,2),j=1,2)
11786
11787       return
11788       end
11789 CCC----------------------------------------------
11790       subroutine Eliptransfer(eliptran)
11791       implicit real*8 (a-h,o-z)
11792       include 'DIMENSIONS'
11793       include 'COMMON.GEO'
11794       include 'COMMON.VAR'
11795       include 'COMMON.LOCAL'
11796       include 'COMMON.CHAIN'
11797       include 'COMMON.DERIV'
11798       include 'COMMON.NAMES'
11799       include 'COMMON.INTERACT'
11800       include 'COMMON.IOUNITS'
11801       include 'COMMON.CALC'
11802       include 'COMMON.CONTROL'
11803       include 'COMMON.SPLITELE'
11804       include 'COMMON.SBRIDGE'
11805 C this is done by Adasko
11806 C      print *,"wchodze"
11807 C structure of box:
11808 C      water
11809 C--bordliptop-- buffore starts
11810 C--bufliptop--- here true lipid starts
11811 C      lipid
11812 C--buflipbot--- lipid ends buffore starts
11813 C--bordlipbot--buffore ends
11814       eliptran=0.0
11815       do i=ilip_start,ilip_end
11816 C       do i=1,1
11817         if (itype(i).eq.ntyp1) cycle
11818
11819         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11820         if (positi.le.0.0) positi=positi+boxzsize
11821 C        print *,i
11822 C first for peptide groups
11823 c for each residue check if it is in lipid or lipid water border area
11824        if ((positi.gt.bordlipbot)
11825      &.and.(positi.lt.bordliptop)) then
11826 C the energy transfer exist
11827         if (positi.lt.buflipbot) then
11828 C what fraction I am in
11829          fracinbuf=1.0d0-
11830      &        ((positi-bordlipbot)/lipbufthick)
11831 C lipbufthick is thickenes of lipid buffore
11832          sslip=sscalelip(fracinbuf)
11833          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11834          eliptran=eliptran+sslip*pepliptran
11835          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11836          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11837 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11838
11839 C        print *,"doing sccale for lower part"
11840 C         print *,i,sslip,fracinbuf,ssgradlip
11841         elseif (positi.gt.bufliptop) then
11842          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11843          sslip=sscalelip(fracinbuf)
11844          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11845          eliptran=eliptran+sslip*pepliptran
11846          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11847          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11848 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11849 C          print *, "doing sscalefor top part"
11850 C         print *,i,sslip,fracinbuf,ssgradlip
11851         else
11852          eliptran=eliptran+pepliptran
11853 C         print *,"I am in true lipid"
11854         endif
11855 C       else
11856 C       eliptran=elpitran+0.0 ! I am in water
11857        endif
11858        enddo
11859 C       print *, "nic nie bylo w lipidzie?"
11860 C now multiply all by the peptide group transfer factor
11861 C       eliptran=eliptran*pepliptran
11862 C now the same for side chains
11863 CV       do i=1,1
11864        do i=ilip_start,ilip_end
11865         if (itype(i).eq.ntyp1) cycle
11866         positi=(mod(c(3,i+nres),boxzsize))
11867         if (positi.le.0) positi=positi+boxzsize
11868 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11869 c for each residue check if it is in lipid or lipid water border area
11870 C       respos=mod(c(3,i+nres),boxzsize)
11871 C       print *,positi,bordlipbot,buflipbot
11872        if ((positi.gt.bordlipbot)
11873      & .and.(positi.lt.bordliptop)) then
11874 C the energy transfer exist
11875         if (positi.lt.buflipbot) then
11876          fracinbuf=1.0d0-
11877      &     ((positi-bordlipbot)/lipbufthick)
11878 C lipbufthick is thickenes of lipid buffore
11879          sslip=sscalelip(fracinbuf)
11880          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11881          eliptran=eliptran+sslip*liptranene(itype(i))
11882          gliptranx(3,i)=gliptranx(3,i)
11883      &+ssgradlip*liptranene(itype(i))
11884          gliptranc(3,i-1)= gliptranc(3,i-1)
11885      &+ssgradlip*liptranene(itype(i))
11886 C         print *,"doing sccale for lower part"
11887         elseif (positi.gt.bufliptop) then
11888          fracinbuf=1.0d0-
11889      &((bordliptop-positi)/lipbufthick)
11890          sslip=sscalelip(fracinbuf)
11891          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11892          eliptran=eliptran+sslip*liptranene(itype(i))
11893          gliptranx(3,i)=gliptranx(3,i)
11894      &+ssgradlip*liptranene(itype(i))
11895          gliptranc(3,i-1)= gliptranc(3,i-1)
11896      &+ssgradlip*liptranene(itype(i))
11897 C          print *, "doing sscalefor top part",sslip,fracinbuf
11898         else
11899          eliptran=eliptran+liptranene(itype(i))
11900 C         print *,"I am in true lipid"
11901         endif
11902         endif ! if in lipid or buffor
11903 C       else
11904 C       eliptran=elpitran+0.0 ! I am in water
11905        enddo
11906        return
11907        end
11908 C---------------------------------------------------------
11909 C AFM soubroutine for constant force
11910        subroutine AFMforce(Eafmforce)
11911        implicit real*8 (a-h,o-z)
11912       include 'DIMENSIONS'
11913       include 'COMMON.GEO'
11914       include 'COMMON.VAR'
11915       include 'COMMON.LOCAL'
11916       include 'COMMON.CHAIN'
11917       include 'COMMON.DERIV'
11918       include 'COMMON.NAMES'
11919       include 'COMMON.INTERACT'
11920       include 'COMMON.IOUNITS'
11921       include 'COMMON.CALC'
11922       include 'COMMON.CONTROL'
11923       include 'COMMON.SPLITELE'
11924       include 'COMMON.SBRIDGE'
11925       real*8 diffafm(3)
11926       dist=0.0d0
11927       Eafmforce=0.0d0
11928       do i=1,3
11929       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11930       dist=dist+diffafm(i)**2
11931       enddo
11932       dist=dsqrt(dist)
11933       Eafmforce=-forceAFMconst*(dist-distafminit)
11934       do i=1,3
11935       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11936       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11937       enddo
11938 C      print *,'AFM',Eafmforce
11939       return
11940       end
11941 C---------------------------------------------------------
11942 C AFM subroutine with pseudoconstant velocity
11943        subroutine AFMvel(Eafmforce)
11944        implicit real*8 (a-h,o-z)
11945       include 'DIMENSIONS'
11946       include 'COMMON.GEO'
11947       include 'COMMON.VAR'
11948       include 'COMMON.LOCAL'
11949       include 'COMMON.CHAIN'
11950       include 'COMMON.DERIV'
11951       include 'COMMON.NAMES'
11952       include 'COMMON.INTERACT'
11953       include 'COMMON.IOUNITS'
11954       include 'COMMON.CALC'
11955       include 'COMMON.CONTROL'
11956       include 'COMMON.SPLITELE'
11957       include 'COMMON.SBRIDGE'
11958       real*8 diffafm(3)
11959 C Only for check grad COMMENT if not used for checkgrad
11960 C      totT=3.0d0
11961 C--------------------------------------------------------
11962 C      print *,"wchodze"
11963       dist=0.0d0
11964       Eafmforce=0.0d0
11965       do i=1,3
11966       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11967       dist=dist+diffafm(i)**2
11968       enddo
11969       dist=dsqrt(dist)
11970       Eafmforce=0.5d0*forceAFMconst
11971      & *(distafminit+totTafm*velAFMconst-dist)**2
11972 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11973       do i=1,3
11974       gradafm(i,afmend-1)=-forceAFMconst*
11975      &(distafminit+totTafm*velAFMconst-dist)
11976      &*diffafm(i)/dist
11977       gradafm(i,afmbeg-1)=forceAFMconst*
11978      &(distafminit+totTafm*velAFMconst-dist)
11979      &*diffafm(i)/dist
11980       enddo
11981 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11982       return
11983       end
11984 C-----------------------------------------------------------
11985 C first for shielding is setting of function of side-chains
11986        subroutine set_shield_fac
11987       implicit real*8 (a-h,o-z)
11988       include 'DIMENSIONS'
11989       include 'COMMON.CHAIN'
11990       include 'COMMON.DERIV'
11991       include 'COMMON.IOUNITS'
11992       include 'COMMON.SHIELD'
11993       include 'COMMON.INTERACT'
11994 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11995       double precision div77_81/0.974996043d0/,
11996      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11997
11998 C the vector between center of side_chain and peptide group
11999        double precision pep_side(3),long,side_calf(3),
12000      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12001      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12002 C the line belowe needs to be changed for FGPROC>1
12003       do i=1,nres-1
12004       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12005       ishield_list(i)=0
12006 Cif there two consequtive dummy atoms there is no peptide group between them
12007 C the line below has to be changed for FGPROC>1
12008       VolumeTotal=0.0
12009       do k=1,nres
12010        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12011        dist_pep_side=0.0
12012        dist_side_calf=0.0
12013        do j=1,3
12014 C first lets set vector conecting the ithe side-chain with kth side-chain
12015       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12016 C      pep_side(j)=2.0d0
12017 C and vector conecting the side-chain with its proper calfa
12018       side_calf(j)=c(j,k+nres)-c(j,k)
12019 C      side_calf(j)=2.0d0
12020       pept_group(j)=c(j,i)-c(j,i+1)
12021 C lets have their lenght
12022       dist_pep_side=pep_side(j)**2+dist_pep_side
12023       dist_side_calf=dist_side_calf+side_calf(j)**2
12024       dist_pept_group=dist_pept_group+pept_group(j)**2
12025       enddo
12026        dist_pep_side=dsqrt(dist_pep_side)
12027        dist_pept_group=dsqrt(dist_pept_group)
12028        dist_side_calf=dsqrt(dist_side_calf)
12029       do j=1,3
12030         pep_side_norm(j)=pep_side(j)/dist_pep_side
12031         side_calf_norm(j)=dist_side_calf
12032       enddo
12033 C now sscale fraction
12034        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12035 C       print *,buff_shield,"buff"
12036 C now sscale
12037         if (sh_frac_dist.le.0.0) cycle
12038 C If we reach here it means that this side chain reaches the shielding sphere
12039 C Lets add him to the list for gradient
12040         ishield_list(i)=ishield_list(i)+1
12041 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12042 C this list is essential otherwise problem would be O3
12043         shield_list(ishield_list(i),i)=k
12044 C Lets have the sscale value
12045         if (sh_frac_dist.gt.1.0) then
12046          scale_fac_dist=1.0d0
12047          do j=1,3
12048          sh_frac_dist_grad(j)=0.0d0
12049          enddo
12050         else
12051          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12052      &                   *(2.0*sh_frac_dist-3.0d0)
12053          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12054      &                  /dist_pep_side/buff_shield*0.5
12055 C remember for the final gradient multiply sh_frac_dist_grad(j)
12056 C for side_chain by factor -2 !
12057          do j=1,3
12058          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12059 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12060 C     &                    sh_frac_dist_grad(j)
12061          enddo
12062         endif
12063 C        if ((i.eq.3).and.(k.eq.2)) then
12064 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12065 C     & ,"TU"
12066 C        endif
12067
12068 C this is what is now we have the distance scaling now volume...
12069       short=short_r_sidechain(itype(k))
12070       long=long_r_sidechain(itype(k))
12071       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12072 C now costhet_grad
12073 C       costhet=0.0d0
12074        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12075 C       costhet_fac=0.0d0
12076        do j=1,3
12077          costhet_grad(j)=costhet_fac*pep_side(j)
12078        enddo
12079 C remember for the final gradient multiply costhet_grad(j)
12080 C for side_chain by factor -2 !
12081 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12082 C pep_side0pept_group is vector multiplication
12083       pep_side0pept_group=0.0
12084       do j=1,3
12085       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12086       enddo
12087       cosalfa=(pep_side0pept_group/
12088      & (dist_pep_side*dist_side_calf))
12089       fac_alfa_sin=1.0-cosalfa**2
12090       fac_alfa_sin=dsqrt(fac_alfa_sin)
12091       rkprim=fac_alfa_sin*(long-short)+short
12092 C now costhet_grad
12093        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12094        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12095
12096        do j=1,3
12097          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12098      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12099      &*(long-short)/fac_alfa_sin*cosalfa/
12100      &((dist_pep_side*dist_side_calf))*
12101      &((side_calf(j))-cosalfa*
12102      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12103
12104         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12105      &*(long-short)/fac_alfa_sin*cosalfa
12106      &/((dist_pep_side*dist_side_calf))*
12107      &(pep_side(j)-
12108      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12109        enddo
12110
12111       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12112      &                    /VSolvSphere_div
12113      &                    *wshield
12114 C now the gradient...
12115 C grad_shield is gradient of Calfa for peptide groups
12116 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12117 C     &               costhet,cosphi
12118 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12119 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12120       do j=1,3
12121       grad_shield(j,i)=grad_shield(j,i)
12122 C gradient po skalowaniu
12123      &                +(sh_frac_dist_grad(j)
12124 C  gradient po costhet
12125      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12126      &-scale_fac_dist*(cosphi_grad_long(j))
12127      &/(1.0-cosphi) )*div77_81
12128      &*VofOverlap
12129 C grad_shield_side is Cbeta sidechain gradient
12130       grad_shield_side(j,ishield_list(i),i)=
12131      &        (sh_frac_dist_grad(j)*(-2.0d0)
12132      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12133      &       +scale_fac_dist*(cosphi_grad_long(j))
12134      &        *2.0d0/(1.0-cosphi))
12135      &        *div77_81*VofOverlap
12136
12137        grad_shield_loc(j,ishield_list(i),i)=
12138      &   scale_fac_dist*cosphi_grad_loc(j)
12139      &        *2.0d0/(1.0-cosphi)
12140      &        *div77_81*VofOverlap
12141       enddo
12142       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12143       enddo
12144       fac_shield(i)=VolumeTotal*div77_81+div4_81
12145 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12146       enddo
12147       return
12148       end
12149 C--------------------------------------------------------------------------
12150       double precision function tschebyshev(m,n,x,y)
12151       implicit none
12152       include "DIMENSIONS"
12153       integer i,m,n
12154       double precision x(n),y,yy(0:maxvar),aux
12155 c Tschebyshev polynomial. Note that the first term is omitted
12156 c m=0: the constant term is included
12157 c m=1: the constant term is not included
12158       yy(0)=1.0d0
12159       yy(1)=y
12160       do i=2,n
12161         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12162       enddo
12163       aux=0.0d0
12164       do i=m,n
12165         aux=aux+x(i)*yy(i)
12166       enddo
12167       tschebyshev=aux
12168       return
12169       end
12170 C--------------------------------------------------------------------------
12171       double precision function gradtschebyshev(m,n,x,y)
12172       implicit none
12173       include "DIMENSIONS"
12174       integer i,m,n
12175       double precision x(n+1),y,yy(0:maxvar),aux
12176 c Tschebyshev polynomial. Note that the first term is omitted
12177 c m=0: the constant term is included
12178 c m=1: the constant term is not included
12179       yy(0)=1.0d0
12180       yy(1)=2.0d0*y
12181       do i=2,n
12182         yy(i)=2*y*yy(i-1)-yy(i-2)
12183       enddo
12184       aux=0.0d0
12185       do i=m,n
12186         aux=aux+x(i+1)*yy(i)*(i+1)
12187 C        print *, x(i+1),yy(i),i
12188       enddo
12189       gradtschebyshev=aux
12190       return
12191       end
12192 C------------------------------------------------------------------------
12193 C first for shielding is setting of function of side-chains
12194        subroutine set_shield_fac2
12195       implicit real*8 (a-h,o-z)
12196       include 'DIMENSIONS'
12197       include 'COMMON.CHAIN'
12198       include 'COMMON.DERIV'
12199       include 'COMMON.IOUNITS'
12200       include 'COMMON.SHIELD'
12201       include 'COMMON.INTERACT'
12202 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12203       double precision div77_81/0.974996043d0/,
12204      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12205
12206 C the vector between center of side_chain and peptide group
12207        double precision pep_side(3),long,side_calf(3),
12208      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12209      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12210 C the line belowe needs to be changed for FGPROC>1
12211       do i=1,nres-1
12212       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12213       ishield_list(i)=0
12214 Cif there two consequtive dummy atoms there is no peptide group between them
12215 C the line below has to be changed for FGPROC>1
12216       VolumeTotal=0.0
12217       do k=1,nres
12218        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12219        dist_pep_side=0.0
12220        dist_side_calf=0.0
12221        do j=1,3
12222 C first lets set vector conecting the ithe side-chain with kth side-chain
12223       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12224 C      pep_side(j)=2.0d0
12225 C and vector conecting the side-chain with its proper calfa
12226       side_calf(j)=c(j,k+nres)-c(j,k)
12227 C      side_calf(j)=2.0d0
12228       pept_group(j)=c(j,i)-c(j,i+1)
12229 C lets have their lenght
12230       dist_pep_side=pep_side(j)**2+dist_pep_side
12231       dist_side_calf=dist_side_calf+side_calf(j)**2
12232       dist_pept_group=dist_pept_group+pept_group(j)**2
12233       enddo
12234        dist_pep_side=dsqrt(dist_pep_side)
12235        dist_pept_group=dsqrt(dist_pept_group)
12236        dist_side_calf=dsqrt(dist_side_calf)
12237       do j=1,3
12238         pep_side_norm(j)=pep_side(j)/dist_pep_side
12239         side_calf_norm(j)=dist_side_calf
12240       enddo
12241 C now sscale fraction
12242        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12243 C       print *,buff_shield,"buff"
12244 C now sscale
12245         if (sh_frac_dist.le.0.0) cycle
12246 C If we reach here it means that this side chain reaches the shielding sphere
12247 C Lets add him to the list for gradient
12248         ishield_list(i)=ishield_list(i)+1
12249 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12250 C this list is essential otherwise problem would be O3
12251         shield_list(ishield_list(i),i)=k
12252 C Lets have the sscale value
12253         if (sh_frac_dist.gt.1.0) then
12254          scale_fac_dist=1.0d0
12255          do j=1,3
12256          sh_frac_dist_grad(j)=0.0d0
12257          enddo
12258         else
12259          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12260      &                   *(2.0d0*sh_frac_dist-3.0d0)
12261          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12262      &                  /dist_pep_side/buff_shield*0.5d0
12263 C remember for the final gradient multiply sh_frac_dist_grad(j)
12264 C for side_chain by factor -2 !
12265          do j=1,3
12266          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12267 C         sh_frac_dist_grad(j)=0.0d0
12268 C         scale_fac_dist=1.0d0
12269 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12270 C     &                    sh_frac_dist_grad(j)
12271          enddo
12272         endif
12273 C this is what is now we have the distance scaling now volume...
12274       short=short_r_sidechain(itype(k))
12275       long=long_r_sidechain(itype(k))
12276       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12277       sinthet=short/dist_pep_side*costhet
12278 C now costhet_grad
12279 C       costhet=0.6d0
12280 C       sinthet=0.8
12281        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12282 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12283 C     &             -short/dist_pep_side**2/costhet)
12284 C       costhet_fac=0.0d0
12285        do j=1,3
12286          costhet_grad(j)=costhet_fac*pep_side(j)
12287        enddo
12288 C remember for the final gradient multiply costhet_grad(j)
12289 C for side_chain by factor -2 !
12290 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12291 C pep_side0pept_group is vector multiplication
12292       pep_side0pept_group=0.0d0
12293       do j=1,3
12294       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12295       enddo
12296       cosalfa=(pep_side0pept_group/
12297      & (dist_pep_side*dist_side_calf))
12298       fac_alfa_sin=1.0d0-cosalfa**2
12299       fac_alfa_sin=dsqrt(fac_alfa_sin)
12300       rkprim=fac_alfa_sin*(long-short)+short
12301 C      rkprim=short
12302
12303 C now costhet_grad
12304        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12305 C       cosphi=0.6
12306        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12307        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12308      &      dist_pep_side**2)
12309 C       sinphi=0.8
12310        do j=1,3
12311          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12312      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12313      &*(long-short)/fac_alfa_sin*cosalfa/
12314      &((dist_pep_side*dist_side_calf))*
12315      &((side_calf(j))-cosalfa*
12316      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12317 C       cosphi_grad_long(j)=0.0d0
12318         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12319      &*(long-short)/fac_alfa_sin*cosalfa
12320      &/((dist_pep_side*dist_side_calf))*
12321      &(pep_side(j)-
12322      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12323 C       cosphi_grad_loc(j)=0.0d0
12324        enddo
12325 C      print *,sinphi,sinthet
12326 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12327 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12328       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12329      &                    /VSolvSphere_div
12330 C     &                    *wshield
12331 C now the gradient...
12332       do j=1,3
12333       grad_shield(j,i)=grad_shield(j,i)
12334 C gradient po skalowaniu
12335      &                +(sh_frac_dist_grad(j)*VofOverlap
12336 C  gradient po costhet
12337      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12338      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12339      &       sinphi/sinthet*costhet*costhet_grad(j)
12340      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12341      & )*wshield
12342 C grad_shield_side is Cbeta sidechain gradient
12343       grad_shield_side(j,ishield_list(i),i)=
12344      &        (sh_frac_dist_grad(j)*(-2.0d0)
12345      &        *VofOverlap
12346      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12347      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12348      &       sinphi/sinthet*costhet*costhet_grad(j)
12349      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12350      &       )*wshield
12351
12352        grad_shield_loc(j,ishield_list(i),i)=
12353      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12354      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12355      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12356      &        ))
12357      &        *wshield
12358       enddo
12359 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12360 c     & scale_fac_dist
12361       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12362       enddo
12363       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12364 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12365 c     &  " wshield",wshield
12366 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12367       enddo
12368       return
12369       end
12370 C-----------------------------------------------------------------------
12371 C-----------------------------------------------------------
12372 C This subroutine is to mimic the histone like structure but as well can be
12373 C utilizet to nanostructures (infinit) small modification has to be used to
12374 C make it finite (z gradient at the ends has to be changes as well as the x,y
12375 C gradient has to be modified at the ends
12376 C The energy function is Kihara potential
12377 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12378 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12379 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12380 C simple Kihara potential
12381       subroutine calctube(Etube)
12382        implicit real*8 (a-h,o-z)
12383       include 'DIMENSIONS'
12384       include 'COMMON.GEO'
12385       include 'COMMON.VAR'
12386       include 'COMMON.LOCAL'
12387       include 'COMMON.CHAIN'
12388       include 'COMMON.DERIV'
12389       include 'COMMON.NAMES'
12390       include 'COMMON.INTERACT'
12391       include 'COMMON.IOUNITS'
12392       include 'COMMON.CALC'
12393       include 'COMMON.CONTROL'
12394       include 'COMMON.SPLITELE'
12395       include 'COMMON.SBRIDGE'
12396       double precision tub_r,vectube(3),enetube(maxres*2)
12397       Etube=0.0d0
12398       do i=1,2*nres
12399         enetube(i)=0.0d0
12400       enddo
12401 C first we calculate the distance from tube center
12402 C first sugare-phosphate group for NARES this would be peptide group
12403 C for UNRES
12404       do i=1,nres
12405 C lets ommit dummy atoms for now
12406        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12407 C now calculate distance from center of tube and direction vectors
12408       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12409           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12410       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12411           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12412       vectube(1)=vectube(1)-tubecenter(1)
12413       vectube(2)=vectube(2)-tubecenter(2)
12414
12415 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12416 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12417
12418 C as the tube is infinity we do not calculate the Z-vector use of Z
12419 C as chosen axis
12420       vectube(3)=0.0d0
12421 C now calculte the distance
12422        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12423 C now normalize vector
12424       vectube(1)=vectube(1)/tub_r
12425       vectube(2)=vectube(2)/tub_r
12426 C calculte rdiffrence between r and r0
12427       rdiff=tub_r-tubeR0
12428 C and its 6 power
12429       rdiff6=rdiff**6.0d0
12430 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12431        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12432 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12433 C       print *,rdiff,rdiff6,pep_aa_tube
12434 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12435 C now we calculate gradient
12436        fac=(-12.0d0*pep_aa_tube/rdiff6+
12437      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12438 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12439 C     &rdiff,fac
12440
12441 C now direction of gg_tube vector
12442         do j=1,3
12443         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12444         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12445         enddo
12446         enddo
12447 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12448         do i=1,nres
12449 C Lets not jump over memory as we use many times iti
12450          iti=itype(i)
12451 C lets ommit dummy atoms for now
12452          if ((iti.eq.ntyp1)
12453 C in UNRES uncomment the line below as GLY has no side-chain...
12454 C      .or.(iti.eq.10)
12455      &   ) cycle
12456           vectube(1)=c(1,i+nres)
12457           vectube(1)=mod(vectube(1),boxxsize)
12458           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12459           vectube(2)=c(2,i+nres)
12460           vectube(2)=mod(vectube(2),boxxsize)
12461           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12462
12463       vectube(1)=vectube(1)-tubecenter(1)
12464       vectube(2)=vectube(2)-tubecenter(2)
12465
12466 C as the tube is infinity we do not calculate the Z-vector use of Z
12467 C as chosen axis
12468       vectube(3)=0.0d0
12469 C now calculte the distance
12470        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12471 C now normalize vector
12472       vectube(1)=vectube(1)/tub_r
12473       vectube(2)=vectube(2)/tub_r
12474 C calculte rdiffrence between r and r0
12475       rdiff=tub_r-tubeR0
12476 C and its 6 power
12477       rdiff6=rdiff**6.0d0
12478 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12479        sc_aa_tube=sc_aa_tube_par(iti)
12480        sc_bb_tube=sc_bb_tube_par(iti)
12481        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12482 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12483 C now we calculate gradient
12484        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12485      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12486 C now direction of gg_tube vector
12487          do j=1,3
12488           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12489           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12490          enddo
12491         enddo
12492         do i=1,2*nres
12493           Etube=Etube+enetube(i)
12494         enddo
12495 C        print *,"ETUBE", etube
12496         return
12497         end
12498 C TO DO 1) add to total energy
12499 C       2) add to gradient summation
12500 C       3) add reading parameters (AND of course oppening of PARAM file)
12501 C       4) add reading the center of tube
12502 C       5) add COMMONs
12503 C       6) add to zerograd
12504
12505 C-----------------------------------------------------------------------
12506 C-----------------------------------------------------------
12507 C This subroutine is to mimic the histone like structure but as well can be
12508 C utilizet to nanostructures (infinit) small modification has to be used to
12509 C make it finite (z gradient at the ends has to be changes as well as the x,y
12510 C gradient has to be modified at the ends
12511 C The energy function is Kihara potential
12512 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12513 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12514 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12515 C simple Kihara potential
12516       subroutine calctube2(Etube)
12517        implicit real*8 (a-h,o-z)
12518       include 'DIMENSIONS'
12519       include 'COMMON.GEO'
12520       include 'COMMON.VAR'
12521       include 'COMMON.LOCAL'
12522       include 'COMMON.CHAIN'
12523       include 'COMMON.DERIV'
12524       include 'COMMON.NAMES'
12525       include 'COMMON.INTERACT'
12526       include 'COMMON.IOUNITS'
12527       include 'COMMON.CALC'
12528       include 'COMMON.CONTROL'
12529       include 'COMMON.SPLITELE'
12530       include 'COMMON.SBRIDGE'
12531       double precision tub_r,vectube(3),enetube(maxres*2)
12532       Etube=0.0d0
12533       do i=1,2*nres
12534         enetube(i)=0.0d0
12535       enddo
12536 C first we calculate the distance from tube center
12537 C first sugare-phosphate group for NARES this would be peptide group
12538 C for UNRES
12539       do i=1,nres
12540 C lets ommit dummy atoms for now
12541        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12542 C now calculate distance from center of tube and direction vectors
12543       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12544           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12545       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12546           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12547       vectube(1)=vectube(1)-tubecenter(1)
12548       vectube(2)=vectube(2)-tubecenter(2)
12549
12550 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12551 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12552
12553 C as the tube is infinity we do not calculate the Z-vector use of Z
12554 C as chosen axis
12555       vectube(3)=0.0d0
12556 C now calculte the distance
12557        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12558 C now normalize vector
12559       vectube(1)=vectube(1)/tub_r
12560       vectube(2)=vectube(2)/tub_r
12561 C calculte rdiffrence between r and r0
12562       rdiff=tub_r-tubeR0
12563 C and its 6 power
12564       rdiff6=rdiff**6.0d0
12565 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12566        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12567 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12568 C       print *,rdiff,rdiff6,pep_aa_tube
12569 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12570 C now we calculate gradient
12571        fac=(-12.0d0*pep_aa_tube/rdiff6+
12572      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12573 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12574 C     &rdiff,fac
12575
12576 C now direction of gg_tube vector
12577         do j=1,3
12578         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12579         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12580         enddo
12581         enddo
12582 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12583         do i=1,nres
12584 C Lets not jump over memory as we use many times iti
12585          iti=itype(i)
12586 C lets ommit dummy atoms for now
12587          if ((iti.eq.ntyp1)
12588 C in UNRES uncomment the line below as GLY has no side-chain...
12589      &      .or.(iti.eq.10)
12590      &   ) cycle
12591           vectube(1)=c(1,i+nres)
12592           vectube(1)=mod(vectube(1),boxxsize)
12593           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12594           vectube(2)=c(2,i+nres)
12595           vectube(2)=mod(vectube(2),boxxsize)
12596           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12597
12598       vectube(1)=vectube(1)-tubecenter(1)
12599       vectube(2)=vectube(2)-tubecenter(2)
12600 C THIS FRAGMENT MAKES TUBE FINITE
12601         positi=(mod(c(3,i+nres),boxzsize))
12602         if (positi.le.0) positi=positi+boxzsize
12603 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12604 c for each residue check if it is in lipid or lipid water border area
12605 C       respos=mod(c(3,i+nres),boxzsize)
12606        print *,positi,bordtubebot,buftubebot,bordtubetop
12607        if ((positi.gt.bordtubebot)
12608      & .and.(positi.lt.bordtubetop)) then
12609 C the energy transfer exist
12610         if (positi.lt.buftubebot) then
12611          fracinbuf=1.0d0-
12612      &     ((positi-bordtubebot)/tubebufthick)
12613 C lipbufthick is thickenes of lipid buffore
12614          sstube=sscalelip(fracinbuf)
12615          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12616          print *,ssgradtube, sstube,tubetranene(itype(i))
12617          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12618          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12619      &+ssgradtube*tubetranene(itype(i))
12620          gg_tube(3,i-1)= gg_tube(3,i-1)
12621      &+ssgradtube*tubetranene(itype(i))
12622 C         print *,"doing sccale for lower part"
12623         elseif (positi.gt.buftubetop) then
12624          fracinbuf=1.0d0-
12625      &((bordtubetop-positi)/tubebufthick)
12626          sstube=sscalelip(fracinbuf)
12627          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12628          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12629 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12630 C     &+ssgradtube*tubetranene(itype(i))
12631 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12632 C     &+ssgradtube*tubetranene(itype(i))
12633 C          print *, "doing sscalefor top part",sslip,fracinbuf
12634         else
12635          sstube=1.0d0
12636          ssgradtube=0.0d0
12637          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12638 C         print *,"I am in true lipid"
12639         endif
12640         else
12641 C          sstube=0.0d0
12642 C          ssgradtube=0.0d0
12643         cycle
12644         endif ! if in lipid or buffor
12645 CEND OF FINITE FRAGMENT
12646 C as the tube is infinity we do not calculate the Z-vector use of Z
12647 C as chosen axis
12648       vectube(3)=0.0d0
12649 C now calculte the distance
12650        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12651 C now normalize vector
12652       vectube(1)=vectube(1)/tub_r
12653       vectube(2)=vectube(2)/tub_r
12654 C calculte rdiffrence between r and r0
12655       rdiff=tub_r-tubeR0
12656 C and its 6 power
12657       rdiff6=rdiff**6.0d0
12658 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12659        sc_aa_tube=sc_aa_tube_par(iti)
12660        sc_bb_tube=sc_bb_tube_par(iti)
12661        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12662      &                 *sstube+enetube(i+nres)
12663 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12664 C now we calculate gradient
12665        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12666      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12667 C now direction of gg_tube vector
12668          do j=1,3
12669           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12670           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12671          enddo
12672          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12673      &+ssgradtube*enetube(i+nres)/sstube
12674          gg_tube(3,i-1)= gg_tube(3,i-1)
12675      &+ssgradtube*enetube(i+nres)/sstube
12676
12677         enddo
12678         do i=1,2*nres
12679           Etube=Etube+enetube(i)
12680         enddo
12681 C        print *,"ETUBE", etube
12682         return
12683         end
12684 C TO DO 1) add to total energy
12685 C       2) add to gradient summation
12686 C       3) add reading parameters (AND of course oppening of PARAM file)
12687 C       4) add reading the center of tube
12688 C       5) add COMMONs
12689 C       6) add to zerograd
12690 c----------------------------------------------------------------------------
12691       subroutine e_saxs(Esaxs_constr)
12692       implicit none
12693       include 'DIMENSIONS'
12694 #ifdef MPI
12695       include "mpif.h"
12696       include "COMMON.SETUP"
12697       integer IERR
12698 #endif
12699       include 'COMMON.SBRIDGE'
12700       include 'COMMON.CHAIN'
12701       include 'COMMON.GEO'
12702       include 'COMMON.DERIV'
12703       include 'COMMON.LOCAL'
12704       include 'COMMON.INTERACT'
12705       include 'COMMON.VAR'
12706       include 'COMMON.IOUNITS'
12707 c      include 'COMMON.MD'
12708 #ifdef LANG0
12709 #ifdef FIVEDIAG
12710       include 'COMMON.LANGEVIN.lang0.5diag'
12711 #else
12712       include 'COMMON.LANGEVIN.lang0'
12713 #endif
12714 #else
12715       include 'COMMON.LANGEVIN'
12716 #endif
12717       include 'COMMON.CONTROL'
12718       include 'COMMON.SAXS'
12719       include 'COMMON.NAMES'
12720       include 'COMMON.TIME1'
12721       include 'COMMON.FFIELD'
12722 c
12723       double precision Esaxs_constr
12724       integer i,iint,j,k,l
12725       double precision PgradC(maxSAXS,3,maxres),
12726      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12727 #ifdef MPI
12728       double precision PgradC_(maxSAXS,3,maxres),
12729      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12730 #endif
12731       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12732      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12733      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12734      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12735       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12736       double precision dist,mygauss,mygaussder
12737       external dist
12738       integer llicz,lllicz
12739       double precision time01
12740 c  SAXS restraint penalty function
12741 #ifdef DEBUG
12742       write(iout,*) "------- SAXS penalty function start -------"
12743       write (iout,*) "nsaxs",nsaxs
12744       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12745       write (iout,*) "Psaxs"
12746       do i=1,nsaxs
12747         write (iout,'(i5,e15.5)') i, Psaxs(i)
12748       enddo
12749 #endif
12750 #ifdef TIMING
12751       time01=MPI_Wtime()
12752 #endif
12753       Esaxs_constr = 0.0d0
12754       do k=1,nsaxs
12755         Pcalc(k)=0.0d0
12756         do j=1,nres
12757           do l=1,3
12758             PgradC(k,l,j)=0.0d0
12759             PgradX(k,l,j)=0.0d0
12760           enddo
12761         enddo
12762       enddo
12763 c      lllicz=0
12764       do i=iatsc_s,iatsc_e
12765        if (itype(i).eq.ntyp1) cycle
12766        do iint=1,nint_gr(i)
12767          do j=istart(i,iint),iend(i,iint)
12768            if (itype(j).eq.ntyp1) cycle
12769 #ifdef ALLSAXS
12770            dijCACA=dist(i,j)
12771            dijCASC=dist(i,j+nres)
12772            dijSCCA=dist(i+nres,j)
12773            dijSCSC=dist(i+nres,j+nres)
12774            sigma2CACA=2.0d0/(pstok**2)
12775            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12776            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12777            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12778            do k=1,nsaxs
12779              dk = distsaxs(k)
12780              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12781              if (itype(j).ne.10) then
12782              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12783              else
12784              endif
12785              expCASC = 0.0d0
12786              if (itype(i).ne.10) then
12787              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12788              else
12789              expSCCA = 0.0d0
12790              endif
12791              if (itype(i).ne.10 .and. itype(j).ne.10) then
12792              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12793              else
12794              expSCSC = 0.0d0
12795              endif
12796              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12797 #ifdef DEBUG
12798              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12799 #endif
12800              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12801              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12802              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12803              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12804              do l=1,3
12805 c CA CA
12806                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12807                PgradC(k,l,i) = PgradC(k,l,i)-aux
12808                PgradC(k,l,j) = PgradC(k,l,j)+aux
12809 c CA SC
12810                if (itype(j).ne.10) then
12811                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12812                PgradC(k,l,i) = PgradC(k,l,i)-aux
12813                PgradC(k,l,j) = PgradC(k,l,j)+aux
12814                PgradX(k,l,j) = PgradX(k,l,j)+aux
12815                endif
12816 c SC CA
12817                if (itype(i).ne.10) then
12818                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12819                PgradX(k,l,i) = PgradX(k,l,i)-aux
12820                PgradC(k,l,i) = PgradC(k,l,i)-aux
12821                PgradC(k,l,j) = PgradC(k,l,j)+aux
12822                endif
12823 c SC SC
12824                if (itype(i).ne.10 .and. itype(j).ne.10) then
12825                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12826                PgradC(k,l,i) = PgradC(k,l,i)-aux
12827                PgradC(k,l,j) = PgradC(k,l,j)+aux
12828                PgradX(k,l,i) = PgradX(k,l,i)-aux
12829                PgradX(k,l,j) = PgradX(k,l,j)+aux
12830                endif
12831              enddo ! l
12832            enddo ! k
12833 #else
12834            dijCACA=dist(i,j)
12835            sigma2CACA=scal_rad**2*0.25d0/
12836      &        (restok(itype(j))**2+restok(itype(i))**2)
12837 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12838 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12839 #ifdef MYGAUSS
12840            sigmaCACA=dsqrt(sigma2CACA)
12841            threesig=3.0d0/sigmaCACA
12842 c           llicz=0
12843            do k=1,nsaxs
12844              dk = distsaxs(k)
12845              if (dabs(dijCACA-dk).ge.threesig) cycle
12846 c             llicz=llicz+1
12847 c             lllicz=lllicz+1
12848              aux = sigmaCACA*(dijCACA-dk)
12849              expCACA = mygauss(aux)
12850 c             if (expcaca.eq.0.0d0) cycle
12851              Pcalc(k) = Pcalc(k)+expCACA
12852              CACAgrad = -sigmaCACA*mygaussder(aux)
12853 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12854              do l=1,3
12855                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12856                PgradC(k,l,i) = PgradC(k,l,i)-aux
12857                PgradC(k,l,j) = PgradC(k,l,j)+aux
12858              enddo ! l
12859            enddo ! k
12860 c           write (iout,*) "i",i," j",j," llicz",llicz
12861 #else
12862            IF (saxs_cutoff.eq.0) THEN
12863            do k=1,nsaxs
12864              dk = distsaxs(k)
12865              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12866              Pcalc(k) = Pcalc(k)+expCACA
12867              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12868              do l=1,3
12869                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12870                PgradC(k,l,i) = PgradC(k,l,i)-aux
12871                PgradC(k,l,j) = PgradC(k,l,j)+aux
12872              enddo ! l
12873            enddo ! k
12874            ELSE
12875            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12876            do k=1,nsaxs
12877              dk = distsaxs(k)
12878 c             write (2,*) "ijk",i,j,k
12879              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12880              if (sss2.eq.0.0d0) cycle
12881              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12882              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12883      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12884      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12885      &           sss2,ssgrad2
12886              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12887              Pcalc(k) = Pcalc(k)+expCACA
12888 #ifdef DEBUG
12889              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12890 #endif
12891              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12892      &             ssgrad2*expCACA/sss2
12893              do l=1,3
12894 c CA CA
12895                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12896                PgradC(k,l,i) = PgradC(k,l,i)+aux
12897                PgradC(k,l,j) = PgradC(k,l,j)-aux
12898              enddo ! l
12899            enddo ! k
12900            ENDIF
12901 #endif
12902 #endif
12903          enddo ! j
12904        enddo ! iint
12905       enddo ! i
12906 c#ifdef TIMING
12907 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12908 c#endif
12909 c      write (iout,*) "lllicz",lllicz
12910 c#ifdef TIMING
12911 c      time01=MPI_Wtime()
12912 c#endif
12913 #ifdef MPI
12914       if (nfgtasks.gt.1) then
12915        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12916      &    MPI_SUM,FG_COMM,IERR)
12917 c        if (fg_rank.eq.king) then
12918           do k=1,nsaxs
12919             Pcalc(k) = Pcalc_(k)
12920           enddo
12921 c        endif
12922 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12923 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12924 c        if (fg_rank.eq.king) then
12925 c          do i=1,nres
12926 c            do l=1,3
12927 c              do k=1,nsaxs
12928 c                PgradC(k,l,i) = PgradC_(k,l,i)
12929 c              enddo
12930 c            enddo
12931 c          enddo
12932 c        endif
12933 #ifdef ALLSAXS
12934 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12935 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12936 c        if (fg_rank.eq.king) then
12937 c          do i=1,nres
12938 c            do l=1,3
12939 c              do k=1,nsaxs
12940 c                PgradX(k,l,i) = PgradX_(k,l,i)
12941 c              enddo
12942 c            enddo
12943 c          enddo
12944 c        endif
12945 #endif
12946       endif
12947 #endif
12948       Cnorm = 0.0d0
12949       do k=1,nsaxs
12950         Cnorm = Cnorm + Pcalc(k)
12951       enddo
12952 #ifdef MPI
12953       if (fg_rank.eq.king) then
12954 #endif
12955       Esaxs_constr = dlog(Cnorm)-wsaxs0
12956       do k=1,nsaxs
12957         if (Pcalc(k).gt.0.0d0)
12958      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12959 #ifdef DEBUG
12960         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12961 #endif
12962       enddo
12963 #ifdef DEBUG
12964       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12965 #endif
12966 #ifdef MPI
12967       endif
12968 #endif
12969       gsaxsC=0.0d0
12970       gsaxsX=0.0d0
12971       do i=nnt,nct
12972         do l=1,3
12973           auxC=0.0d0
12974           auxC1=0.0d0
12975           auxX=0.0d0
12976           auxX1=0.d0
12977           do k=1,nsaxs
12978             if (Pcalc(k).gt.0)
12979      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12980             auxC1 = auxC1+PgradC(k,l,i)
12981 #ifdef ALLSAXS
12982             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12983             auxX1 = auxX1+PgradX(k,l,i)
12984 #endif
12985           enddo
12986           gsaxsC(l,i) = auxC - auxC1/Cnorm
12987 #ifdef ALLSAXS
12988           gsaxsX(l,i) = auxX - auxX1/Cnorm
12989 #endif
12990 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12991 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12992 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12993 c     *     " gradX",wsaxs*gsaxsX(l,i)
12994         enddo
12995       enddo
12996 #ifdef TIMING
12997       time_SAXS=time_SAXS+MPI_Wtime()-time01
12998 #endif
12999 #ifdef DEBUG
13000       write (iout,*) "gsaxsc"
13001       do i=nnt,nct
13002         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13003       enddo
13004 #endif
13005 #ifdef MPI
13006 c      endif
13007 #endif
13008       return
13009       end
13010 c----------------------------------------------------------------------------
13011       subroutine e_saxsC(Esaxs_constr)
13012       implicit none
13013       include 'DIMENSIONS'
13014 #ifdef MPI
13015       include "mpif.h"
13016       include "COMMON.SETUP"
13017       integer IERR
13018 #endif
13019       include 'COMMON.SBRIDGE'
13020       include 'COMMON.CHAIN'
13021       include 'COMMON.GEO'
13022       include 'COMMON.DERIV'
13023       include 'COMMON.LOCAL'
13024       include 'COMMON.INTERACT'
13025       include 'COMMON.VAR'
13026       include 'COMMON.IOUNITS'
13027 c      include 'COMMON.MD'
13028 #ifdef LANG0
13029 #ifdef FIVEDIAG
13030       include 'COMMON.LANGEVIN.lang0.5diag'
13031 #else
13032       include 'COMMON.LANGEVIN.lang0'
13033 #endif
13034 #else
13035       include 'COMMON.LANGEVIN'
13036 #endif
13037       include 'COMMON.CONTROL'
13038       include 'COMMON.SAXS'
13039       include 'COMMON.NAMES'
13040       include 'COMMON.TIME1'
13041       include 'COMMON.FFIELD'
13042 c
13043       double precision Esaxs_constr
13044       integer i,iint,j,k,l
13045       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13046 #ifdef MPI
13047       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13048 #endif
13049       double precision dk,dijCASPH,dijSCSPH,
13050      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13051      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13052      & auxX,auxX1,Cnorm
13053 c  SAXS restraint penalty function
13054 #ifdef DEBUG
13055       write(iout,*) "------- SAXS penalty function start -------"
13056       write (iout,*) "nsaxs",nsaxs
13057
13058       do i=nnt,nct
13059         print *,MyRank,"C",i,(C(j,i),j=1,3)
13060       enddo
13061       do i=nnt,nct
13062         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13063       enddo
13064 #endif
13065       Esaxs_constr = 0.0d0
13066       logPtot=0.0d0
13067       do j=isaxs_start,isaxs_end
13068         Pcalc=0.0d0
13069         do i=1,nres
13070           do l=1,3
13071             PgradC(l,i)=0.0d0
13072             PgradX(l,i)=0.0d0
13073           enddo
13074         enddo
13075         do i=nnt,nct
13076           if (itype(i).eq.ntyp1) cycle
13077           dijCASPH=0.0d0
13078           dijSCSPH=0.0d0
13079           do l=1,3
13080             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13081           enddo
13082           if (itype(i).ne.10) then
13083           do l=1,3
13084             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13085           enddo
13086           endif
13087           sigma2CA=2.0d0/pstok**2
13088           sigma2SC=4.0d0/restok(itype(i))**2
13089           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13090           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13091           Pcalc = Pcalc+expCASPH+expSCSPH
13092 #ifdef DEBUG
13093           write(*,*) "processor i j Pcalc",
13094      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13095 #endif
13096           CASPHgrad = sigma2CA*expCASPH
13097           SCSPHgrad = sigma2SC*expSCSPH
13098           do l=1,3
13099             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13100             PgradX(l,i) = PgradX(l,i) + aux
13101             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13102           enddo ! l
13103         enddo ! i
13104         do i=nnt,nct
13105           do l=1,3
13106             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13107             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13108           enddo
13109         enddo
13110         logPtot = logPtot - dlog(Pcalc)
13111 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13112 c     &    " logPtot",logPtot
13113       enddo ! j
13114 #ifdef MPI
13115       if (nfgtasks.gt.1) then
13116 c        write (iout,*) "logPtot before reduction",logPtot
13117         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13118      &    MPI_SUM,king,FG_COMM,IERR)
13119         logPtot = logPtot_
13120 c        write (iout,*) "logPtot after reduction",logPtot
13121         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13122      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13123         if (fg_rank.eq.king) then
13124           do i=1,nres
13125             do l=1,3
13126               gsaxsC(l,i) = gsaxsC_(l,i)
13127             enddo
13128           enddo
13129         endif
13130         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13131      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13132         if (fg_rank.eq.king) then
13133           do i=1,nres
13134             do l=1,3
13135               gsaxsX(l,i) = gsaxsX_(l,i)
13136             enddo
13137           enddo
13138         endif
13139       endif
13140 #endif
13141       Esaxs_constr = logPtot
13142       return
13143       end
13144 c----------------------------------------------------------------------------
13145       double precision function sscale2(r,r_cut,r0,rlamb)
13146       implicit none
13147       double precision r,gamm,r_cut,r0,rlamb,rr
13148       rr = dabs(r-r0)
13149 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13150 c      write (2,*) "rr",rr
13151       if(rr.lt.r_cut-rlamb) then
13152         sscale2=1.0d0
13153       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13154         gamm=(rr-(r_cut-rlamb))/rlamb
13155         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13156       else
13157         sscale2=0d0
13158       endif
13159       return
13160       end
13161 C-----------------------------------------------------------------------
13162       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13163       implicit none
13164       double precision r,gamm,r_cut,r0,rlamb,rr
13165       rr = dabs(r-r0)
13166       if(rr.lt.r_cut-rlamb) then
13167         sscalgrad2=0.0d0
13168       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13169         gamm=(rr-(r_cut-rlamb))/rlamb
13170         if (r.ge.r0) then
13171           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13172         else
13173           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13174         endif
13175       else
13176         sscalgrad2=0.0d0
13177       endif
13178       return
13179       end
13180 c------------------------------------------------------------------------
13181       double precision function boxshift(x,boxsize)
13182       implicit none
13183       double precision x,boxsize
13184       double precision xtemp
13185       xtemp=dmod(x,boxsize)
13186       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13187         boxshift=xtemp-boxsize
13188       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13189         boxshift=xtemp+boxsize
13190       else
13191         boxshift=xtemp
13192       endif
13193       return
13194       end
13195 c--------------------------------------------------------------------------
13196       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13197       include 'DIMENSIONS'
13198       include 'COMMON.CHAIN'
13199       integer xshift,yshift,zshift,subchap
13200       double precision dist_init,xj_safe,yj_safe,zj_safe,
13201      & xj_temp,yj_temp,zj_temp,dist_temp
13202       xj_safe=xj
13203       yj_safe=yj
13204       zj_safe=zj
13205       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13206       subchap=0
13207       do xshift=-1,1
13208         do yshift=-1,1
13209           do zshift=-1,1
13210             xj=xj_safe+xshift*boxxsize
13211             yj=yj_safe+yshift*boxysize
13212             zj=zj_safe+zshift*boxzsize
13213             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13214             if(dist_temp.lt.dist_init) then
13215               dist_init=dist_temp
13216               xj_temp=xj
13217               yj_temp=yj
13218               zj_temp=zj
13219               subchap=1
13220             endif
13221           enddo
13222         enddo
13223       enddo
13224       if (subchap.eq.1) then
13225         xj=xj_temp-xi
13226         yj=yj_temp-yi
13227         zj=zj_temp-zi
13228       else
13229         xj=xj_safe-xi
13230         yj=yj_safe-yi
13231         zj=zj_safe-zi
13232       endif
13233       return
13234       end
13235 c--------------------------------------------------------------------------
13236       subroutine to_box(xi,yi,zi)
13237       implicit none
13238       include 'DIMENSIONS'
13239       include 'COMMON.CHAIN'
13240       double precision xi,yi,zi
13241       xi=dmod(xi,boxxsize)
13242       if (xi.lt.0.0d0) xi=xi+boxxsize
13243       yi=dmod(yi,boxysize)
13244       if (yi.lt.0.0d0) yi=yi+boxysize
13245       zi=dmod(zi,boxzsize)
13246       if (zi.lt.0.0d0) zi=zi+boxzsize
13247       return
13248       end
13249 c--------------------------------------------------------------------------
13250       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13251       implicit none
13252       include 'DIMENSIONS'
13253       include 'COMMON.CHAIN'
13254       double precision xi,yi,zi,sslipi,ssgradlipi
13255       double precision fracinbuf
13256       double precision sscalelip,sscagradlip
13257
13258       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13259 C the energy transfer exist
13260         if (zi.lt.buflipbot) then
13261 C what fraction I am in
13262           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13263 C lipbufthick is thickenes of lipid buffore
13264           sslipi=sscalelip(fracinbuf)
13265           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13266         elseif (zi.gt.bufliptop) then
13267           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13268           sslipi=sscalelip(fracinbuf)
13269           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13270         else
13271           sslipi=1.0d0
13272           ssgradlipi=0.0
13273         endif
13274       else
13275         sslipi=0.0d0
13276         ssgradlipi=0.0
13277       endif
13278       return
13279       end