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 #ifndef DFA
 116       edfadis=0.0d0
 117       edfator=0.0d0
 118       edfanei=0.0d0
 119       edfabet=0.0d0
 120 #endif
 121       if (nfgtasks.gt.1) then
 122         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 123       endif
 124       if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 125       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 126       if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 127 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 128 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 129 #else
 130 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 131 c        call int_from_cart1(.false.)
 132 c      endif
 133 #endif
 134 #ifdef TIMING
 135       time00=MPI_Wtime()
 136 #endif
 137 C
 138 C Compute the side-chain and electrostatic interaction energy
 139 C
 140 C      print *,ipot
 141       goto (101,102,103,104,105,106) ipot
 142 C Lennard-Jones potential.
 143   101 call elj(evdw)
 144 cd    print '(a)','Exit ELJ'
 145       goto 107
 146 C Lennard-Jones-Kihara potential (shifted).
 147   102 call eljk(evdw)
 148       goto 107
 149 C Berne-Pechukas potential (dilated LJ, angular dependence).
 150   103 call ebp(evdw)
 151       goto 107
 152 C Gay-Berne potential (shifted LJ, angular dependence).
 153   104 call egb(evdw)
 154 C      print *,"bylem w egb"
 155       goto 107
 156 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 157   105 call egbv(evdw)
 158       goto 107
 159 C Soft-sphere potential
 160   106 call e_softsphere(evdw)
 161 C
 162 C Calculate electrostatic (H-bonding) energy of the main chain.
 163 C
 164   107 continue
 165 #ifdef DFA
 166 C     BARTEK for dfa test!
 167       if (wdfa_dist.gt.0) then
 168         call edfad(edfadis)
 169       else
 170         edfadis=0
 171       endif
 172 c      print*, 'edfad is finished!', edfadis
 173       if (wdfa_tor.gt.0) then
 174         call edfat(edfator)
 175       else
 176         edfator=0
 177       endif
 178 c      print*, 'edfat is finished!', edfator
 179       if (wdfa_nei.gt.0) then
 180         call edfan(edfanei)
 181       else
 182         edfanei=0
 183       endif
 184 c      print*, 'edfan is finished!', edfanei
 185       if (wdfa_beta.gt.0) then
 186         call edfab(edfabet)
 187       else
 188         edfabet=0
 189       endif
 190 #endif
 191 cmc
 192 cmc Sep-06: egb takes care of dynamic ss bonds too
 193 cmc
 194 c      if (dyn_ss) call dyn_set_nss
 195
 196 c      print *,"Processor",myrank," computed USCSC"
 197 #ifdef TIMING
 198       time01=MPI_Wtime()
 199 #endif
 200       call vec_and_deriv
 201 #ifdef TIMING
 202       time_vec=time_vec+MPI_Wtime()-time01
 203 #endif
 204 C Introduction of shielding effect first for each peptide group
 205 C the shielding factor is set this factor is describing how each
 206 C peptide group is shielded by side-chains
 207 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 208 C      write (iout,*) "shield_mode",shield_mode
 209       if (shield_mode.eq.1) then
 210        call set_shield_fac
 211       else if  (shield_mode.eq.2) then
 212        call set_shield_fac2
 213       endif
 214 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 215       if (ipot.lt.6) then
 216 #ifdef SPLITELE
 217          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 218      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 219      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 220      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 221 #else
 222          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 223      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 224      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 225      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 226 #endif
 227             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 228          else
 229             ees=0.0d0
 230             evdw1=0.0d0
 231             eel_loc=0.0d0
 232             eello_turn3=0.0d0
 233             eello_turn4=0.0d0
 234          endif
 235       else
 236         write (iout,*) "Soft-spheer ELEC potential"
 237 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 238 c     &   eello_turn4)
 239       endif
 240 c#ifdef TIMING
 241 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 242 c#endif
 243 c      print *,"Processor",myrank," computed UELEC"
 244 C
 245 C Calculate excluded-volume interaction energy between peptide groups
 246 C and side chains.
 247 C
 248       if (ipot.lt.6) then
 249        if(wscp.gt.0d0) then
 250         call escp(evdw2,evdw2_14)
 251        else
 252         evdw2=0
 253         evdw2_14=0
 254        endif
 255       else
 256 c        write (iout,*) "Soft-sphere SCP potential"
 257         call escp_soft_sphere(evdw2,evdw2_14)
 258       endif
 259 c
 260 c Calculate the bond-stretching energy
 261 c
 262       call ebond(estr)
 263 C
 264 C Calculate the disulfide-bridge and other energy and the contributions
 265 C from other distance constraints.
 266 cd      write (iout,*) 'Calling EHPB'
 267       call edis(ehpb)
 268 cd    print *,'EHPB exitted succesfully.'
 269 C
 270 C Calculate the virtual-bond-angle energy.
 271 C
 272       if (wang.gt.0d0) then
 273        if (tor_mode.eq.0) then
 274          call ebend(ebe)
 275        else
 276 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 277 C energy function
 278          call ebend_kcc(ebe)
 279        endif
 280       else
 281         ebe=0.0d0
 282       endif
 283       ethetacnstr=0.0d0
 284       if (with_theta_constr) call etheta_constr(ethetacnstr)
 285 c      print *,"Processor",myrank," computed UB"
 286 C
 287 C Calculate the SC local energy.
 288 C
 289 C      print *,"TU DOCHODZE?"
 290       call esc(escloc)
 291 c      print *,"Processor",myrank," computed USC"
 292 C
 293 C Calculate the virtual-bond torsional energy.
 294 C
 295 cd    print *,'nterm=',nterm
 296 C      print *,"tor",tor_mode
 297       if (wtor.gt.0.0d0) then
 298          if (tor_mode.eq.0) then
 299            call etor(etors)
 300          else
 301 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 302 C energy function
 303            call etor_kcc(etors)
 304          endif
 305       else
 306         etors=0.0d0
 307       endif
 308       edihcnstr=0.0d0
 309       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 310 c      print *,"Processor",myrank," computed Utor"
 311       if (constr_homology.ge.1) then
 312         call e_modeller(ehomology_constr)
 313 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 314 c     &  'Processor',fg_rank,' CG group',kolor,
 315 c     &  ' absolute rank',MyRank
 316       else
 317         ehomology_constr=0.0d0
 318       endif
 319 C
 320 C 6/23/01 Calculate double-torsional energy
 321 C
 322       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 323         call etor_d(etors_d)
 324       else
 325         etors_d=0
 326       endif
 327 c      print *,"Processor",myrank," computed Utord"
 328 C
 329 C 21/5/07 Calculate local sicdechain correlation energy
 330 C
 331       if (wsccor.gt.0.0d0) then
 332         call eback_sc_corr(esccor)
 333       else
 334         esccor=0.0d0
 335       endif
 336 #ifdef FOURBODY
 337 C      print *,"PRZED MULIt"
 338 c      print *,"Processor",myrank," computed Usccorr"
 339 C
 340 C 12/1/95 Multi-body terms
 341 C
 342       n_corr=0
 343       n_corr1=0
 344       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 345      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 346          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 347 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 348 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 349 c        call flush(iout)
 350       else
 351          ecorr=0.0d0
 352          ecorr5=0.0d0
 353          ecorr6=0.0d0
 354          eturn6=0.0d0
 355       endif
 356       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 357 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 358 c     &     n_corr,n_corr1
 359 c         call flush(iout)
 360          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 361 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 362 c     &     n_corr1
 363 c         call flush(iout)
 364       endif
 365 #endif
 366 c      print *,"Processor",myrank," computed Ucorr"
 367 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 368       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 369         call e_saxs(Esaxs_constr)
 370 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 371       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 372         call e_saxsC(Esaxs_constr)
 373 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 374       else
 375         Esaxs_constr = 0.0d0
 376       endif
 377 C
 378 C If performing constraint dynamics, call the constraint energy
 379 C  after the equilibration time
 380 c      if(usampl.and.totT.gt.eq_time) then
 381 c      write (iout,*) "usampl",usampl
 382       if(usampl) then
 383          call EconstrQ
 384          if (loc_qlike) then
 385            call Econstr_back_qlike
 386          else
 387            call Econstr_back
 388          endif
 389       else
 390          Uconst=0.0d0
 391          Uconst_back=0.0d0
 392       endif
 393 C 01/27/2015 added by adasko
 394 C the energy component below is energy transfer into lipid environment
 395 C based on partition function
 396 C      print *,"przed lipidami"
 397       if (wliptran.gt.0) then
 398         call Eliptransfer(eliptran)
 399       else
 400         eliptran=0.0d0
 401       endif
 402 C      print *,"za lipidami"
 403       if (AFMlog.gt.0) then
 404         call AFMforce(Eafmforce)
 405       else if (selfguide.gt.0) then
 406         call AFMvel(Eafmforce)
 407       endif
 408       if (TUBElog.eq.1) then
 409 C      print *,"just before call"
 410         call calctube(Etube)
 411        elseif (TUBElog.eq.2) then
 412         call calctube2(Etube)
 413        else
 414        Etube=0.0d0
 415        endif
 416
 417 #ifdef TIMING
 418       time_enecalc=time_enecalc+MPI_Wtime()-time00
 419 #endif
 420 c      print *,"Processor",myrank," computed Uconstr"
 421 #ifdef TIMING
 422       time00=MPI_Wtime()
 423 #endif
 424 c
 425 C Sum the energies
 426 C
 427       energia(1)=evdw
 428 #ifdef SCP14
 429       energia(2)=evdw2-evdw2_14
 430       energia(18)=evdw2_14
 431 #else
 432       energia(2)=evdw2
 433       energia(18)=0.0d0
 434 #endif
 435 #ifdef SPLITELE
 436       energia(3)=ees
 437       energia(16)=evdw1
 438 #else
 439       energia(3)=ees+evdw1
 440       energia(16)=0.0d0
 441 #endif
 442       energia(4)=ecorr
 443       energia(5)=ecorr5
 444       energia(6)=ecorr6
 445       energia(7)=eel_loc
 446       energia(8)=eello_turn3
 447       energia(9)=eello_turn4
 448       energia(10)=eturn6
 449       energia(11)=ebe
 450       energia(12)=escloc
 451       energia(13)=etors
 452       energia(14)=etors_d
 453       energia(15)=ehpb
 454       energia(19)=edihcnstr
 455       energia(17)=estr
 456       energia(20)=Uconst+Uconst_back
 457       energia(21)=esccor
 458       energia(22)=eliptran
 459       energia(23)=Eafmforce
 460       energia(24)=ethetacnstr
 461       energia(25)=Etube
 462       energia(26)=Esaxs_constr
 463       energia(27)=ehomology_constr
 464       energia(28)=edfadis
 465       energia(29)=edfator
 466       energia(30)=edfanei
 467       energia(31)=edfabet
 468 c      write (iout,*) "esaxs_constr",energia(26)
 469 c    Here are the energies showed per procesor if the are more processors
 470 c    per molecule then we sum it up in sum_energy subroutine
 471 c      print *," Processor",myrank," calls SUM_ENERGY"
 472       call sum_energy(energia,.true.)
 473 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 474       if (dyn_ss) call dyn_set_nss
 475 c      print *," Processor",myrank," left SUM_ENERGY"
 476 #ifdef TIMING
 477       time_sumene=time_sumene+MPI_Wtime()-time00
 478 #endif
 479       return
 480       end
 481 c-------------------------------------------------------------------------------
 482       subroutine sum_energy(energia,reduce)
 483       implicit none
 484       include 'DIMENSIONS'
 485 #ifndef ISNAN
 486       external proc_proc
 487 #ifdef WINPGI
 488 cMS$ATTRIBUTES C ::  proc_proc
 489 #endif
 490 #endif
 491 #ifdef MPI
 492       include "mpif.h"
 493       integer ierr
 494       double precision time00
 495 #endif
 496       include 'COMMON.SETUP'
 497       include 'COMMON.IOUNITS'
 498       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 499       include 'COMMON.FFIELD'
 500       include 'COMMON.DERIV'
 501       include 'COMMON.INTERACT'
 502       include 'COMMON.SBRIDGE'
 503       include 'COMMON.CHAIN'
 504       include 'COMMON.VAR'
 505       include 'COMMON.CONTROL'
 506       include 'COMMON.TIME1'
 507       logical reduce
 508       integer i
 509       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 510      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 511      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 512      & eliptran,Eafmforce,Etube,
 513      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 514       double precision Uconst,etot
 515 #ifdef MPI
 516       if (nfgtasks.gt.1 .and. reduce) then
 517 #ifdef DEBUG
 518         write (iout,*) "energies before REDUCE"
 519         call enerprint(energia)
 520         call flush(iout)
 521 #endif
 522         do i=0,n_ene
 523           enebuff(i)=energia(i)
 524         enddo
 525         time00=MPI_Wtime()
 526         call MPI_Barrier(FG_COMM,IERR)
 527         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 528         time00=MPI_Wtime()
 529         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 530      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 531 #ifdef DEBUG
 532         write (iout,*) "energies after REDUCE"
 533         call enerprint(energia)
 534         call flush(iout)
 535 #endif
 536         time_Reduce=time_Reduce+MPI_Wtime()-time00
 537       endif
 538       if (fg_rank.eq.0) then
 539 #endif
 540       evdw=energia(1)
 541 #ifdef SCP14
 542       evdw2=energia(2)+energia(18)
 543       evdw2_14=energia(18)
 544 #else
 545       evdw2=energia(2)
 546 #endif
 547 #ifdef SPLITELE
 548       ees=energia(3)
 549       evdw1=energia(16)
 550 #else
 551       ees=energia(3)
 552       evdw1=0.0d0
 553 #endif
 554       ecorr=energia(4)
 555       ecorr5=energia(5)
 556       ecorr6=energia(6)
 557       eel_loc=energia(7)
 558       eello_turn3=energia(8)
 559       eello_turn4=energia(9)
 560       eturn6=energia(10)
 561       ebe=energia(11)
 562       escloc=energia(12)
 563       etors=energia(13)
 564       etors_d=energia(14)
 565       ehpb=energia(15)
 566       edihcnstr=energia(19)
 567       estr=energia(17)
 568       Uconst=energia(20)
 569       esccor=energia(21)
 570       eliptran=energia(22)
 571       Eafmforce=energia(23)
 572       ethetacnstr=energia(24)
 573       Etube=energia(25)
 574       esaxs_constr=energia(26)
 575       ehomology_constr=energia(27)
 576       edfadis=energia(28)
 577       edfator=energia(29)
 578       edfanei=energia(30)
 579       edfabet=energia(31)
 580 #ifdef SPLITELE
 581       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 582      & +wang*ebe+wtor*etors+wscloc*escloc
 583      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 584      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 585      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 586      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 587      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 588      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 589      & +wdfa_beta*edfabet
 590 #else
 591       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 592      & +wang*ebe+wtor*etors+wscloc*escloc
 593      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 594      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 595      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 596      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 597      & +Eafmforce
 598      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 599      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 600      & +wdfa_beta*edfabet
 601 #endif
 602       energia(0)=etot
 603 c detecting NaNQ
 604 #ifdef ISNAN
 605 #ifdef AIX
 606       if (isnan(etot).ne.0) energia(0)=1.0d+99
 607 #else
 608       if (isnan(etot)) energia(0)=1.0d+99
 609 #endif
 610 #else
 611       i=0
 612 #ifdef WINPGI
 613       idumm=proc_proc(etot,i)
 614 #else
 615       call proc_proc(etot,i)
 616 #endif
 617       if(i.eq.1)energia(0)=1.0d+99
 618 #endif
 619 #ifdef MPI
 620       endif
 621 #endif
 622       return
 623       end
 624 c-------------------------------------------------------------------------------
 625       subroutine sum_gradient
 626       implicit none
 627       include 'DIMENSIONS'
 628 #ifndef ISNAN
 629       external proc_proc
 630 #ifdef WINPGI
 631 cMS$ATTRIBUTES C ::  proc_proc
 632 #endif
 633 #endif
 634 #ifdef MPI
 635       include 'mpif.h'
 636       integer ierror,ierr
 637       double precision time00,time01
 638 #endif
 639       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 640      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 641      & ,gloc_scbuf(3,-1:maxres)
 642       include 'COMMON.SETUP'
 643       include 'COMMON.IOUNITS'
 644       include 'COMMON.FFIELD'
 645       include 'COMMON.DERIV'
 646       include 'COMMON.INTERACT'
 647       include 'COMMON.SBRIDGE'
 648       include 'COMMON.CHAIN'
 649       include 'COMMON.VAR'
 650       include 'COMMON.CONTROL'
 651       include 'COMMON.TIME1'
 652       include 'COMMON.MAXGRAD'
 653       include 'COMMON.SCCOR'
 654 c      include 'COMMON.MD'
 655       include 'COMMON.QRESTR'
 656       integer i,j,k
 657       double precision scalar
 658       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 659      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 660      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 661      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 662      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 663      &gsclocx_norm
 664 #ifdef TIMING
 665       time01=MPI_Wtime()
 666 #endif
 667 #ifdef DEBUG
 668       write (iout,*) "sum_gradient gvdwc, gvdwx"
 669       do i=1,nres
 670         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 671      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 672       enddo
 673       call flush(iout)
 674 #endif
 675 #ifdef DEBUG
 676       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 677       do i=0,nres
 678         write (iout,'(i3,3e15.5,5x,3e15.5)')
 679      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 680       enddo
 681       call flush(iout)
 682 #endif
 683 #ifdef MPI
 684 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 685         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 686      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 687 #endif
 688 C
 689 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 690 C            in virtual-bond-vector coordinates
 691 C
 692 #ifdef DEBUG
 693 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 694 c      do i=1,nres-1
 695 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 696 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 697 c      enddo
 698 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 699 c      do i=1,nres-1
 700 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 701 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 702 c      enddo
 703       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 704       do i=1,nres
 705         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 706      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 707      &   g_corr5_loc(i)
 708       enddo
 709       call flush(iout)
 710 #endif
 711 #ifdef DEBUG
 712       write (iout,*) "gsaxsc"
 713       do i=1,nres
 714         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 715       enddo
 716       call flush(iout)
 717 #endif
 718 #ifdef SPLITELE
 719       do i=0,nct
 720         do j=1,3
 721           gradbufc(j,i)=wsc*gvdwc(j,i)+
 722      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 723      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 724      &                wel_loc*gel_loc_long(j,i)+
 725      &                wcorr*gradcorr_long(j,i)+
 726      &                wcorr5*gradcorr5_long(j,i)+
 727      &                wcorr6*gradcorr6_long(j,i)+
 728      &                wturn6*gcorr6_turn_long(j,i)+
 729      &                wstrain*ghpbc(j,i)
 730      &                +wliptran*gliptranc(j,i)
 731      &                +gradafm(j,i)
 732      &                +welec*gshieldc(j,i)
 733      &                +wcorr*gshieldc_ec(j,i)
 734      &                +wturn3*gshieldc_t3(j,i)
 735      &                +wturn4*gshieldc_t4(j,i)
 736      &                +wel_loc*gshieldc_ll(j,i)
 737      &                +wtube*gg_tube(j,i)
 738      &                +wsaxs*gsaxsc(j,i)
 739         enddo
 740       enddo
 741 #else
 742       do i=0,nct
 743         do j=1,3
 744           gradbufc(j,i)=wsc*gvdwc(j,i)+
 745      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 746      &                welec*gelc_long(j,i)+
 747      &                wbond*gradb(j,i)+
 748      &                wel_loc*gel_loc_long(j,i)+
 749      &                wcorr*gradcorr_long(j,i)+
 750      &                wcorr5*gradcorr5_long(j,i)+
 751      &                wcorr6*gradcorr6_long(j,i)+
 752      &                wturn6*gcorr6_turn_long(j,i)+
 753      &                wstrain*ghpbc(j,i)
 754      &                +wliptran*gliptranc(j,i)
 755      &                +gradafm(j,i)
 756      &                 +welec*gshieldc(j,i)
 757      &                 +wcorr*gshieldc_ec(j,i)
 758      &                 +wturn4*gshieldc_t4(j,i)
 759      &                 +wel_loc*gshieldc_ll(j,i)
 760      &                +wtube*gg_tube(j,i)
 761      &                +wsaxs*gsaxsc(j,i)
 762         enddo
 763       enddo
 764 #endif
 765       do i=1,nct
 766         do j=1,3
 767           gradbufc(j,i)=gradbufc(j,i)+
 768      &                wdfa_dist*gdfad(j,i)+
 769      &                wdfa_tor*gdfat(j,i)+
 770      &                wdfa_nei*gdfan(j,i)+
 771      &                wdfa_beta*gdfab(j,i)
 772         enddo
 773       enddo
 774 #ifdef DEBUG
 775       write (iout,*) "gradc from gradbufc"
 776       do i=1,nres
 777         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 778       enddo
 779       call flush(iout)
 780 #endif
 781 #ifdef MPI
 782       if (nfgtasks.gt.1) then
 783       time00=MPI_Wtime()
 784 #ifdef DEBUG
 785       write (iout,*) "gradbufc before allreduce"
 786       do i=1,nres
 787         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 788       enddo
 789       call flush(iout)
 790 #endif
 791       do i=0,nres
 792         do j=1,3
 793           gradbufc_sum(j,i)=gradbufc(j,i)
 794         enddo
 795       enddo
 796 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 797 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 798 c      time_reduce=time_reduce+MPI_Wtime()-time00
 799 #ifdef DEBUG
 800 c      write (iout,*) "gradbufc_sum after allreduce"
 801 c      do i=1,nres
 802 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 803 c      enddo
 804 c      call flush(iout)
 805 #endif
 806 #ifdef TIMING
 807 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 808 #endif
 809       do i=nnt,nres
 810         do k=1,3
 811           gradbufc(k,i)=0.0d0
 812         enddo
 813       enddo
 814 #ifdef DEBUG
 815       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 816       write (iout,*) (i," jgrad_start",jgrad_start(i),
 817      &                  " jgrad_end  ",jgrad_end(i),
 818      &                  i=igrad_start,igrad_end)
 819 #endif
 820 c
 821 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 822 c do not parallelize this part.
 823 c
 824 c      do i=igrad_start,igrad_end
 825 c        do j=jgrad_start(i),jgrad_end(i)
 826 c          do k=1,3
 827 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 828 c          enddo
 829 c        enddo
 830 c      enddo
 831       do j=1,3
 832         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 833       enddo
 834       do i=nres-2,-1,-1
 835         do j=1,3
 836           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 837         enddo
 838       enddo
 839 #ifdef DEBUG
 840       write (iout,*) "gradbufc after summing"
 841       do i=1,nres
 842         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 843       enddo
 844       call flush(iout)
 845 #endif
 846       else
 847 #endif
 848 #ifdef DEBUG
 849       write (iout,*) "gradbufc"
 850       do i=1,nres
 851         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 852       enddo
 853       call flush(iout)
 854 #endif
 855       do i=-1,nres
 856         do j=1,3
 857           gradbufc_sum(j,i)=gradbufc(j,i)
 858           gradbufc(j,i)=0.0d0
 859         enddo
 860       enddo
 861       do j=1,3
 862         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 863       enddo
 864       do i=nres-2,-1,-1
 865         do j=1,3
 866           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 867         enddo
 868       enddo
 869 c      do i=nnt,nres-1
 870 c        do k=1,3
 871 c          gradbufc(k,i)=0.0d0
 872 c        enddo
 873 c        do j=i+1,nres
 874 c          do k=1,3
 875 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 876 c          enddo
 877 c        enddo
 878 c      enddo
 879 #ifdef DEBUG
 880       write (iout,*) "gradbufc after summing"
 881       do i=1,nres
 882         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 883       enddo
 884       call flush(iout)
 885 #endif
 886 #ifdef MPI
 887       endif
 888 #endif
 889       do k=1,3
 890         gradbufc(k,nres)=0.0d0
 891       enddo
 892       do i=-1,nct
 893         do j=1,3
 894 #ifdef SPLITELE
 895 C          print *,gradbufc(1,13)
 896 C          print *,welec*gelc(1,13)
 897 C          print *,wel_loc*gel_loc(1,13)
 898 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 899 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 900 C          print *,wel_loc*gel_loc_long(1,13)
 901 C          print *,gradafm(1,13),"AFM"
 902           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 903      &                wel_loc*gel_loc(j,i)+
 904      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 905      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 906      &                wel_loc*gel_loc_long(j,i)+
 907      &                wcorr*gradcorr_long(j,i)+
 908      &                wcorr5*gradcorr5_long(j,i)+
 909      &                wcorr6*gradcorr6_long(j,i)+
 910      &                wturn6*gcorr6_turn_long(j,i))+
 911      &                wbond*gradb(j,i)+
 912      &                wcorr*gradcorr(j,i)+
 913      &                wturn3*gcorr3_turn(j,i)+
 914      &                wturn4*gcorr4_turn(j,i)+
 915      &                wcorr5*gradcorr5(j,i)+
 916      &                wcorr6*gradcorr6(j,i)+
 917      &                wturn6*gcorr6_turn(j,i)+
 918      &                wsccor*gsccorc(j,i)
 919      &               +wscloc*gscloc(j,i)
 920      &               +wliptran*gliptranc(j,i)
 921      &                +gradafm(j,i)
 922      &                 +welec*gshieldc(j,i)
 923      &                 +welec*gshieldc_loc(j,i)
 924      &                 +wcorr*gshieldc_ec(j,i)
 925      &                 +wcorr*gshieldc_loc_ec(j,i)
 926      &                 +wturn3*gshieldc_t3(j,i)
 927      &                 +wturn3*gshieldc_loc_t3(j,i)
 928      &                 +wturn4*gshieldc_t4(j,i)
 929      &                 +wturn4*gshieldc_loc_t4(j,i)
 930      &                 +wel_loc*gshieldc_ll(j,i)
 931      &                 +wel_loc*gshieldc_loc_ll(j,i)
 932      &                +wtube*gg_tube(j,i)
 933
 934 #else
 935           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 936      &                wel_loc*gel_loc(j,i)+
 937      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 938      &                welec*gelc_long(j,i)+
 939      &                wel_loc*gel_loc_long(j,i)+
 940      &                wcorr*gcorr_long(j,i)+
 941      &                wcorr5*gradcorr5_long(j,i)+
 942      &                wcorr6*gradcorr6_long(j,i)+
 943      &                wturn6*gcorr6_turn_long(j,i))+
 944      &                wbond*gradb(j,i)+
 945      &                wcorr*gradcorr(j,i)+
 946      &                wturn3*gcorr3_turn(j,i)+
 947      &                wturn4*gcorr4_turn(j,i)+
 948      &                wcorr5*gradcorr5(j,i)+
 949      &                wcorr6*gradcorr6(j,i)+
 950      &                wturn6*gcorr6_turn(j,i)+
 951      &                wsccor*gsccorc(j,i)
 952      &               +wscloc*gscloc(j,i)
 953      &               +wliptran*gliptranc(j,i)
 954      &                +gradafm(j,i)
 955      &                 +welec*gshieldc(j,i)
 956      &                 +welec*gshieldc_loc(j,i)
 957      &                 +wcorr*gshieldc_ec(j,i)
 958      &                 +wcorr*gshieldc_loc_ec(j,i)
 959      &                 +wturn3*gshieldc_t3(j,i)
 960      &                 +wturn3*gshieldc_loc_t3(j,i)
 961      &                 +wturn4*gshieldc_t4(j,i)
 962      &                 +wturn4*gshieldc_loc_t4(j,i)
 963      &                 +wel_loc*gshieldc_ll(j,i)
 964      &                 +wel_loc*gshieldc_loc_ll(j,i)
 965      &                +wtube*gg_tube(j,i)
 966
 967
 968 #endif
 969           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 970      &                  wbond*gradbx(j,i)+
 971      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 972      &                  wsccor*gsccorx(j,i)
 973      &                 +wscloc*gsclocx(j,i)
 974      &                 +wliptran*gliptranx(j,i)
 975      &                 +welec*gshieldx(j,i)
 976      &                 +wcorr*gshieldx_ec(j,i)
 977      &                 +wturn3*gshieldx_t3(j,i)
 978      &                 +wturn4*gshieldx_t4(j,i)
 979      &                 +wel_loc*gshieldx_ll(j,i)
 980      &                 +wtube*gg_tube_sc(j,i)
 981      &                 +wsaxs*gsaxsx(j,i)
 982
 983
 984
 985         enddo
 986       enddo
 987       if (constr_homology.gt.0) then
 988         do i=1,nct
 989           do j=1,3
 990             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 991             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 992           enddo
 993         enddo
 994       endif
 995 #ifdef DEBUG
 996       write (iout,*) "gradc gradx gloc after adding"
 997       do i=1,nres
 998         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 999      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1000       enddo
1001 #endif
1002 #ifdef DEBUG
1003       write (iout,*) "gloc before adding corr"
1004       do i=1,4*nres
1005         write (iout,*) i,gloc(i,icg)
1006       enddo
1007 #endif
1008       do i=1,nres-3
1009         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1010      &   +wcorr5*g_corr5_loc(i)
1011      &   +wcorr6*g_corr6_loc(i)
1012      &   +wturn4*gel_loc_turn4(i)
1013      &   +wturn3*gel_loc_turn3(i)
1014      &   +wturn6*gel_loc_turn6(i)
1015      &   +wel_loc*gel_loc_loc(i)
1016       enddo
1017 #ifdef DEBUG
1018       write (iout,*) "gloc after adding corr"
1019       do i=1,4*nres
1020         write (iout,*) i,gloc(i,icg)
1021       enddo
1022 #endif
1023 #ifdef MPI
1024       if (nfgtasks.gt.1) then
1025         do j=1,3
1026           do i=1,nres
1027             gradbufc(j,i)=gradc(j,i,icg)
1028             gradbufx(j,i)=gradx(j,i,icg)
1029           enddo
1030         enddo
1031         do i=1,4*nres
1032           glocbuf(i)=gloc(i,icg)
1033         enddo
1034 c#define DEBUG
1035 #ifdef DEBUG
1036       write (iout,*) "gloc_sc before reduce"
1037       do i=1,nres
1038        do j=1,1
1039         write (iout,*) i,j,gloc_sc(j,i,icg)
1040        enddo
1041       enddo
1042 #endif
1043 c#undef DEBUG
1044         do i=1,nres
1045          do j=1,3
1046           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1047          enddo
1048         enddo
1049         time00=MPI_Wtime()
1050         call MPI_Barrier(FG_COMM,IERR)
1051         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1052         time00=MPI_Wtime()
1053         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1054      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1055         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1056      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1057         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1058      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1059         time_reduce=time_reduce+MPI_Wtime()-time00
1060         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1061      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1062         time_reduce=time_reduce+MPI_Wtime()-time00
1063 #ifdef DEBUG
1064       write (iout,*) "gradc after reduce"
1065       do i=1,nres
1066        do j=1,3
1067         write (iout,*) i,j,gradc(j,i,icg)
1068        enddo
1069       enddo
1070 #endif
1071 #ifdef DEBUG
1072       write (iout,*) "gloc_sc after reduce"
1073       do i=1,nres
1074        do j=1,1
1075         write (iout,*) i,j,gloc_sc(j,i,icg)
1076        enddo
1077       enddo
1078 #endif
1079 #ifdef DEBUG
1080       write (iout,*) "gloc after reduce"
1081       do i=1,4*nres
1082         write (iout,*) i,gloc(i,icg)
1083       enddo
1084 #endif
1085       endif
1086 #endif
1087       if (gnorm_check) then
1088 c
1089 c Compute the maximum elements of the gradient
1090 c
1091       gvdwc_max=0.0d0
1092       gvdwc_scp_max=0.0d0
1093       gelc_max=0.0d0
1094       gvdwpp_max=0.0d0
1095       gradb_max=0.0d0
1096       ghpbc_max=0.0d0
1097       gradcorr_max=0.0d0
1098       gel_loc_max=0.0d0
1099       gcorr3_turn_max=0.0d0
1100       gcorr4_turn_max=0.0d0
1101       gradcorr5_max=0.0d0
1102       gradcorr6_max=0.0d0
1103       gcorr6_turn_max=0.0d0
1104       gsccorrc_max=0.0d0
1105       gscloc_max=0.0d0
1106       gvdwx_max=0.0d0
1107       gradx_scp_max=0.0d0
1108       ghpbx_max=0.0d0
1109       gradxorr_max=0.0d0
1110       gsccorrx_max=0.0d0
1111       gsclocx_max=0.0d0
1112       do i=1,nct
1113         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1114         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1115         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1116         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1117      &   gvdwc_scp_max=gvdwc_scp_norm
1118         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1119         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1120         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1121         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1122         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1123         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1124         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1125         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1126         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1127         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1128         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1129         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1130         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1131      &    gcorr3_turn(1,i)))
1132         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1133      &    gcorr3_turn_max=gcorr3_turn_norm
1134         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1135      &    gcorr4_turn(1,i)))
1136         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1137      &    gcorr4_turn_max=gcorr4_turn_norm
1138         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1139         if (gradcorr5_norm.gt.gradcorr5_max)
1140      &    gradcorr5_max=gradcorr5_norm
1141         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1142         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1143         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1144      &    gcorr6_turn(1,i)))
1145         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1146      &    gcorr6_turn_max=gcorr6_turn_norm
1147         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1148         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1149         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1150         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1151         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1152         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1153         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1154         if (gradx_scp_norm.gt.gradx_scp_max)
1155      &    gradx_scp_max=gradx_scp_norm
1156         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1157         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1158         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1159         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1160         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1161         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1162         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1163         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1164       enddo
1165       if (gradout) then
1166 #if (defined AIX || defined CRAY)
1167         open(istat,file=statname,position="append")
1168 #else
1169         open(istat,file=statname,access="append")
1170 #endif
1171         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1172      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1173      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1174      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1175      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1176      &     gsccorrx_max,gsclocx_max
1177         close(istat)
1178         if (gvdwc_max.gt.1.0d4) then
1179           write (iout,*) "gvdwc gvdwx gradb gradbx"
1180           do i=nnt,nct
1181             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1182      &        gradb(j,i),gradbx(j,i),j=1,3)
1183           enddo
1184           call pdbout(0.0d0,'cipiszcze',iout)
1185           call flush(iout)
1186         endif
1187       endif
1188       endif
1189 #ifdef DEBUG
1190       write (iout,*) "gradc gradx gloc"
1191       do i=1,nres
1192         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1193      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1194       enddo
1195 #endif
1196 #ifdef TIMING
1197       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1198 #endif
1199       return
1200       end
1201 c-------------------------------------------------------------------------------
1202       subroutine rescale_weights(t_bath)
1203       implicit none
1204 #ifdef MPI
1205       include 'mpif.h'
1206       integer ierror
1207 #endif
1208       include 'DIMENSIONS'
1209       include 'COMMON.IOUNITS'
1210       include 'COMMON.FFIELD'
1211       include 'COMMON.SBRIDGE'
1212       include 'COMMON.CONTROL'
1213       double precision t_bath
1214       double precision facT,facT2,facT3,facT4,facT5
1215       double precision kfac /2.4d0/
1216       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1217 c      facT=temp0/t_bath
1218 c      facT=2*temp0/(t_bath+temp0)
1219       if (rescale_mode.eq.0) then
1220         facT=1.0d0
1221         facT2=1.0d0
1222         facT3=1.0d0
1223         facT4=1.0d0
1224         facT5=1.0d0
1225       else if (rescale_mode.eq.1) then
1226         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1227         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1228         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1229         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1230         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1231       else if (rescale_mode.eq.2) then
1232         x=t_bath/temp0
1233         x2=x*x
1234         x3=x2*x
1235         x4=x3*x
1236         x5=x4*x
1237         facT=licznik/dlog(dexp(x)+dexp(-x))
1238         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1239         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1240         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1241         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1242       else
1243         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1244         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1245 #ifdef MPI
1246        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1247 #endif
1248        stop 555
1249       endif
1250       if (shield_mode.gt.0) then
1251        wscp=weights(2)*fact
1252        wsc=weights(1)*fact
1253        wvdwpp=weights(16)*fact
1254       endif
1255       welec=weights(3)*fact
1256       wcorr=weights(4)*fact3
1257       wcorr5=weights(5)*fact4
1258       wcorr6=weights(6)*fact5
1259       wel_loc=weights(7)*fact2
1260       wturn3=weights(8)*fact2
1261       wturn4=weights(9)*fact3
1262       wturn6=weights(10)*fact5
1263       wtor=weights(13)*fact
1264       wtor_d=weights(14)*fact2
1265       wsccor=weights(21)*fact
1266       if (scale_umb) wumb=t_bath/temp0
1267 c      write (iout,*) "scale_umb",scale_umb
1268 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1269
1270       return
1271       end
1272 C------------------------------------------------------------------------
1273       subroutine enerprint(energia)
1274       implicit none
1275       include 'DIMENSIONS'
1276       include 'COMMON.IOUNITS'
1277       include 'COMMON.FFIELD'
1278       include 'COMMON.SBRIDGE'
1279       include 'COMMON.QRESTR'
1280       double precision energia(0:n_ene)
1281       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1282      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1283      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1284      & eello_turn6,
1285      & eliptran,Eafmforce,Etube,
1286      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1287       etot=energia(0)
1288       evdw=energia(1)
1289       evdw2=energia(2)
1290 #ifdef SCP14
1291       evdw2=energia(2)+energia(18)
1292 #else
1293       evdw2=energia(2)
1294 #endif
1295       ees=energia(3)
1296 #ifdef SPLITELE
1297       evdw1=energia(16)
1298 #endif
1299       ecorr=energia(4)
1300       ecorr5=energia(5)
1301       ecorr6=energia(6)
1302       eel_loc=energia(7)
1303       eello_turn3=energia(8)
1304       eello_turn4=energia(9)
1305       eello_turn6=energia(10)
1306       ebe=energia(11)
1307       escloc=energia(12)
1308       etors=energia(13)
1309       etors_d=energia(14)
1310       ehpb=energia(15)
1311       edihcnstr=energia(19)
1312       estr=energia(17)
1313       Uconst=energia(20)
1314       esccor=energia(21)
1315       eliptran=energia(22)
1316       Eafmforce=energia(23)
1317       ethetacnstr=energia(24)
1318       etube=energia(25)
1319       esaxs=energia(26)
1320       ehomology_constr=energia(27)
1321 C     Bartek
1322       edfadis = energia(28)
1323       edfator = energia(29)
1324       edfanei = energia(30)
1325       edfabet = energia(31)
1326 #ifdef SPLITELE
1327       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1328      &  estr,wbond,ebe,wang,
1329      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1330 #ifdef FOURBODY
1331      &  ecorr,wcorr,
1332      &  ecorr5,wcorr5,ecorr6,wcorr6,
1333 #endif
1334      &  eel_loc,wel_loc,eello_turn3,wturn3,
1335      &  eello_turn4,wturn4,
1336 #ifdef FOURBODY
1337      &  eello_turn6,wturn6,
1338 #endif
1339      &  esccor,wsccor,edihcnstr,
1340      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1341      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1342      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1343      &  edfabet,wdfa_beta,
1344      &  etot
1345    10 format (/'Virtual-chain energies:'//
1346      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1347      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1348      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1349      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1350      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1351      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1352      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1353      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1354      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1355      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1356      & ' (SS bridges & dist. cnstr.)'/
1357 #ifdef FOURBODY
1358      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1359      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1360      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1361 #endif
1362      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1363      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1364      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1365 #ifdef FOURBODY
1366      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1367 #endif
1368      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1369      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1370      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1371      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1372      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1373      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1374      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1375      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1376      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1377      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1378      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1379      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1380      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1381      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1382      & 'ETOT=  ',1pE16.6,' (total)')
1383
1384 #else
1385       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1386      &  estr,wbond,ebe,wang,
1387      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1388 #ifdef FOURBODY
1389      &  ecorr,wcorr,
1390      &  ecorr5,wcorr5,ecorr6,wcorr6,
1391 #endif
1392      &  eel_loc,wel_loc,eello_turn3,wturn3,
1393      &  eello_turn4,wturn4,
1394 #ifdef FOURBODY
1395      &  eello_turn6,wturn6,
1396 #endif
1397      &  esccor,wsccor,edihcnstr,
1398      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1399      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1400      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1401      &  edfabet,wdfa_beta,
1402      &  etot
1403    10 format (/'Virtual-chain energies:'//
1404      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1405      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1406      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1407      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1408      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1409      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1410      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1411      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1412      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1413      & ' (SS bridges & dist. restr.)'/
1414 #ifdef FOURBODY
1415      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1416      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1417      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1418 #endif
1419      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1420      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1421      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1422 #ifdef FOURBODY
1423      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1424 #endif
1425      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1426      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1427      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1428      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1429      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1430      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1431      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1432      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1433      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1434      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1435      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1436      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1437      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1438      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1439      & 'ETOT=  ',1pE16.6,' (total)')
1440 #endif
1441       return
1442       end
1443 C-----------------------------------------------------------------------
1444       subroutine elj(evdw)
1445 C
1446 C This subroutine calculates the interaction energy of nonbonded side chains
1447 C assuming the LJ potential of interaction.
1448 C
1449       implicit none
1450       double precision accur
1451       include 'DIMENSIONS'
1452       parameter (accur=1.0d-10)
1453       include 'COMMON.GEO'
1454       include 'COMMON.VAR'
1455       include 'COMMON.LOCAL'
1456       include 'COMMON.CHAIN'
1457       include 'COMMON.DERIV'
1458       include 'COMMON.INTERACT'
1459       include 'COMMON.TORSION'
1460       include 'COMMON.SBRIDGE'
1461       include 'COMMON.NAMES'
1462       include 'COMMON.IOUNITS'
1463       include 'COMMON.SPLITELE'
1464 #ifdef FOURBODY
1465       include 'COMMON.CONTACTS'
1466       include 'COMMON.CONTMAT'
1467 #endif
1468       double precision gg(3)
1469       double precision evdw,evdwij
1470       integer i,j,k,itypi,itypj,itypi1,num_conti,iint,icont
1471       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1472      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1473       double precision fcont,fprimcont
1474       double precision sscale,sscagrad
1475 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1476       evdw=0.0D0
1477 c      do i=iatsc_s,iatsc_e
1478       do icont=g_listscsc_start,g_listscsc_end
1479         i=newcontlisti(icont)
1480         j=newcontlistj(icont)
1481         itypi=iabs(itype(i))
1482         if (itypi.eq.ntyp1) cycle
1483         itypi1=iabs(itype(i+1))
1484         xi=c(1,nres+i)
1485         yi=c(2,nres+i)
1486         zi=c(3,nres+i)
1487 C Change 12/1/95
1488         num_conti=0
1489 C
1490 C Calculate SC interaction energy.
1491 C
1492 c        do iint=1,nint_gr(i)
1493 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1494 cd   &                  'iend=',iend(i,iint)
1495 c          do j=istart(i,iint),iend(i,iint)
1496             itypj=iabs(itype(j))
1497             if (itypj.eq.ntyp1) cycle
1498             xj=c(1,nres+j)-xi
1499             yj=c(2,nres+j)-yi
1500             zj=c(3,nres+j)-zi
1501 C Change 12/1/95 to calculate four-body interactions
1502             rij=xj*xj+yj*yj+zj*zj
1503             rrij=1.0D0/rij
1504             sqrij=dsqrt(rij)
1505             sss1=sscale(sqrij,r_cut_int)
1506             if (sss1.eq.0.0d0) cycle
1507             sssgrad1=sscagrad(sqrij,r_cut_int)
1508
1509 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1510             eps0ij=eps(itypi,itypj)
1511             fac=rrij**expon2
1512 C have you changed here?
1513             e1=fac*fac*aa
1514             e2=fac*bb
1515             evdwij=e1+e2
1516 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1517 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1518 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1519 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1520 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1521 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1522             evdw=evdw+sss1*evdwij
1523 C
1524 C Calculate the components of the gradient in DC and X
1525 C
1526             fac=-rrij*(e1+evdwij)*sss1
1527      &          +evdwij*sssgrad1/sqrij/expon
1528             gg(1)=xj*fac
1529             gg(2)=yj*fac
1530             gg(3)=zj*fac
1531             do k=1,3
1532               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1533               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1534               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1535               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1536             enddo
1537 cgrad            do k=i,j-1
1538 cgrad              do l=1,3
1539 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1540 cgrad              enddo
1541 cgrad            enddo
1542 C
1543 #ifdef FOURBODY
1544 C 12/1/95, revised on 5/20/97
1545 C
1546 C Calculate the contact function. The ith column of the array JCONT will
1547 C contain the numbers of atoms that make contacts with the atom I (of numbers
1548 C greater than I). The arrays FACONT and GACONT will contain the values of
1549 C the contact function and its derivative.
1550 C
1551 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1552 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1553 C Uncomment next line, if the correlation interactions are contact function only
1554             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1555               rij=dsqrt(rij)
1556               sigij=sigma(itypi,itypj)
1557               r0ij=rs0(itypi,itypj)
1558 C
1559 C Check whether the SC's are not too far to make a contact.
1560 C
1561               rcut=1.5d0*r0ij
1562               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1563 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1564 C
1565               if (fcont.gt.0.0D0) then
1566 C If the SC-SC distance if close to sigma, apply spline.
1567 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1568 cAdam &             fcont1,fprimcont1)
1569 cAdam           fcont1=1.0d0-fcont1
1570 cAdam           if (fcont1.gt.0.0d0) then
1571 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1572 cAdam             fcont=fcont*fcont1
1573 cAdam           endif
1574 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1575 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1576 cga             do k=1,3
1577 cga               gg(k)=gg(k)*eps0ij
1578 cga             enddo
1579 cga             eps0ij=-evdwij*eps0ij
1580 C Uncomment for AL's type of SC correlation interactions.
1581 cadam           eps0ij=-evdwij
1582                 num_conti=num_conti+1
1583                 jcont(num_conti,i)=j
1584                 facont(num_conti,i)=fcont*eps0ij
1585                 fprimcont=eps0ij*fprimcont/rij
1586                 fcont=expon*fcont
1587 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1588 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1589 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1590 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1591                 gacont(1,num_conti,i)=-fprimcont*xj
1592                 gacont(2,num_conti,i)=-fprimcont*yj
1593                 gacont(3,num_conti,i)=-fprimcont*zj
1594 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1595 cd              write (iout,'(2i3,3f10.5)')
1596 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1597               endif
1598             endif
1599 #endif
1600 c          enddo      ! j
1601 c        enddo        ! iint
1602 C Change 12/1/95
1603 #ifdef FOURBODY
1604         num_cont(i)=num_conti
1605 #endif
1606       enddo          ! i
1607       do i=1,nct
1608         do j=1,3
1609           gvdwc(j,i)=expon*gvdwc(j,i)
1610           gvdwx(j,i)=expon*gvdwx(j,i)
1611         enddo
1612       enddo
1613 C******************************************************************************
1614 C
1615 C                              N O T E !!!
1616 C
1617 C To save time, the factor of EXPON has been extracted from ALL components
1618 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1619 C use!
1620 C
1621 C******************************************************************************
1622       return
1623       end
1624 C-----------------------------------------------------------------------------
1625       subroutine eljk(evdw)
1626 C
1627 C This subroutine calculates the interaction energy of nonbonded side chains
1628 C assuming the LJK potential of interaction.
1629 C
1630       implicit none
1631       include 'DIMENSIONS'
1632       include 'COMMON.GEO'
1633       include 'COMMON.VAR'
1634       include 'COMMON.LOCAL'
1635       include 'COMMON.CHAIN'
1636       include 'COMMON.DERIV'
1637       include 'COMMON.INTERACT'
1638       include 'COMMON.IOUNITS'
1639       include 'COMMON.NAMES'
1640       include 'COMMON.SPLITELE'
1641       double precision gg(3)
1642       double precision evdw,evdwij
1643       integer i,j,k,itypi,itypj,itypi1,iint,icont
1644       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1645      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1646       logical scheck
1647       double precision sscale,sscagrad
1648 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1649       evdw=0.0D0
1650 c      do i=iatsc_s,iatsc_e
1651       do icont=g_listscsc_start,g_listscsc_end
1652         i=newcontlisti(icont)
1653         j=newcontlistj(icont)
1654         itypi=iabs(itype(i))
1655         if (itypi.eq.ntyp1) cycle
1656         itypi1=iabs(itype(i+1))
1657         xi=c(1,nres+i)
1658         yi=c(2,nres+i)
1659         zi=c(3,nres+i)
1660 C
1661 C Calculate SC interaction energy.
1662 C
1663 c        do iint=1,nint_gr(i)
1664 c          do j=istart(i,iint),iend(i,iint)
1665             itypj=iabs(itype(j))
1666             if (itypj.eq.ntyp1) cycle
1667             xj=c(1,nres+j)-xi
1668             yj=c(2,nres+j)-yi
1669             zj=c(3,nres+j)-zi
1670             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1671             fac_augm=rrij**expon
1672             e_augm=augm(itypi,itypj)*fac_augm
1673             r_inv_ij=dsqrt(rrij)
1674             rij=1.0D0/r_inv_ij
1675             sss1=sscale(rij,r_cut_int)
1676             if (sss1.eq.0.0d0) cycle
1677             sssgrad1=sscagrad(rij,r_cut_int)
1678             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1679             fac=r_shift_inv**expon
1680 C have you changed here?
1681             e1=fac*fac*aa
1682             e2=fac*bb
1683             evdwij=e_augm+e1+e2
1684 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1685 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1686 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1687 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1688 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1689 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1690 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1691             evdw=evdw+evdwij*sss1
1692 C
1693 C Calculate the components of the gradient in DC and X
1694 C
1695             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1696      &          +evdwij*sssgrad1*r_inv_ij/expon
1697             gg(1)=xj*fac
1698             gg(2)=yj*fac
1699             gg(3)=zj*fac
1700             do k=1,3
1701               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1702               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1703               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1704               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1705             enddo
1706 cgrad            do k=i,j-1
1707 cgrad              do l=1,3
1708 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1709 cgrad              enddo
1710 cgrad            enddo
1711 c          enddo      ! j
1712 c        enddo        ! iint
1713       enddo          ! i
1714       do i=1,nct
1715         do j=1,3
1716           gvdwc(j,i)=expon*gvdwc(j,i)
1717           gvdwx(j,i)=expon*gvdwx(j,i)
1718         enddo
1719       enddo
1720       return
1721       end
1722 C-----------------------------------------------------------------------------
1723       subroutine ebp(evdw)
1724 C
1725 C This subroutine calculates the interaction energy of nonbonded side chains
1726 C assuming the Berne-Pechukas potential of interaction.
1727 C
1728       implicit none
1729       include 'DIMENSIONS'
1730       include 'COMMON.GEO'
1731       include 'COMMON.VAR'
1732       include 'COMMON.LOCAL'
1733       include 'COMMON.CHAIN'
1734       include 'COMMON.DERIV'
1735       include 'COMMON.NAMES'
1736       include 'COMMON.INTERACT'
1737       include 'COMMON.IOUNITS'
1738       include 'COMMON.CALC'
1739       include 'COMMON.SPLITELE'
1740       integer icall
1741       common /srutu/ icall
1742       double precision evdw
1743       integer itypi,itypj,itypi1,iint,ind,icont
1744       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1745      & sss1,sssgrad1
1746       double precision sscale,sscagrad
1747 c     double precision rrsave(maxdim)
1748       logical lprn
1749       evdw=0.0D0
1750 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1751       evdw=0.0D0
1752 c     if (icall.eq.0) then
1753 c       lprn=.true.
1754 c     else
1755         lprn=.false.
1756 c     endif
1757       ind=0
1758 c      do i=iatsc_s,iatsc_e
1759       do icont=g_listscsc_start,g_listscsc_end
1760         i=newcontlisti(icont)
1761         j=newcontlistj(icont)
1762         itypi=iabs(itype(i))
1763         if (itypi.eq.ntyp1) cycle
1764         itypi1=iabs(itype(i+1))
1765         xi=c(1,nres+i)
1766         yi=c(2,nres+i)
1767         zi=c(3,nres+i)
1768         dxi=dc_norm(1,nres+i)
1769         dyi=dc_norm(2,nres+i)
1770         dzi=dc_norm(3,nres+i)
1771 c        dsci_inv=dsc_inv(itypi)
1772         dsci_inv=vbld_inv(i+nres)
1773 C
1774 C Calculate SC interaction energy.
1775 C
1776 c        do iint=1,nint_gr(i)
1777 c          do j=istart(i,iint),iend(i,iint)
1778             ind=ind+1
1779             itypj=iabs(itype(j))
1780             if (itypj.eq.ntyp1) cycle
1781 c            dscj_inv=dsc_inv(itypj)
1782             dscj_inv=vbld_inv(j+nres)
1783             chi1=chi(itypi,itypj)
1784             chi2=chi(itypj,itypi)
1785             chi12=chi1*chi2
1786             chip1=chip(itypi)
1787             chip2=chip(itypj)
1788             chip12=chip1*chip2
1789             alf1=alp(itypi)
1790             alf2=alp(itypj)
1791             alf12=0.5D0*(alf1+alf2)
1792 C For diagnostics only!!!
1793 c           chi1=0.0D0
1794 c           chi2=0.0D0
1795 c           chi12=0.0D0
1796 c           chip1=0.0D0
1797 c           chip2=0.0D0
1798 c           chip12=0.0D0
1799 c           alf1=0.0D0
1800 c           alf2=0.0D0
1801 c           alf12=0.0D0
1802             xj=c(1,nres+j)-xi
1803             yj=c(2,nres+j)-yi
1804             zj=c(3,nres+j)-zi
1805             dxj=dc_norm(1,nres+j)
1806             dyj=dc_norm(2,nres+j)
1807             dzj=dc_norm(3,nres+j)
1808             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1809 cd          if (icall.eq.0) then
1810 cd            rrsave(ind)=rrij
1811 cd          else
1812 cd            rrij=rrsave(ind)
1813 cd          endif
1814             rij=dsqrt(rrij)
1815             sss1=sscale(1.0d0/rij,r_cut_int)
1816             if (sss1.eq.0.0d0) cycle
1817             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1818 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1819             call sc_angular
1820 C Calculate whole angle-dependent part of epsilon and contributions
1821 C to its derivatives
1822 C have you changed here?
1823             fac=(rrij*sigsq)**expon2
1824             e1=fac*fac*aa
1825             e2=fac*bb
1826             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1827             eps2der=evdwij*eps3rt
1828             eps3der=evdwij*eps2rt
1829             evdwij=evdwij*eps2rt*eps3rt
1830             evdw=evdw+sss1*evdwij
1831             if (lprn) then
1832             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1833             epsi=bb**2/aa
1834 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1835 cd     &        restyp(itypi),i,restyp(itypj),j,
1836 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1837 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1838 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1839 cd     &        evdwij
1840             endif
1841 C Calculate gradient components.
1842             e1=e1*eps1*eps2rt**2*eps3rt**2
1843             fac=-expon*(e1+evdwij)
1844             sigder=fac/sigsq
1845             fac=rrij*fac
1846      &          +evdwij*sssgrad1/sss1*rij
1847 C Calculate radial part of the gradient
1848             gg(1)=xj*fac
1849             gg(2)=yj*fac
1850             gg(3)=zj*fac
1851 C Calculate the angular part of the gradient and sum add the contributions
1852 C to the appropriate components of the Cartesian gradient.
1853             call sc_grad
1854 !          enddo      ! j
1855 !        enddo        ! iint
1856       enddo          ! i
1857 c     stop
1858       return
1859       end
1860 C-----------------------------------------------------------------------------
1861       subroutine egb(evdw)
1862 C
1863 C This subroutine calculates the interaction energy of nonbonded side chains
1864 C assuming the Gay-Berne potential of interaction.
1865 C
1866       implicit none
1867       include 'DIMENSIONS'
1868       include 'COMMON.GEO'
1869       include 'COMMON.VAR'
1870       include 'COMMON.LOCAL'
1871       include 'COMMON.CHAIN'
1872       include 'COMMON.DERIV'
1873       include 'COMMON.NAMES'
1874       include 'COMMON.INTERACT'
1875       include 'COMMON.IOUNITS'
1876       include 'COMMON.CALC'
1877       include 'COMMON.CONTROL'
1878       include 'COMMON.SPLITELE'
1879       include 'COMMON.SBRIDGE'
1880       logical lprn
1881       integer xshift,yshift,zshift,subchap
1882       double precision evdw
1883       integer itypi,itypj,itypi1,iint,ind,icont
1884       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1885       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1886      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1887      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1888       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1889       evdw=0.0D0
1890 ccccc      energy_dec=.false.
1891 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1892       evdw=0.0D0
1893       lprn=.false.
1894 c     if (icall.eq.0) lprn=.false.
1895       ind=0
1896 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1897 C we have the original box)
1898 C      do xshift=-1,1
1899 C      do yshift=-1,1
1900 C      do zshift=-1,1
1901 c      do i=iatsc_s,iatsc_e
1902       do icont=g_listscsc_start,g_listscsc_end
1903         i=newcontlisti(icont)
1904         j=newcontlistj(icont)
1905         itypi=iabs(itype(i))
1906         if (itypi.eq.ntyp1) cycle
1907         itypi1=iabs(itype(i+1))
1908         xi=c(1,nres+i)
1909         yi=c(2,nres+i)
1910         zi=c(3,nres+i)
1911 C Return atom into box, boxxsize is size of box in x dimension
1912 c  134   continue
1913 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1914 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1915 C Condition for being inside the proper box
1916 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1917 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1918 c        go to 134
1919 c        endif
1920 c  135   continue
1921 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1922 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1923 C Condition for being inside the proper box
1924 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1925 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1926 c        go to 135
1927 c        endif
1928 c  136   continue
1929 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1930 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1931 C Condition for being inside the proper box
1932 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1933 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1934 c        go to 136
1935 c        endif
1936           xi=mod(xi,boxxsize)
1937           if (xi.lt.0) xi=xi+boxxsize
1938           yi=mod(yi,boxysize)
1939           if (yi.lt.0) yi=yi+boxysize
1940           zi=mod(zi,boxzsize)
1941           if (zi.lt.0) zi=zi+boxzsize
1942 C define scaling factor for lipids
1943
1944 C        if (positi.le.0) positi=positi+boxzsize
1945 C        print *,i
1946 C first for peptide groups
1947 c for each residue check if it is in lipid or lipid water border area
1948        if ((zi.gt.bordlipbot)
1949      &.and.(zi.lt.bordliptop)) then
1950 C the energy transfer exist
1951         if (zi.lt.buflipbot) then
1952 C what fraction I am in
1953          fracinbuf=1.0d0-
1954      &        ((zi-bordlipbot)/lipbufthick)
1955 C lipbufthick is thickenes of lipid buffore
1956          sslipi=sscalelip(fracinbuf)
1957          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1958         elseif (zi.gt.bufliptop) then
1959          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1960          sslipi=sscalelip(fracinbuf)
1961          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1962         else
1963          sslipi=1.0d0
1964          ssgradlipi=0.0
1965         endif
1966        else
1967          sslipi=0.0d0
1968          ssgradlipi=0.0
1969        endif
1970
1971 C          xi=xi+xshift*boxxsize
1972 C          yi=yi+yshift*boxysize
1973 C          zi=zi+zshift*boxzsize
1974
1975         dxi=dc_norm(1,nres+i)
1976         dyi=dc_norm(2,nres+i)
1977         dzi=dc_norm(3,nres+i)
1978 c        dsci_inv=dsc_inv(itypi)
1979         dsci_inv=vbld_inv(i+nres)
1980 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1981 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1982 C
1983 C Calculate SC interaction energy.
1984 C
1985 c        do iint=1,nint_gr(i)
1986 c          do j=istart(i,iint),iend(i,iint)
1987             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1988
1989 c              write(iout,*) "PRZED ZWYKLE", evdwij
1990               call dyn_ssbond_ene(i,j,evdwij)
1991 c              write(iout,*) "PO ZWYKLE", evdwij
1992
1993               evdw=evdw+evdwij
1994               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1995      &                        'evdw',i,j,evdwij,' ss'
1996 C triple bond artifac removal
1997              do k=j+1,iend(i,iint)
1998 C search over all next residues
1999               if (dyn_ss_mask(k)) then
2000 C check if they are cysteins
2001 C              write(iout,*) 'k=',k
2002
2003 c              write(iout,*) "PRZED TRI", evdwij
2004                evdwij_przed_tri=evdwij
2005               call triple_ssbond_ene(i,j,k,evdwij)
2006 c               if(evdwij_przed_tri.ne.evdwij) then
2007 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2008 c               endif
2009
2010 c              write(iout,*) "PO TRI", evdwij
2011 C call the energy function that removes the artifical triple disulfide
2012 C bond the soubroutine is located in ssMD.F
2013               evdw=evdw+evdwij
2014               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2015      &                        'evdw',i,j,evdwij,'tss'
2016               endif!dyn_ss_mask(k)
2017              enddo! k
2018             ELSE
2019             ind=ind+1
2020             itypj=iabs(itype(j))
2021             if (itypj.eq.ntyp1) cycle
2022 c            dscj_inv=dsc_inv(itypj)
2023             dscj_inv=vbld_inv(j+nres)
2024 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2025 c     &       1.0d0/vbld(j+nres)
2026 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2027             sig0ij=sigma(itypi,itypj)
2028             chi1=chi(itypi,itypj)
2029             chi2=chi(itypj,itypi)
2030             chi12=chi1*chi2
2031             chip1=chip(itypi)
2032             chip2=chip(itypj)
2033             chip12=chip1*chip2
2034             alf1=alp(itypi)
2035             alf2=alp(itypj)
2036             alf12=0.5D0*(alf1+alf2)
2037 C For diagnostics only!!!
2038 c           chi1=0.0D0
2039 c           chi2=0.0D0
2040 c           chi12=0.0D0
2041 c           chip1=0.0D0
2042 c           chip2=0.0D0
2043 c           chip12=0.0D0
2044 c           alf1=0.0D0
2045 c           alf2=0.0D0
2046 c           alf12=0.0D0
2047             xj=c(1,nres+j)
2048             yj=c(2,nres+j)
2049             zj=c(3,nres+j)
2050 C Return atom J into box the original box
2051 c  137   continue
2052 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2053 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2054 C Condition for being inside the proper box
2055 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2056 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2057 c        go to 137
2058 c        endif
2059 c  138   continue
2060 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2061 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2062 C Condition for being inside the proper box
2063 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2064 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2065 c        go to 138
2066 c        endif
2067 c  139   continue
2068 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2069 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2070 C Condition for being inside the proper box
2071 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2072 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2073 c        go to 139
2074 c        endif
2075           xj=mod(xj,boxxsize)
2076           if (xj.lt.0) xj=xj+boxxsize
2077           yj=mod(yj,boxysize)
2078           if (yj.lt.0) yj=yj+boxysize
2079           zj=mod(zj,boxzsize)
2080           if (zj.lt.0) zj=zj+boxzsize
2081        if ((zj.gt.bordlipbot)
2082      &.and.(zj.lt.bordliptop)) then
2083 C the energy transfer exist
2084         if (zj.lt.buflipbot) then
2085 C what fraction I am in
2086          fracinbuf=1.0d0-
2087      &        ((zj-bordlipbot)/lipbufthick)
2088 C lipbufthick is thickenes of lipid buffore
2089          sslipj=sscalelip(fracinbuf)
2090          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2091         elseif (zj.gt.bufliptop) then
2092          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2093          sslipj=sscalelip(fracinbuf)
2094          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2095         else
2096          sslipj=1.0d0
2097          ssgradlipj=0.0
2098         endif
2099        else
2100          sslipj=0.0d0
2101          ssgradlipj=0.0
2102        endif
2103       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2104      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2105       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2106      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2107 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2108 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2109 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2110 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2111 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2112       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2113       xj_safe=xj
2114       yj_safe=yj
2115       zj_safe=zj
2116       subchap=0
2117       do xshift=-1,1
2118       do yshift=-1,1
2119       do zshift=-1,1
2120           xj=xj_safe+xshift*boxxsize
2121           yj=yj_safe+yshift*boxysize
2122           zj=zj_safe+zshift*boxzsize
2123           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2124           if(dist_temp.lt.dist_init) then
2125             dist_init=dist_temp
2126             xj_temp=xj
2127             yj_temp=yj
2128             zj_temp=zj
2129             subchap=1
2130           endif
2131        enddo
2132        enddo
2133        enddo
2134        if (subchap.eq.1) then
2135           xj=xj_temp-xi
2136           yj=yj_temp-yi
2137           zj=zj_temp-zi
2138        else
2139           xj=xj_safe-xi
2140           yj=yj_safe-yi
2141           zj=zj_safe-zi
2142        endif
2143             dxj=dc_norm(1,nres+j)
2144             dyj=dc_norm(2,nres+j)
2145             dzj=dc_norm(3,nres+j)
2146 C            xj=xj-xi
2147 C            yj=yj-yi
2148 C            zj=zj-zi
2149 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2150 c            write (iout,*) "j",j," dc_norm",
2151 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2152             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2153             rij=dsqrt(rrij)
2154             sss=sscale(1.0d0/rij,r_cut_int)
2155 c            write (iout,'(a7,4f8.3)')
2156 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2157             if (sss.eq.0.0d0) cycle
2158             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2159 C Calculate angle-dependent terms of energy and contributions to their
2160 C derivatives.
2161             call sc_angular
2162             sigsq=1.0D0/sigsq
2163             sig=sig0ij*dsqrt(sigsq)
2164             rij_shift=1.0D0/rij-sig+sig0ij
2165 c for diagnostics; uncomment
2166 c            rij_shift=1.2*sig0ij
2167 C I hate to put IF's in the loops, but here don't have another choice!!!!
2168             if (rij_shift.le.0.0D0) then
2169               evdw=1.0D20
2170 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2171 cd     &        restyp(itypi),i,restyp(itypj),j,
2172 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2173               return
2174             endif
2175             sigder=-sig*sigsq
2176 c---------------------------------------------------------------
2177             rij_shift=1.0D0/rij_shift
2178             fac=rij_shift**expon
2179 C here to start with
2180 C            if (c(i,3).gt.
2181             faclip=fac
2182             e1=fac*fac*aa
2183             e2=fac*bb
2184             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2185             eps2der=evdwij*eps3rt
2186             eps3der=evdwij*eps2rt
2187 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2188 C     &((sslipi+sslipj)/2.0d0+
2189 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2190 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2191 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2192             evdwij=evdwij*eps2rt*eps3rt
2193             evdw=evdw+evdwij*sss
2194             if (lprn) then
2195             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2196             epsi=bb**2/aa
2197             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2198      &        restyp(itypi),i,restyp(itypj),j,
2199      &        epsi,sigm,chi1,chi2,chip1,chip2,
2200      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2201      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2202      &        evdwij
2203             endif
2204
2205             if (energy_dec) write (iout,'(a,2i5,3f10.5)')
2206      &                    'r sss evdw',i,j,rij,sss,evdwij
2207
2208 C Calculate gradient components.
2209             e1=e1*eps1*eps2rt**2*eps3rt**2
2210             fac=-expon*(e1+evdwij)*rij_shift
2211             sigder=fac*sigder
2212             fac=rij*fac
2213 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2214 c     &      evdwij,fac,sigma(itypi,itypj),expon
2215             fac=fac+evdwij*sssgrad/sss*rij
2216 c            fac=0.0d0
2217 C Calculate the radial part of the gradient
2218             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2219      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2220      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2221      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2222             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2223             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2224 C            gg_lipi(3)=0.0d0
2225 C            gg_lipj(3)=0.0d0
2226             gg(1)=xj*fac
2227             gg(2)=yj*fac
2228             gg(3)=zj*fac
2229 C Calculate angular part of the gradient.
2230 c            call sc_grad_scale(sss)
2231             call sc_grad
2232             ENDIF    ! dyn_ss
2233 c          enddo      ! j
2234 c        enddo        ! iint
2235       enddo          ! i
2236 C      enddo          ! zshift
2237 C      enddo          ! yshift
2238 C      enddo          ! xshift
2239 c      write (iout,*) "Number of loop steps in EGB:",ind
2240 cccc      energy_dec=.false.
2241       return
2242       end
2243 C-----------------------------------------------------------------------------
2244       subroutine egbv(evdw)
2245 C
2246 C This subroutine calculates the interaction energy of nonbonded side chains
2247 C assuming the Gay-Berne-Vorobjev potential of interaction.
2248 C
2249       implicit none
2250       include 'DIMENSIONS'
2251       include 'COMMON.GEO'
2252       include 'COMMON.VAR'
2253       include 'COMMON.LOCAL'
2254       include 'COMMON.CHAIN'
2255       include 'COMMON.DERIV'
2256       include 'COMMON.NAMES'
2257       include 'COMMON.INTERACT'
2258       include 'COMMON.IOUNITS'
2259       include 'COMMON.CALC'
2260       include 'COMMON.SPLITELE'
2261       integer xshift,yshift,zshift,subchap
2262       integer icall
2263       common /srutu/ icall
2264       logical lprn
2265       double precision evdw
2266       integer itypi,itypj,itypi1,iint,ind,icont
2267       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2268      & xi,yi,zi,fac_augm,e_augm
2269       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2270      & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2271      & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip,sssgrad1
2272       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2273       evdw=0.0D0
2274 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2275       evdw=0.0D0
2276       lprn=.false.
2277 c     if (icall.eq.0) lprn=.true.
2278       ind=0
2279 c      do i=iatsc_s,iatsc_e
2280       do icont=g_listscsc_start,g_listscsc_end
2281         i=newcontlisti(icont)
2282         j=newcontlistj(icont)
2283         itypi=iabs(itype(i))
2284         if (itypi.eq.ntyp1) cycle
2285         itypi1=iabs(itype(i+1))
2286         xi=c(1,nres+i)
2287         yi=c(2,nres+i)
2288         zi=c(3,nres+i)
2289           xi=mod(xi,boxxsize)
2290           if (xi.lt.0) xi=xi+boxxsize
2291           yi=mod(yi,boxysize)
2292           if (yi.lt.0) yi=yi+boxysize
2293           zi=mod(zi,boxzsize)
2294           if (zi.lt.0) zi=zi+boxzsize
2295 C define scaling factor for lipids
2296
2297 C        if (positi.le.0) positi=positi+boxzsize
2298 C        print *,i
2299 C first for peptide groups
2300 c for each residue check if it is in lipid or lipid water border area
2301        if ((zi.gt.bordlipbot)
2302      &.and.(zi.lt.bordliptop)) then
2303 C the energy transfer exist
2304         if (zi.lt.buflipbot) then
2305 C what fraction I am in
2306          fracinbuf=1.0d0-
2307      &        ((zi-bordlipbot)/lipbufthick)
2308 C lipbufthick is thickenes of lipid buffore
2309          sslipi=sscalelip(fracinbuf)
2310          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2311         elseif (zi.gt.bufliptop) then
2312          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2313          sslipi=sscalelip(fracinbuf)
2314          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2315         else
2316          sslipi=1.0d0
2317          ssgradlipi=0.0
2318         endif
2319        else
2320          sslipi=0.0d0
2321          ssgradlipi=0.0
2322        endif
2323
2324         dxi=dc_norm(1,nres+i)
2325         dyi=dc_norm(2,nres+i)
2326         dzi=dc_norm(3,nres+i)
2327 c        dsci_inv=dsc_inv(itypi)
2328         dsci_inv=vbld_inv(i+nres)
2329 C
2330 C Calculate SC interaction energy.
2331 C
2332 c        do iint=1,nint_gr(i)
2333 c          do j=istart(i,iint),iend(i,iint)
2334             ind=ind+1
2335             itypj=iabs(itype(j))
2336             if (itypj.eq.ntyp1) cycle
2337 c            dscj_inv=dsc_inv(itypj)
2338             dscj_inv=vbld_inv(j+nres)
2339             sig0ij=sigma(itypi,itypj)
2340             r0ij=r0(itypi,itypj)
2341             chi1=chi(itypi,itypj)
2342             chi2=chi(itypj,itypi)
2343             chi12=chi1*chi2
2344             chip1=chip(itypi)
2345             chip2=chip(itypj)
2346             chip12=chip1*chip2
2347             alf1=alp(itypi)
2348             alf2=alp(itypj)
2349             alf12=0.5D0*(alf1+alf2)
2350 C For diagnostics only!!!
2351 c           chi1=0.0D0
2352 c           chi2=0.0D0
2353 c           chi12=0.0D0
2354 c           chip1=0.0D0
2355 c           chip2=0.0D0
2356 c           chip12=0.0D0
2357 c           alf1=0.0D0
2358 c           alf2=0.0D0
2359 c           alf12=0.0D0
2360 C            xj=c(1,nres+j)-xi
2361 C            yj=c(2,nres+j)-yi
2362 C            zj=c(3,nres+j)-zi
2363           xj=mod(xj,boxxsize)
2364           if (xj.lt.0) xj=xj+boxxsize
2365           yj=mod(yj,boxysize)
2366           if (yj.lt.0) yj=yj+boxysize
2367           zj=mod(zj,boxzsize)
2368           if (zj.lt.0) zj=zj+boxzsize
2369        if ((zj.gt.bordlipbot)
2370      &.and.(zj.lt.bordliptop)) then
2371 C the energy transfer exist
2372         if (zj.lt.buflipbot) then
2373 C what fraction I am in
2374          fracinbuf=1.0d0-
2375      &        ((zj-bordlipbot)/lipbufthick)
2376 C lipbufthick is thickenes of lipid buffore
2377          sslipj=sscalelip(fracinbuf)
2378          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2379         elseif (zj.gt.bufliptop) then
2380          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2381          sslipj=sscalelip(fracinbuf)
2382          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2383         else
2384          sslipj=1.0d0
2385          ssgradlipj=0.0
2386         endif
2387        else
2388          sslipj=0.0d0
2389          ssgradlipj=0.0
2390        endif
2391       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2392      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2393       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2394      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2395 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2396 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2397 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2398       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2399       xj_safe=xj
2400       yj_safe=yj
2401       zj_safe=zj
2402       subchap=0
2403       do xshift=-1,1
2404       do yshift=-1,1
2405       do zshift=-1,1
2406           xj=xj_safe+xshift*boxxsize
2407           yj=yj_safe+yshift*boxysize
2408           zj=zj_safe+zshift*boxzsize
2409           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2410           if(dist_temp.lt.dist_init) then
2411             dist_init=dist_temp
2412             xj_temp=xj
2413             yj_temp=yj
2414             zj_temp=zj
2415             subchap=1
2416           endif
2417        enddo
2418        enddo
2419        enddo
2420        if (subchap.eq.1) then
2421           xj=xj_temp-xi
2422           yj=yj_temp-yi
2423           zj=zj_temp-zi
2424        else
2425           xj=xj_safe-xi
2426           yj=yj_safe-yi
2427           zj=zj_safe-zi
2428        endif
2429             dxj=dc_norm(1,nres+j)
2430             dyj=dc_norm(2,nres+j)
2431             dzj=dc_norm(3,nres+j)
2432             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2433             rij=dsqrt(rrij)
2434             sss=sscale(1.0d0/rij,r_cut_int)
2435             if (sss.eq.0.0d0) cycle
2436             sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2437 C Calculate angle-dependent terms of energy and contributions to their
2438 C derivatives.
2439             call sc_angular
2440             sigsq=1.0D0/sigsq
2441             sig=sig0ij*dsqrt(sigsq)
2442             rij_shift=1.0D0/rij-sig+r0ij
2443 C I hate to put IF's in the loops, but here don't have another choice!!!!
2444             if (rij_shift.le.0.0D0) then
2445               evdw=1.0D20
2446               return
2447             endif
2448             sigder=-sig*sigsq
2449 c---------------------------------------------------------------
2450             rij_shift=1.0D0/rij_shift
2451             fac=rij_shift**expon
2452             e1=fac*fac*aa
2453             e2=fac*bb
2454             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2455             eps2der=evdwij*eps3rt
2456             eps3der=evdwij*eps2rt
2457             fac_augm=rrij**expon
2458             e_augm=augm(itypi,itypj)*fac_augm
2459             evdwij=evdwij*eps2rt*eps3rt
2460             evdw=evdw+evdwij+e_augm
2461             if (lprn) then
2462             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2463             epsi=bb**2/aa
2464             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2465      &        restyp(itypi),i,restyp(itypj),j,
2466      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2467      &        chi1,chi2,chip1,chip2,
2468      &        eps1,eps2rt**2,eps3rt**2,
2469      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2470      &        evdwij+e_augm
2471             endif
2472 C Calculate gradient components.
2473             e1=e1*eps1*eps2rt**2*eps3rt**2
2474             fac=-expon*(e1+evdwij)*rij_shift
2475             sigder=fac*sigder
2476             fac=rij*fac-2*expon*rrij*e_augm
2477             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2478 C Calculate the radial part of the gradient
2479             gg(1)=xj*fac
2480             gg(2)=yj*fac
2481             gg(3)=zj*fac
2482 C Calculate angular part of the gradient.
2483 c            call sc_grad_scale(sss)
2484             call sc_grad
2485 c          enddo      ! j
2486 c        enddo        ! iint
2487       enddo          ! i
2488       end
2489 C-----------------------------------------------------------------------------
2490       subroutine sc_angular
2491 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2492 C om12. Called by ebp, egb, and egbv.
2493       implicit none
2494       include 'COMMON.CALC'
2495       include 'COMMON.IOUNITS'
2496       erij(1)=xj*rij
2497       erij(2)=yj*rij
2498       erij(3)=zj*rij
2499       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2500       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2501       om12=dxi*dxj+dyi*dyj+dzi*dzj
2502       chiom12=chi12*om12
2503 C Calculate eps1(om12) and its derivative in om12
2504       faceps1=1.0D0-om12*chiom12
2505       faceps1_inv=1.0D0/faceps1
2506       eps1=dsqrt(faceps1_inv)
2507 C Following variable is eps1*deps1/dom12
2508       eps1_om12=faceps1_inv*chiom12
2509 c diagnostics only
2510 c      faceps1_inv=om12
2511 c      eps1=om12
2512 c      eps1_om12=1.0d0
2513 c      write (iout,*) "om12",om12," eps1",eps1
2514 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2515 C and om12.
2516       om1om2=om1*om2
2517       chiom1=chi1*om1
2518       chiom2=chi2*om2
2519       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2520       sigsq=1.0D0-facsig*faceps1_inv
2521       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2522       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2523       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2524 c diagnostics only
2525 c      sigsq=1.0d0
2526 c      sigsq_om1=0.0d0
2527 c      sigsq_om2=0.0d0
2528 c      sigsq_om12=0.0d0
2529 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2530 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2531 c     &    " eps1",eps1
2532 C Calculate eps2 and its derivatives in om1, om2, and om12.
2533       chipom1=chip1*om1
2534       chipom2=chip2*om2
2535       chipom12=chip12*om12
2536       facp=1.0D0-om12*chipom12
2537       facp_inv=1.0D0/facp
2538       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2539 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2540 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2541 C Following variable is the square root of eps2
2542       eps2rt=1.0D0-facp1*facp_inv
2543 C Following three variables are the derivatives of the square root of eps
2544 C in om1, om2, and om12.
2545       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2546       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2547       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2548 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2549       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2550 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2551 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2552 c     &  " eps2rt_om12",eps2rt_om12
2553 C Calculate whole angle-dependent part of epsilon and contributions
2554 C to its derivatives
2555       return
2556       end
2557 C----------------------------------------------------------------------------
2558       subroutine sc_grad
2559       implicit real*8 (a-h,o-z)
2560       include 'DIMENSIONS'
2561       include 'COMMON.CHAIN'
2562       include 'COMMON.DERIV'
2563       include 'COMMON.CALC'
2564       include 'COMMON.IOUNITS'
2565       double precision dcosom1(3),dcosom2(3)
2566 cc      print *,'sss=',sss
2567       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2568       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2569       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2570      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2571 c diagnostics only
2572 c      eom1=0.0d0
2573 c      eom2=0.0d0
2574 c      eom12=evdwij*eps1_om12
2575 c end diagnostics
2576 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2577 c     &  " sigder",sigder
2578 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2579 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2580       do k=1,3
2581         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2582         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2583       enddo
2584       do k=1,3
2585         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2586       enddo
2587 c      write (iout,*) "gg",(gg(k),k=1,3)
2588       do k=1,3
2589         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2590      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2591      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2592         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2593      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2594      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2595 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2596 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2597 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2598 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2599       enddo
2600 C
2601 C Calculate the components of the gradient in DC and X
2602 C
2603 cgrad      do k=i,j-1
2604 cgrad        do l=1,3
2605 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2606 cgrad        enddo
2607 cgrad      enddo
2608       do l=1,3
2609         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2610         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2611       enddo
2612       return
2613       end
2614 C-----------------------------------------------------------------------
2615       subroutine e_softsphere(evdw)
2616 C
2617 C This subroutine calculates the interaction energy of nonbonded side chains
2618 C assuming the LJ potential of interaction.
2619 C
2620       implicit real*8 (a-h,o-z)
2621       include 'DIMENSIONS'
2622       parameter (accur=1.0d-10)
2623       include 'COMMON.GEO'
2624       include 'COMMON.VAR'
2625       include 'COMMON.LOCAL'
2626       include 'COMMON.CHAIN'
2627       include 'COMMON.DERIV'
2628       include 'COMMON.INTERACT'
2629       include 'COMMON.TORSION'
2630       include 'COMMON.SBRIDGE'
2631       include 'COMMON.NAMES'
2632       include 'COMMON.IOUNITS'
2633 c      include 'COMMON.CONTACTS'
2634       dimension gg(3)
2635 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2636       evdw=0.0D0
2637 c      do i=iatsc_s,iatsc_e
2638       do icont=g_listscsc_start,g_listscsc_end
2639         i=newcontlisti(icont)
2640         j=newcontlistj(icont)
2641         itypi=iabs(itype(i))
2642         if (itypi.eq.ntyp1) cycle
2643         itypi1=iabs(itype(i+1))
2644         xi=c(1,nres+i)
2645         yi=c(2,nres+i)
2646         zi=c(3,nres+i)
2647 C
2648 C Calculate SC interaction energy.
2649 C
2650 c        do iint=1,nint_gr(i)
2651 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2652 cd   &                  'iend=',iend(i,iint)
2653 c          do j=istart(i,iint),iend(i,iint)
2654             itypj=iabs(itype(j))
2655             if (itypj.eq.ntyp1) cycle
2656             xj=c(1,nres+j)-xi
2657             yj=c(2,nres+j)-yi
2658             zj=c(3,nres+j)-zi
2659             rij=xj*xj+yj*yj+zj*zj
2660 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2661             r0ij=r0(itypi,itypj)
2662             r0ijsq=r0ij*r0ij
2663 c            print *,i,j,r0ij,dsqrt(rij)
2664             if (rij.lt.r0ijsq) then
2665               evdwij=0.25d0*(rij-r0ijsq)**2
2666               fac=rij-r0ijsq
2667             else
2668               evdwij=0.0d0
2669               fac=0.0d0
2670             endif
2671             evdw=evdw+evdwij
2672 C
2673 C Calculate the components of the gradient in DC and X
2674 C
2675             gg(1)=xj*fac
2676             gg(2)=yj*fac
2677             gg(3)=zj*fac
2678             do k=1,3
2679               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2680               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2681               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2682               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2683             enddo
2684 cgrad            do k=i,j-1
2685 cgrad              do l=1,3
2686 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2687 cgrad              enddo
2688 cgrad            enddo
2689 c          enddo ! j
2690 c        enddo ! iint
2691       enddo ! i
2692       return
2693       end
2694 C--------------------------------------------------------------------------
2695       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2696      &              eello_turn4)
2697 C
2698 C Soft-sphere potential of p-p interaction
2699 C
2700       implicit real*8 (a-h,o-z)
2701       include 'DIMENSIONS'
2702       include 'COMMON.CONTROL'
2703       include 'COMMON.IOUNITS'
2704       include 'COMMON.GEO'
2705       include 'COMMON.VAR'
2706       include 'COMMON.LOCAL'
2707       include 'COMMON.CHAIN'
2708       include 'COMMON.DERIV'
2709       include 'COMMON.INTERACT'
2710 c      include 'COMMON.CONTACTS'
2711       include 'COMMON.TORSION'
2712       include 'COMMON.VECTORS'
2713       include 'COMMON.FFIELD'
2714       dimension ggg(3)
2715       integer xshift,yshift,zshift
2716 C      write(iout,*) 'In EELEC_soft_sphere'
2717       ees=0.0D0
2718       evdw1=0.0D0
2719       eel_loc=0.0d0
2720       eello_turn3=0.0d0
2721       eello_turn4=0.0d0
2722       ind=0
2723       do i=iatel_s,iatel_e
2724         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2725         dxi=dc(1,i)
2726         dyi=dc(2,i)
2727         dzi=dc(3,i)
2728         xmedi=c(1,i)+0.5d0*dxi
2729         ymedi=c(2,i)+0.5d0*dyi
2730         zmedi=c(3,i)+0.5d0*dzi
2731           xmedi=mod(xmedi,boxxsize)
2732           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2733           ymedi=mod(ymedi,boxysize)
2734           if (ymedi.lt.0) ymedi=ymedi+boxysize
2735           zmedi=mod(zmedi,boxzsize)
2736           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2737         num_conti=0
2738 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2739         do j=ielstart(i),ielend(i)
2740           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2741           ind=ind+1
2742           iteli=itel(i)
2743           itelj=itel(j)
2744           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2745           r0ij=rpp(iteli,itelj)
2746           r0ijsq=r0ij*r0ij
2747           dxj=dc(1,j)
2748           dyj=dc(2,j)
2749           dzj=dc(3,j)
2750           xj=c(1,j)+0.5D0*dxj
2751           yj=c(2,j)+0.5D0*dyj
2752           zj=c(3,j)+0.5D0*dzj
2753           xj=mod(xj,boxxsize)
2754           if (xj.lt.0) xj=xj+boxxsize
2755           yj=mod(yj,boxysize)
2756           if (yj.lt.0) yj=yj+boxysize
2757           zj=mod(zj,boxzsize)
2758           if (zj.lt.0) zj=zj+boxzsize
2759       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2760       xj_safe=xj
2761       yj_safe=yj
2762       zj_safe=zj
2763       isubchap=0
2764       do xshift=-1,1
2765       do yshift=-1,1
2766       do zshift=-1,1
2767           xj=xj_safe+xshift*boxxsize
2768           yj=yj_safe+yshift*boxysize
2769           zj=zj_safe+zshift*boxzsize
2770           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2771           if(dist_temp.lt.dist_init) then
2772             dist_init=dist_temp
2773             xj_temp=xj
2774             yj_temp=yj
2775             zj_temp=zj
2776             isubchap=1
2777           endif
2778        enddo
2779        enddo
2780        enddo
2781        if (isubchap.eq.1) then
2782           xj=xj_temp-xmedi
2783           yj=yj_temp-ymedi
2784           zj=zj_temp-zmedi
2785        else
2786           xj=xj_safe-xmedi
2787           yj=yj_safe-ymedi
2788           zj=zj_safe-zmedi
2789        endif
2790           rij=xj*xj+yj*yj+zj*zj
2791             sss=sscale(sqrt(rij),r_cut_int)
2792             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2793           if (rij.lt.r0ijsq) then
2794             evdw1ij=0.25d0*(rij-r0ijsq)**2
2795             fac=rij-r0ijsq
2796           else
2797             evdw1ij=0.0d0
2798             fac=0.0d0
2799           endif
2800           evdw1=evdw1+evdw1ij*sss
2801 C
2802 C Calculate contributions to the Cartesian gradient.
2803 C
2804           ggg(1)=fac*xj*sssgrad
2805           ggg(2)=fac*yj*sssgrad
2806           ggg(3)=fac*zj*sssgrad
2807           do k=1,3
2808             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2809             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2810           enddo
2811 *
2812 * Loop over residues i+1 thru j-1.
2813 *
2814 cgrad          do k=i+1,j-1
2815 cgrad            do l=1,3
2816 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2817 cgrad            enddo
2818 cgrad          enddo
2819         enddo ! j
2820       enddo   ! i
2821 cgrad      do i=nnt,nct-1
2822 cgrad        do k=1,3
2823 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2824 cgrad        enddo
2825 cgrad        do j=i+1,nct-1
2826 cgrad          do k=1,3
2827 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2828 cgrad          enddo
2829 cgrad        enddo
2830 cgrad      enddo
2831       return
2832       end
2833 c------------------------------------------------------------------------------
2834       subroutine vec_and_deriv
2835       implicit real*8 (a-h,o-z)
2836       include 'DIMENSIONS'
2837 #ifdef MPI
2838       include 'mpif.h'
2839 #endif
2840       include 'COMMON.IOUNITS'
2841       include 'COMMON.GEO'
2842       include 'COMMON.VAR'
2843       include 'COMMON.LOCAL'
2844       include 'COMMON.CHAIN'
2845       include 'COMMON.VECTORS'
2846       include 'COMMON.SETUP'
2847       include 'COMMON.TIME1'
2848       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2849 C Compute the local reference systems. For reference system (i), the
2850 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2851 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2852 #ifdef PARVEC
2853       do i=ivec_start,ivec_end
2854 #else
2855       do i=1,nres-1
2856 #endif
2857           if (i.eq.nres-1) then
2858 C Case of the last full residue
2859 C Compute the Z-axis
2860             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2861             costh=dcos(pi-theta(nres))
2862             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2863             do k=1,3
2864               uz(k,i)=fac*uz(k,i)
2865             enddo
2866 C Compute the derivatives of uz
2867             uzder(1,1,1)= 0.0d0
2868             uzder(2,1,1)=-dc_norm(3,i-1)
2869             uzder(3,1,1)= dc_norm(2,i-1)
2870             uzder(1,2,1)= dc_norm(3,i-1)
2871             uzder(2,2,1)= 0.0d0
2872             uzder(3,2,1)=-dc_norm(1,i-1)
2873             uzder(1,3,1)=-dc_norm(2,i-1)
2874             uzder(2,3,1)= dc_norm(1,i-1)
2875             uzder(3,3,1)= 0.0d0
2876             uzder(1,1,2)= 0.0d0
2877             uzder(2,1,2)= dc_norm(3,i)
2878             uzder(3,1,2)=-dc_norm(2,i)
2879             uzder(1,2,2)=-dc_norm(3,i)
2880             uzder(2,2,2)= 0.0d0
2881             uzder(3,2,2)= dc_norm(1,i)
2882             uzder(1,3,2)= dc_norm(2,i)
2883             uzder(2,3,2)=-dc_norm(1,i)
2884             uzder(3,3,2)= 0.0d0
2885 C Compute the Y-axis
2886             facy=fac
2887             do k=1,3
2888               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2889             enddo
2890 C Compute the derivatives of uy
2891             do j=1,3
2892               do k=1,3
2893                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2894      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2895                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2896               enddo
2897               uyder(j,j,1)=uyder(j,j,1)-costh
2898               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2899             enddo
2900             do j=1,2
2901               do k=1,3
2902                 do l=1,3
2903                   uygrad(l,k,j,i)=uyder(l,k,j)
2904                   uzgrad(l,k,j,i)=uzder(l,k,j)
2905                 enddo
2906               enddo
2907             enddo
2908             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2909             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2910             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2911             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2912           else
2913 C Other residues
2914 C Compute the Z-axis
2915             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2916             costh=dcos(pi-theta(i+2))
2917             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2918             do k=1,3
2919               uz(k,i)=fac*uz(k,i)
2920             enddo
2921 C Compute the derivatives of uz
2922             uzder(1,1,1)= 0.0d0
2923             uzder(2,1,1)=-dc_norm(3,i+1)
2924             uzder(3,1,1)= dc_norm(2,i+1)
2925             uzder(1,2,1)= dc_norm(3,i+1)
2926             uzder(2,2,1)= 0.0d0
2927             uzder(3,2,1)=-dc_norm(1,i+1)
2928             uzder(1,3,1)=-dc_norm(2,i+1)
2929             uzder(2,3,1)= dc_norm(1,i+1)
2930             uzder(3,3,1)= 0.0d0
2931             uzder(1,1,2)= 0.0d0
2932             uzder(2,1,2)= dc_norm(3,i)
2933             uzder(3,1,2)=-dc_norm(2,i)
2934             uzder(1,2,2)=-dc_norm(3,i)
2935             uzder(2,2,2)= 0.0d0
2936             uzder(3,2,2)= dc_norm(1,i)
2937             uzder(1,3,2)= dc_norm(2,i)
2938             uzder(2,3,2)=-dc_norm(1,i)
2939             uzder(3,3,2)= 0.0d0
2940 C Compute the Y-axis
2941             facy=fac
2942             do k=1,3
2943               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2944             enddo
2945 C Compute the derivatives of uy
2946             do j=1,3
2947               do k=1,3
2948                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2949      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2950                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2951               enddo
2952               uyder(j,j,1)=uyder(j,j,1)-costh
2953               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2954             enddo
2955             do j=1,2
2956               do k=1,3
2957                 do l=1,3
2958                   uygrad(l,k,j,i)=uyder(l,k,j)
2959                   uzgrad(l,k,j,i)=uzder(l,k,j)
2960                 enddo
2961               enddo
2962             enddo
2963             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2964             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2965             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2966             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2967           endif
2968       enddo
2969       do i=1,nres-1
2970         vbld_inv_temp(1)=vbld_inv(i+1)
2971         if (i.lt.nres-1) then
2972           vbld_inv_temp(2)=vbld_inv(i+2)
2973           else
2974           vbld_inv_temp(2)=vbld_inv(i)
2975           endif
2976         do j=1,2
2977           do k=1,3
2978             do l=1,3
2979               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2980               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2981             enddo
2982           enddo
2983         enddo
2984       enddo
2985 #if defined(PARVEC) && defined(MPI)
2986       if (nfgtasks1.gt.1) then
2987         time00=MPI_Wtime()
2988 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2989 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2990 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2991         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2992      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2993      &   FG_COMM1,IERR)
2994         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2995      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2996      &   FG_COMM1,IERR)
2997         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2998      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2999      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
3000         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
3001      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
3002      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
3003         time_gather=time_gather+MPI_Wtime()-time00
3004       endif
3005 #endif
3006 #ifdef DEBUG
3007       if (fg_rank.eq.0) then
3008         write (iout,*) "Arrays UY and UZ"
3009         do i=1,nres-1
3010           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
3011      &     (uz(k,i),k=1,3)
3012         enddo
3013       endif
3014 #endif
3015       return
3016       end
3017 C--------------------------------------------------------------------------
3018       subroutine set_matrices
3019       implicit real*8 (a-h,o-z)
3020       include 'DIMENSIONS'
3021 #ifdef MPI
3022       include "mpif.h"
3023       include "COMMON.SETUP"
3024       integer IERR
3025       integer status(MPI_STATUS_SIZE)
3026 #endif
3027       include 'COMMON.IOUNITS'
3028       include 'COMMON.GEO'
3029       include 'COMMON.VAR'
3030       include 'COMMON.LOCAL'
3031       include 'COMMON.CHAIN'
3032       include 'COMMON.DERIV'
3033       include 'COMMON.INTERACT'
3034       include 'COMMON.CORRMAT'
3035       include 'COMMON.TORSION'
3036       include 'COMMON.VECTORS'
3037       include 'COMMON.FFIELD'
3038       double precision auxvec(2),auxmat(2,2)
3039 C
3040 C Compute the virtual-bond-torsional-angle dependent quantities needed
3041 C to calculate the el-loc multibody terms of various order.
3042 C
3043 c      write(iout,*) 'nphi=',nphi,nres
3044 c      write(iout,*) "itype2loc",itype2loc
3045 #ifdef PARMAT
3046       do i=ivec_start+2,ivec_end+2
3047 #else
3048       do i=3,nres+1
3049 #endif
3050         ii=ireschain(i-2)
3051 c        write (iout,*) "i",i,i-2," ii",ii
3052         if (ii.eq.0) cycle
3053         innt=chain_border(1,ii)
3054         inct=chain_border(2,ii)
3055 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3056 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3057         if (i.gt. innt+2 .and. i.lt.inct+2) then
3058           iti = itype2loc(itype(i-2))
3059         else
3060           iti=nloctyp
3061         endif
3062 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3063         if (i.gt. innt+1 .and. i.lt.inct+1) then
3064           iti1 = itype2loc(itype(i-1))
3065         else
3066           iti1=nloctyp
3067         endif
3068 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3069 c     &  " iti1",itype(i-1),iti1
3070 #ifdef NEWCORR
3071         cost1=dcos(theta(i-1))
3072         sint1=dsin(theta(i-1))
3073         sint1sq=sint1*sint1
3074         sint1cub=sint1sq*sint1
3075         sint1cost1=2*sint1*cost1
3076 c        write (iout,*) "bnew1",i,iti
3077 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
3078 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3079 c        write (iout,*) "bnew2",i,iti
3080 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3081 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3082         do k=1,2
3083           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3084           b1(k,i-2)=sint1*b1k
3085           gtb1(k,i-2)=cost1*b1k-sint1sq*
3086      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3087           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3088           b2(k,i-2)=sint1*b2k
3089           gtb2(k,i-2)=cost1*b2k-sint1sq*
3090      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3091         enddo
3092         do k=1,2
3093           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3094           cc(1,k,i-2)=sint1sq*aux
3095           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3096      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3097           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3098           dd(1,k,i-2)=sint1sq*aux
3099           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3100      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3101         enddo
3102         cc(2,1,i-2)=cc(1,2,i-2)
3103         cc(2,2,i-2)=-cc(1,1,i-2)
3104         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3105         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3106         dd(2,1,i-2)=dd(1,2,i-2)
3107         dd(2,2,i-2)=-dd(1,1,i-2)
3108         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3109         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3110         do k=1,2
3111           do l=1,2
3112             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3113             EE(l,k,i-2)=sint1sq*aux
3114             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3115           enddo
3116         enddo
3117         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3118         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3119         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3120         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3121         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3122         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3123         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3124 c        b1tilde(1,i-2)=b1(1,i-2)
3125 c        b1tilde(2,i-2)=-b1(2,i-2)
3126 c        b2tilde(1,i-2)=b2(1,i-2)
3127 c        b2tilde(2,i-2)=-b2(2,i-2)
3128 #ifdef DEBUG
3129         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3130         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3131         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3132         write (iout,*) 'theta=', theta(i-1)
3133 #endif
3134 #else
3135         if (i.gt. innt+2 .and. i.lt.inct+2) then
3136 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3137           iti = itype2loc(itype(i-2))
3138         else
3139           iti=nloctyp
3140         endif
3141 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3142 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3143         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3144           iti1 = itype2loc(itype(i-1))
3145         else
3146           iti1=nloctyp
3147         endif
3148         b1(1,i-2)=b(3,iti)
3149         b1(2,i-2)=b(5,iti)
3150         b2(1,i-2)=b(2,iti)
3151         b2(2,i-2)=b(4,iti)
3152         do k=1,2
3153           do l=1,2
3154            CC(k,l,i-2)=ccold(k,l,iti)
3155            DD(k,l,i-2)=ddold(k,l,iti)
3156            EE(k,l,i-2)=eeold(k,l,iti)
3157            gtEE(k,l,i-2)=0.0d0
3158           enddo
3159         enddo
3160 #endif
3161         b1tilde(1,i-2)= b1(1,i-2)
3162         b1tilde(2,i-2)=-b1(2,i-2)
3163         b2tilde(1,i-2)= b2(1,i-2)
3164         b2tilde(2,i-2)=-b2(2,i-2)
3165 c
3166         Ctilde(1,1,i-2)= CC(1,1,i-2)
3167         Ctilde(1,2,i-2)= CC(1,2,i-2)
3168         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3169         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3170 c
3171         Dtilde(1,1,i-2)= DD(1,1,i-2)
3172         Dtilde(1,2,i-2)= DD(1,2,i-2)
3173         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3174         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3175 #ifdef DEBUG
3176         write(iout,*) "i",i," iti",iti
3177         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3178         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3179 #endif
3180       enddo
3181       mu=0.0d0
3182 #ifdef PARMAT
3183       do i=ivec_start+2,ivec_end+2
3184 #else
3185       do i=3,nres+1
3186 #endif
3187 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3188         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3189           sin1=dsin(phi(i))
3190           cos1=dcos(phi(i))
3191           sintab(i-2)=sin1
3192           costab(i-2)=cos1
3193           obrot(1,i-2)=cos1
3194           obrot(2,i-2)=sin1
3195           sin2=dsin(2*phi(i))
3196           cos2=dcos(2*phi(i))
3197           sintab2(i-2)=sin2
3198           costab2(i-2)=cos2
3199           obrot2(1,i-2)=cos2
3200           obrot2(2,i-2)=sin2
3201           Ug(1,1,i-2)=-cos1
3202           Ug(1,2,i-2)=-sin1
3203           Ug(2,1,i-2)=-sin1
3204           Ug(2,2,i-2)= cos1
3205           Ug2(1,1,i-2)=-cos2
3206           Ug2(1,2,i-2)=-sin2
3207           Ug2(2,1,i-2)=-sin2
3208           Ug2(2,2,i-2)= cos2
3209         else
3210           costab(i-2)=1.0d0
3211           sintab(i-2)=0.0d0
3212           obrot(1,i-2)=1.0d0
3213           obrot(2,i-2)=0.0d0
3214           obrot2(1,i-2)=0.0d0
3215           obrot2(2,i-2)=0.0d0
3216           Ug(1,1,i-2)=1.0d0
3217           Ug(1,2,i-2)=0.0d0
3218           Ug(2,1,i-2)=0.0d0
3219           Ug(2,2,i-2)=1.0d0
3220           Ug2(1,1,i-2)=0.0d0
3221           Ug2(1,2,i-2)=0.0d0
3222           Ug2(2,1,i-2)=0.0d0
3223           Ug2(2,2,i-2)=0.0d0
3224         endif
3225         if (i .gt. 3) then
3226           obrot_der(1,i-2)=-sin1
3227           obrot_der(2,i-2)= cos1
3228           Ugder(1,1,i-2)= sin1
3229           Ugder(1,2,i-2)=-cos1
3230           Ugder(2,1,i-2)=-cos1
3231           Ugder(2,2,i-2)=-sin1
3232           dwacos2=cos2+cos2
3233           dwasin2=sin2+sin2
3234           obrot2_der(1,i-2)=-dwasin2
3235           obrot2_der(2,i-2)= dwacos2
3236           Ug2der(1,1,i-2)= dwasin2
3237           Ug2der(1,2,i-2)=-dwacos2
3238           Ug2der(2,1,i-2)=-dwacos2
3239           Ug2der(2,2,i-2)=-dwasin2
3240         else
3241           obrot_der(1,i-2)=0.0d0
3242           obrot_der(2,i-2)=0.0d0
3243           Ugder(1,1,i-2)=0.0d0
3244           Ugder(1,2,i-2)=0.0d0
3245           Ugder(2,1,i-2)=0.0d0
3246           Ugder(2,2,i-2)=0.0d0
3247           obrot2_der(1,i-2)=0.0d0
3248           obrot2_der(2,i-2)=0.0d0
3249           Ug2der(1,1,i-2)=0.0d0
3250           Ug2der(1,2,i-2)=0.0d0
3251           Ug2der(2,1,i-2)=0.0d0
3252           Ug2der(2,2,i-2)=0.0d0
3253         endif
3254 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3255 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3256         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3257           iti = itype2loc(itype(i-2))
3258         else
3259           iti=nloctyp
3260         endif
3261 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3262         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3263           iti1 = itype2loc(itype(i-1))
3264         else
3265           iti1=nloctyp
3266         endif
3267 cd        write (iout,*) '*******i',i,' iti1',iti
3268 cd        write (iout,*) 'b1',b1(:,iti)
3269 cd        write (iout,*) 'b2',b2(:,iti)
3270 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3271 c        if (i .gt. iatel_s+2) then
3272         if (i .gt. nnt+2) then
3273           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3274 #ifdef NEWCORR
3275           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3276 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3277 #endif
3278 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3279 c     &    EE(1,2,iti),EE(2,2,i)
3280           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3281           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3282 c          write(iout,*) "Macierz EUG",
3283 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3284 c     &    eug(2,2,i-2)
3285 #ifdef FOURBODY
3286           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3287      &    then
3288           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3289           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3290           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3291           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3292           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3293           endif
3294 #endif
3295         else
3296           do k=1,2
3297             Ub2(k,i-2)=0.0d0
3298             Ctobr(k,i-2)=0.0d0
3299             Dtobr2(k,i-2)=0.0d0
3300             do l=1,2
3301               EUg(l,k,i-2)=0.0d0
3302               CUg(l,k,i-2)=0.0d0
3303               DUg(l,k,i-2)=0.0d0
3304               DtUg2(l,k,i-2)=0.0d0
3305             enddo
3306           enddo
3307         endif
3308         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3309         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3310         do k=1,2
3311           muder(k,i-2)=Ub2der(k,i-2)
3312         enddo
3313 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3314         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3315           if (itype(i-1).le.ntyp) then
3316             iti1 = itype2loc(itype(i-1))
3317           else
3318             iti1=nloctyp
3319           endif
3320         else
3321           iti1=nloctyp
3322         endif
3323         do k=1,2
3324           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3325 c          mu(k,i-2)=b1(k,i-1)
3326 c          mu(k,i-2)=Ub2(k,i-2)
3327         enddo
3328 #ifdef MUOUT
3329         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3330      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3331      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3332      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3333      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3334      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3335 #endif
3336 cd        write (iout,*) 'mu1',mu1(:,i-2)
3337 cd        write (iout,*) 'mu2',mu2(:,i-2)
3338 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3339 #ifdef FOURBODY
3340         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3341      &  then
3342         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3343         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3344         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3345         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3346         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3347 C Vectors and matrices dependent on a single virtual-bond dihedral.
3348         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3349         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3350         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3351         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3352         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3353         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3354         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3355         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3356         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3357         endif
3358 #endif
3359       enddo
3360 #ifdef FOURBODY
3361 C Matrices dependent on two consecutive virtual-bond dihedrals.
3362 C The order of matrices is from left to right.
3363       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3364      &then
3365 c      do i=max0(ivec_start,2),ivec_end
3366       do i=2,nres-1
3367         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3368         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3369         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3370         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3371         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3372         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3373         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3374         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3375       enddo
3376       endif
3377 #endif
3378 #if defined(MPI) && defined(PARMAT)
3379 #ifdef DEBUG
3380 c      if (fg_rank.eq.0) then
3381         write (iout,*) "Arrays UG and UGDER before GATHER"
3382         do i=1,nres-1
3383           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3384      &     ((ug(l,k,i),l=1,2),k=1,2),
3385      &     ((ugder(l,k,i),l=1,2),k=1,2)
3386         enddo
3387         write (iout,*) "Arrays UG2 and UG2DER"
3388         do i=1,nres-1
3389           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3390      &     ((ug2(l,k,i),l=1,2),k=1,2),
3391      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3392         enddo
3393         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3394         do i=1,nres-1
3395           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3396      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3397      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3398         enddo
3399         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3400         do i=1,nres-1
3401           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3402      &     costab(i),sintab(i),costab2(i),sintab2(i)
3403         enddo
3404         write (iout,*) "Array MUDER"
3405         do i=1,nres-1
3406           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3407         enddo
3408 c      endif
3409 #endif
3410       if (nfgtasks.gt.1) then
3411         time00=MPI_Wtime()
3412 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3413 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3414 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3415 #ifdef MATGATHER
3416         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3417      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3418      &   FG_COMM1,IERR)
3419         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3420      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3421      &   FG_COMM1,IERR)
3422         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3423      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3424      &   FG_COMM1,IERR)
3425         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3426      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3427      &   FG_COMM1,IERR)
3428         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3429      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3430      &   FG_COMM1,IERR)
3431         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3432      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3433      &   FG_COMM1,IERR)
3434         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3435      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3436      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3437         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3438      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3439      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3440         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3441      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3442      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3443         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3444      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3445      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3446 #ifdef FOURBODY
3447         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3448      &  then
3449         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3450      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3451      &   FG_COMM1,IERR)
3452         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3453      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3454      &   FG_COMM1,IERR)
3455         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3456      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3457      &   FG_COMM1,IERR)
3458        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3459      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3460      &   FG_COMM1,IERR)
3461         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3462      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3463      &   FG_COMM1,IERR)
3464         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3465      &   ivec_count(fg_rank1),
3466      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3467      &   FG_COMM1,IERR)
3468         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3469      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3470      &   FG_COMM1,IERR)
3471         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3472      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3473      &   FG_COMM1,IERR)
3474         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3475      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3476      &   FG_COMM1,IERR)
3477         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3478      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3479      &   FG_COMM1,IERR)
3480         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3481      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3482      &   FG_COMM1,IERR)
3483         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3484      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3485      &   FG_COMM1,IERR)
3486         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3487      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3488      &   FG_COMM1,IERR)
3489         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3490      &   ivec_count(fg_rank1),
3491      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3492      &   FG_COMM1,IERR)
3493         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3494      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3495      &   FG_COMM1,IERR)
3496        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3497      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3498      &   FG_COMM1,IERR)
3499         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3500      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3501      &   FG_COMM1,IERR)
3502        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3503      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3504      &   FG_COMM1,IERR)
3505         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3506      &   ivec_count(fg_rank1),
3507      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3508      &   FG_COMM1,IERR)
3509         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3510      &   ivec_count(fg_rank1),
3511      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3512      &   FG_COMM1,IERR)
3513         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3514      &   ivec_count(fg_rank1),
3515      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3516      &   MPI_MAT2,FG_COMM1,IERR)
3517         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3518      &   ivec_count(fg_rank1),
3519      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3520      &   MPI_MAT2,FG_COMM1,IERR)
3521         endif
3522 #endif
3523 #else
3524 c Passes matrix info through the ring
3525       isend=fg_rank1
3526       irecv=fg_rank1-1
3527       if (irecv.lt.0) irecv=nfgtasks1-1
3528       iprev=irecv
3529       inext=fg_rank1+1
3530       if (inext.ge.nfgtasks1) inext=0
3531       do i=1,nfgtasks1-1
3532 c        write (iout,*) "isend",isend," irecv",irecv
3533 c        call flush(iout)
3534         lensend=lentyp(isend)
3535         lenrecv=lentyp(irecv)
3536 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3537 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3538 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3539 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3540 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3541 c        write (iout,*) "Gather ROTAT1"
3542 c        call flush(iout)
3543 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3544 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3545 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3546 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3547 c        write (iout,*) "Gather ROTAT2"
3548 c        call flush(iout)
3549         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3550      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3551      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3552      &   iprev,4400+irecv,FG_COMM,status,IERR)
3553 c        write (iout,*) "Gather ROTAT_OLD"
3554 c        call flush(iout)
3555         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3556      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3557      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3558      &   iprev,5500+irecv,FG_COMM,status,IERR)
3559 c        write (iout,*) "Gather PRECOMP11"
3560 c        call flush(iout)
3561         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3562      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3563      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3564      &   iprev,6600+irecv,FG_COMM,status,IERR)
3565 c        write (iout,*) "Gather PRECOMP12"
3566 c        call flush(iout)
3567 #ifdef FOURBODY
3568         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3569      &  then
3570         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3571      &   MPI_ROTAT2(lensend),inext,7700+isend,
3572      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3573      &   iprev,7700+irecv,FG_COMM,status,IERR)
3574 c        write (iout,*) "Gather PRECOMP21"
3575 c        call flush(iout)
3576         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3577      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3578      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3579      &   iprev,8800+irecv,FG_COMM,status,IERR)
3580 c        write (iout,*) "Gather PRECOMP22"
3581 c        call flush(iout)
3582         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3583      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3584      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3585      &   MPI_PRECOMP23(lenrecv),
3586      &   iprev,9900+irecv,FG_COMM,status,IERR)
3587 #endif
3588 c        write (iout,*) "Gather PRECOMP23"
3589 c        call flush(iout)
3590         endif
3591         isend=irecv
3592         irecv=irecv-1
3593         if (irecv.lt.0) irecv=nfgtasks1-1
3594       enddo
3595 #endif
3596         time_gather=time_gather+MPI_Wtime()-time00
3597       endif
3598 #ifdef DEBUG
3599 c      if (fg_rank.eq.0) then
3600         write (iout,*) "Arrays UG and UGDER"
3601         do i=1,nres-1
3602           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3603      &     ((ug(l,k,i),l=1,2),k=1,2),
3604      &     ((ugder(l,k,i),l=1,2),k=1,2)
3605         enddo
3606         write (iout,*) "Arrays UG2 and UG2DER"
3607         do i=1,nres-1
3608           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3609      &     ((ug2(l,k,i),l=1,2),k=1,2),
3610      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3611         enddo
3612         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3613         do i=1,nres-1
3614           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3615      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3616      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3617         enddo
3618         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3619         do i=1,nres-1
3620           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3621      &     costab(i),sintab(i),costab2(i),sintab2(i)
3622         enddo
3623         write (iout,*) "Array MUDER"
3624         do i=1,nres-1
3625           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3626         enddo
3627 c      endif
3628 #endif
3629 #endif
3630 cd      do i=1,nres
3631 cd        iti = itype2loc(itype(i))
3632 cd        write (iout,*) i
3633 cd        do j=1,2
3634 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3635 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3636 cd        enddo
3637 cd      enddo
3638       return
3639       end
3640 C-----------------------------------------------------------------------------
3641       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3642 C
3643 C This subroutine calculates the average interaction energy and its gradient
3644 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3645 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3646 C The potential depends both on the distance of peptide-group centers and on
3647 C the orientation of the CA-CA virtual bonds.
3648 C
3649       implicit real*8 (a-h,o-z)
3650 #ifdef MPI
3651       include 'mpif.h'
3652 #endif
3653       include 'DIMENSIONS'
3654       include 'COMMON.CONTROL'
3655       include 'COMMON.SETUP'
3656       include 'COMMON.IOUNITS'
3657       include 'COMMON.GEO'
3658       include 'COMMON.VAR'
3659       include 'COMMON.LOCAL'
3660       include 'COMMON.CHAIN'
3661       include 'COMMON.DERIV'
3662       include 'COMMON.INTERACT'
3663 #ifdef FOURBODY
3664       include 'COMMON.CONTACTS'
3665       include 'COMMON.CONTMAT'
3666 #endif
3667       include 'COMMON.CORRMAT'
3668       include 'COMMON.TORSION'
3669       include 'COMMON.VECTORS'
3670       include 'COMMON.FFIELD'
3671       include 'COMMON.TIME1'
3672       include 'COMMON.SPLITELE'
3673       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3674      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3675       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3676      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3677       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3678      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3679      &    num_conti,j1,j2
3680 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3681 #ifdef MOMENT
3682       double precision scal_el /1.0d0/
3683 #else
3684       double precision scal_el /0.5d0/
3685 #endif
3686 C 12/13/98
3687 C 13-go grudnia roku pamietnego...
3688       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3689      &                   0.0d0,1.0d0,0.0d0,
3690      &                   0.0d0,0.0d0,1.0d0/
3691 cd      write(iout,*) 'In EELEC'
3692 cd      do i=1,nloctyp
3693 cd        write(iout,*) 'Type',i
3694 cd        write(iout,*) 'B1',B1(:,i)
3695 cd        write(iout,*) 'B2',B2(:,i)
3696 cd        write(iout,*) 'CC',CC(:,:,i)
3697 cd        write(iout,*) 'DD',DD(:,:,i)
3698 cd        write(iout,*) 'EE',EE(:,:,i)
3699 cd      enddo
3700 cd      call check_vecgrad
3701 cd      stop
3702       if (icheckgrad.eq.1) then
3703         do i=1,nres-1
3704           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3705           do k=1,3
3706             dc_norm(k,i)=dc(k,i)*fac
3707           enddo
3708 c          write (iout,*) 'i',i,' fac',fac
3709         enddo
3710       endif
3711       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3712      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3713      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3714 c        call vec_and_deriv
3715 #ifdef TIMING
3716         time01=MPI_Wtime()
3717 #endif
3718         call set_matrices
3719 #ifdef TIMING
3720         time_mat=time_mat+MPI_Wtime()-time01
3721 #endif
3722       endif
3723 cd      do i=1,nres-1
3724 cd        write (iout,*) 'i=',i
3725 cd        do k=1,3
3726 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3727 cd        enddo
3728 cd        do k=1,3
3729 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3730 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3731 cd        enddo
3732 cd      enddo
3733       t_eelecij=0.0d0
3734       ees=0.0D0
3735       evdw1=0.0D0
3736       eel_loc=0.0d0
3737       eello_turn3=0.0d0
3738       eello_turn4=0.0d0
3739       ind=0
3740 #ifdef FOURBODY
3741       do i=1,nres
3742         num_cont_hb(i)=0
3743       enddo
3744 #endif
3745 cd      print '(a)','Enter EELEC'
3746 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3747       do i=1,nres
3748         gel_loc_loc(i)=0.0d0
3749         gcorr_loc(i)=0.0d0
3750       enddo
3751 c
3752 c
3753 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3754 C
3755 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3756 C
3757 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3758       do i=iturn3_start,iturn3_end
3759 c        if (i.le.1) cycle
3760 C        write(iout,*) "tu jest i",i
3761         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3762 C changes suggested by Ana to avoid out of bounds
3763 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3764 c     & .or.((i+4).gt.nres)
3765 c     & .or.((i-1).le.0)
3766 C end of changes by Ana
3767      &  .or. itype(i+2).eq.ntyp1
3768      &  .or. itype(i+3).eq.ntyp1) cycle
3769 C Adam: Instructions below will switch off existing interactions
3770 c        if(i.gt.1)then
3771 c          if(itype(i-1).eq.ntyp1)cycle
3772 c        end if
3773 c        if(i.LT.nres-3)then
3774 c          if (itype(i+4).eq.ntyp1) cycle
3775 c        end if
3776         dxi=dc(1,i)
3777         dyi=dc(2,i)
3778         dzi=dc(3,i)
3779         dx_normi=dc_norm(1,i)
3780         dy_normi=dc_norm(2,i)
3781         dz_normi=dc_norm(3,i)
3782         xmedi=c(1,i)+0.5d0*dxi
3783         ymedi=c(2,i)+0.5d0*dyi
3784         zmedi=c(3,i)+0.5d0*dzi
3785           xmedi=mod(xmedi,boxxsize)
3786           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3787           ymedi=mod(ymedi,boxysize)
3788           if (ymedi.lt.0) ymedi=ymedi+boxysize
3789           zmedi=mod(zmedi,boxzsize)
3790           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3791         num_conti=0
3792         call eelecij(i,i+2,ees,evdw1,eel_loc)
3793         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3794 #ifdef FOURBODY
3795         num_cont_hb(i)=num_conti
3796 #endif
3797       enddo
3798       do i=iturn4_start,iturn4_end
3799         if (i.lt.1) cycle
3800         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3801 C changes suggested by Ana to avoid out of bounds
3802 c     & .or.((i+5).gt.nres)
3803 c     & .or.((i-1).le.0)
3804 C end of changes suggested by Ana
3805      &    .or. itype(i+3).eq.ntyp1
3806      &    .or. itype(i+4).eq.ntyp1
3807 c     &    .or. itype(i+5).eq.ntyp1
3808 c     &    .or. itype(i).eq.ntyp1
3809 c     &    .or. itype(i-1).eq.ntyp1
3810      &                             ) cycle
3811         dxi=dc(1,i)
3812         dyi=dc(2,i)
3813         dzi=dc(3,i)
3814         dx_normi=dc_norm(1,i)
3815         dy_normi=dc_norm(2,i)
3816         dz_normi=dc_norm(3,i)
3817         xmedi=c(1,i)+0.5d0*dxi
3818         ymedi=c(2,i)+0.5d0*dyi
3819         zmedi=c(3,i)+0.5d0*dzi
3820 C Return atom into box, boxxsize is size of box in x dimension
3821 c  194   continue
3822 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3823 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3824 C Condition for being inside the proper box
3825 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3826 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3827 c        go to 194
3828 c        endif
3829 c  195   continue
3830 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3831 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3832 C Condition for being inside the proper box
3833 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3834 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3835 c        go to 195
3836 c        endif
3837 c  196   continue
3838 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3839 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3840 C Condition for being inside the proper box
3841 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3842 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3843 c        go to 196
3844 c        endif
3845           xmedi=mod(xmedi,boxxsize)
3846           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3847           ymedi=mod(ymedi,boxysize)
3848           if (ymedi.lt.0) ymedi=ymedi+boxysize
3849           zmedi=mod(zmedi,boxzsize)
3850           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3851
3852 #ifdef FOURBODY
3853         num_conti=num_cont_hb(i)
3854 #endif
3855 c        write(iout,*) "JESTEM W PETLI"
3856         call eelecij(i,i+3,ees,evdw1,eel_loc)
3857         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3858      &   call eturn4(i,eello_turn4)
3859 #ifdef FOURBODY
3860         num_cont_hb(i)=num_conti
3861 #endif
3862       enddo   ! i
3863 C Loop over all neighbouring boxes
3864 C      do xshift=-1,1
3865 C      do yshift=-1,1
3866 C      do zshift=-1,1
3867 c
3868 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3869 c
3870 CTU KURWA
3871 c      do i=iatel_s,iatel_e
3872        do icont=g_listpp_start,g_listpp_end
3873         i=newcontlistppi(icont)
3874         j=newcontlistppj(icont)
3875 C        do i=75,75
3876 c        if (i.le.1) cycle
3877         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3878 C changes suggested by Ana to avoid out of bounds
3879 c     & .or.((i+2).gt.nres)
3880 c     & .or.((i-1).le.0)
3881 C end of changes by Ana
3882 c     &  .or. itype(i+2).eq.ntyp1
3883 c     &  .or. itype(i-1).eq.ntyp1
3884      &                ) cycle
3885         dxi=dc(1,i)
3886         dyi=dc(2,i)
3887         dzi=dc(3,i)
3888         dx_normi=dc_norm(1,i)
3889         dy_normi=dc_norm(2,i)
3890         dz_normi=dc_norm(3,i)
3891         xmedi=c(1,i)+0.5d0*dxi
3892         ymedi=c(2,i)+0.5d0*dyi
3893         zmedi=c(3,i)+0.5d0*dzi
3894           xmedi=mod(xmedi,boxxsize)
3895           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3896           ymedi=mod(ymedi,boxysize)
3897           if (ymedi.lt.0) ymedi=ymedi+boxysize
3898           zmedi=mod(zmedi,boxzsize)
3899           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3900 C          xmedi=xmedi+xshift*boxxsize
3901 C          ymedi=ymedi+yshift*boxysize
3902 C          zmedi=zmedi+zshift*boxzsize
3903
3904 C Return tom into box, boxxsize is size of box in x dimension
3905 c  164   continue
3906 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3907 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3908 C Condition for being inside the proper box
3909 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3910 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3911 c        go to 164
3912 c        endif
3913 c  165   continue
3914 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3915 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3916 C Condition for being inside the proper box
3917 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3918 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3919 c        go to 165
3920 c        endif
3921 c  166   continue
3922 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3923 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3924 cC Condition for being inside the proper box
3925 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3926 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3927 c        go to 166
3928 c        endif
3929
3930 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3931 #ifdef FOURBODY
3932         num_conti=num_cont_hb(i)
3933 #endif
3934 C I TU KURWA
3935 c        do j=ielstart(i),ielend(i)
3936 C          do j=16,17
3937 C          write (iout,*) i,j
3938 C         if (j.le.1) cycle
3939           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3940 C changes suggested by Ana to avoid out of bounds
3941 c     & .or.((j+2).gt.nres)
3942 c     & .or.((j-1).le.0)
3943 C end of changes by Ana
3944 c     & .or.itype(j+2).eq.ntyp1
3945 c     & .or.itype(j-1).eq.ntyp1
3946      &) cycle
3947           call eelecij(i,j,ees,evdw1,eel_loc)
3948 c        enddo ! j
3949 #ifdef FOURBODY
3950         num_cont_hb(i)=num_conti
3951 #endif
3952       enddo   ! i
3953 C     enddo   ! zshift
3954 C      enddo   ! yshift
3955 C      enddo   ! xshift
3956
3957 c      write (iout,*) "Number of loop steps in EELEC:",ind
3958 cd      do i=1,nres
3959 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3960 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3961 cd      enddo
3962 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3963 ccc      eel_loc=eel_loc+eello_turn3
3964 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3965       return
3966       end
3967 C-------------------------------------------------------------------------------
3968       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3969       implicit none
3970       include 'DIMENSIONS'
3971 #ifdef MPI
3972       include "mpif.h"
3973 #endif
3974       include 'COMMON.CONTROL'
3975       include 'COMMON.IOUNITS'
3976       include 'COMMON.GEO'
3977       include 'COMMON.VAR'
3978       include 'COMMON.LOCAL'
3979       include 'COMMON.CHAIN'
3980       include 'COMMON.DERIV'
3981       include 'COMMON.INTERACT'
3982 #ifdef FOURBODY
3983       include 'COMMON.CONTACTS'
3984       include 'COMMON.CONTMAT'
3985 #endif
3986       include 'COMMON.CORRMAT'
3987       include 'COMMON.TORSION'
3988       include 'COMMON.VECTORS'
3989       include 'COMMON.FFIELD'
3990       include 'COMMON.TIME1'
3991       include 'COMMON.SPLITELE'
3992       include 'COMMON.SHIELD'
3993       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3994      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3995       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3996      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3997      &    gmuij2(4),gmuji2(4)
3998       double precision dxi,dyi,dzi
3999       double precision dx_normi,dy_normi,dz_normi,aux
4000       integer j1,j2,lll,num_conti
4001       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4002      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4003      &    num_conti,j1,j2
4004       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
4005       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
4006       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
4007       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
4008      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
4009      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
4010      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
4011      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
4012      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
4013      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
4014      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
4015       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
4016       double precision dist_init,xj_safe,yj_safe,zj_safe,
4017      &  xj_temp,yj_temp,zj_temp,dist_temp,xmedi,ymedi,zmedi
4018       double precision sscale,sscagrad,scalar
4019
4020 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
4021 #ifdef MOMENT
4022       double precision scal_el /1.0d0/
4023 #else
4024       double precision scal_el /0.5d0/
4025 #endif
4026 C 12/13/98
4027 C 13-go grudnia roku pamietnego...
4028       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4029      &                   0.0d0,1.0d0,0.0d0,
4030      &                   0.0d0,0.0d0,1.0d0/
4031        integer xshift,yshift,zshift
4032 c          time00=MPI_Wtime()
4033 cd      write (iout,*) "eelecij",i,j
4034 c          ind=ind+1
4035           iteli=itel(i)
4036           itelj=itel(j)
4037           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4038           aaa=app(iteli,itelj)
4039           bbb=bpp(iteli,itelj)
4040           ael6i=ael6(iteli,itelj)
4041           ael3i=ael3(iteli,itelj)
4042           dxj=dc(1,j)
4043           dyj=dc(2,j)
4044           dzj=dc(3,j)
4045           dx_normj=dc_norm(1,j)
4046           dy_normj=dc_norm(2,j)
4047           dz_normj=dc_norm(3,j)
4048 C          xj=c(1,j)+0.5D0*dxj-xmedi
4049 C          yj=c(2,j)+0.5D0*dyj-ymedi
4050 C          zj=c(3,j)+0.5D0*dzj-zmedi
4051           xj=c(1,j)+0.5D0*dxj
4052           yj=c(2,j)+0.5D0*dyj
4053           zj=c(3,j)+0.5D0*dzj
4054           xj=mod(xj,boxxsize)
4055           if (xj.lt.0) xj=xj+boxxsize
4056           yj=mod(yj,boxysize)
4057           if (yj.lt.0) yj=yj+boxysize
4058           zj=mod(zj,boxzsize)
4059           if (zj.lt.0) zj=zj+boxzsize
4060           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4061       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4062       xj_safe=xj
4063       yj_safe=yj
4064       zj_safe=zj
4065       isubchap=0
4066       do xshift=-1,1
4067       do yshift=-1,1
4068       do zshift=-1,1
4069           xj=xj_safe+xshift*boxxsize
4070           yj=yj_safe+yshift*boxysize
4071           zj=zj_safe+zshift*boxzsize
4072           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4073           if(dist_temp.lt.dist_init) then
4074             dist_init=dist_temp
4075             xj_temp=xj
4076             yj_temp=yj
4077             zj_temp=zj
4078             isubchap=1
4079           endif
4080        enddo
4081        enddo
4082        enddo
4083        if (isubchap.eq.1) then
4084           xj=xj_temp-xmedi
4085           yj=yj_temp-ymedi
4086           zj=zj_temp-zmedi
4087        else
4088           xj=xj_safe-xmedi
4089           yj=yj_safe-ymedi
4090           zj=zj_safe-zmedi
4091        endif
4092 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4093 c  174   continue
4094 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4095 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4096 C Condition for being inside the proper box
4097 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4098 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4099 c        go to 174
4100 c        endif
4101 c  175   continue
4102 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4103 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4104 C Condition for being inside the proper box
4105 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4106 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4107 c        go to 175
4108 c        endif
4109 c  176   continue
4110 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4111 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4112 C Condition for being inside the proper box
4113 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4114 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4115 c        go to 176
4116 c        endif
4117 C        endif !endPBC condintion
4118 C        xj=xj-xmedi
4119 C        yj=yj-ymedi
4120 C        zj=zj-zmedi
4121           rij=xj*xj+yj*yj+zj*zj
4122
4123           sss=sscale(dsqrt(rij),r_cut_int)
4124           if (sss.eq.0.0d0) return
4125           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
4126 c            if (sss.gt.0.0d0) then
4127           rrmij=1.0D0/rij
4128           rij=dsqrt(rij)
4129           rmij=1.0D0/rij
4130           r3ij=rrmij*rmij
4131           r6ij=r3ij*r3ij
4132           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4133           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4134           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4135           fac=cosa-3.0D0*cosb*cosg
4136           ev1=aaa*r6ij*r6ij
4137 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4138           if (j.eq.i+2) ev1=scal_el*ev1
4139           ev2=bbb*r6ij
4140           fac3=ael6i*r6ij
4141           fac4=ael3i*r3ij
4142           evdwij=(ev1+ev2)
4143           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4144           el2=fac4*fac
4145 C MARYSIA
4146 C          eesij=(el1+el2)
4147 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4148           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4149           if (shield_mode.gt.0) then
4150 C          fac_shield(i)=0.4
4151 C          fac_shield(j)=0.6
4152           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4153           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4154           eesij=(el1+el2)
4155           ees=ees+eesij
4156           else
4157           fac_shield(i)=1.0
4158           fac_shield(j)=1.0
4159           eesij=(el1+el2)
4160           ees=ees+eesij*sss
4161           endif
4162           evdw1=evdw1+evdwij*sss
4163 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4164 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4165 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4166 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4167
4168           if (energy_dec) then
4169             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4170      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4171             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4172      &        fac_shield(i),fac_shield(j)
4173           endif
4174
4175 C
4176 C Calculate contributions to the Cartesian gradient.
4177 C
4178 #ifdef SPLITELE
4179           facvdw=-6*rrmij*(ev1+evdwij)*sss
4180           facel=-3*rrmij*(el1+eesij)
4181           fac1=fac
4182           erij(1)=xj*rmij
4183           erij(2)=yj*rmij
4184           erij(3)=zj*rmij
4185
4186 *
4187 * Radial derivatives. First process both termini of the fragment (i,j)
4188 *
4189           aux=facel*sss+rmij*sssgrad*eesij
4190           ggg(1)=aux*xj
4191           ggg(2)=aux*yj
4192           ggg(3)=aux*zj
4193           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4194      &  (shield_mode.gt.0)) then
4195 C          print *,i,j
4196           do ilist=1,ishield_list(i)
4197            iresshield=shield_list(ilist,i)
4198            do k=1,3
4199            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4200      &      *2.0
4201            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4202      &              rlocshield
4203      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4204             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4205 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4206 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4207 C             if (iresshield.gt.i) then
4208 C               do ishi=i+1,iresshield-1
4209 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4210 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4211 C
4212 C              enddo
4213 C             else
4214 C               do ishi=iresshield,i
4215 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4216 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4217 C
4218 C               enddo
4219 C              endif
4220            enddo
4221           enddo
4222           do ilist=1,ishield_list(j)
4223            iresshield=shield_list(ilist,j)
4224            do k=1,3
4225            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4226      &     *2.0*sss
4227            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4228      &              rlocshield
4229      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4230            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4231
4232 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4233 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4234 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4235 C             if (iresshield.gt.j) then
4236 C               do ishi=j+1,iresshield-1
4237 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4238 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4239 C
4240 C               enddo
4241 C            else
4242 C               do ishi=iresshield,j
4243 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4244 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4245 C               enddo
4246 C              endif
4247            enddo
4248           enddo
4249
4250           do k=1,3
4251             gshieldc(k,i)=gshieldc(k,i)+
4252      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4253             gshieldc(k,j)=gshieldc(k,j)+
4254      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4255             gshieldc(k,i-1)=gshieldc(k,i-1)+
4256      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4257             gshieldc(k,j-1)=gshieldc(k,j-1)+
4258      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4259
4260            enddo
4261            endif
4262 c          do k=1,3
4263 c            ghalf=0.5D0*ggg(k)
4264 c            gelc(k,i)=gelc(k,i)+ghalf
4265 c            gelc(k,j)=gelc(k,j)+ghalf
4266 c          enddo
4267 c 9/28/08 AL Gradient compotents will be summed only at the end
4268 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4269           do k=1,3
4270             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4271 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4272             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4273 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4274 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4275 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4276 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4277 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4278           enddo
4279 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4280
4281 *
4282 * Loop over residues i+1 thru j-1.
4283 *
4284 cgrad          do k=i+1,j-1
4285 cgrad            do l=1,3
4286 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4287 cgrad            enddo
4288 cgrad          enddo
4289           facvdw=facvdw+sssgrad*rmij*evdwij
4290           ggg(1)=facvdw*xj
4291           ggg(2)=facvdw*yj
4292           ggg(3)=facvdw*zj
4293 c          do k=1,3
4294 c            ghalf=0.5D0*ggg(k)
4295 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4296 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4297 c          enddo
4298 c 9/28/08 AL Gradient compotents will be summed only at the end
4299           do k=1,3
4300             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4301             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4302           enddo
4303 *
4304 * Loop over residues i+1 thru j-1.
4305 *
4306 cgrad          do k=i+1,j-1
4307 cgrad            do l=1,3
4308 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4309 cgrad            enddo
4310 cgrad          enddo
4311 #else
4312 C MARYSIA
4313           facvdw=(ev1+evdwij)
4314           facel=(el1+eesij)
4315           fac1=fac
4316           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4317      &       +(evdwij+eesij)*sssgrad*rrmij
4318           erij(1)=xj*rmij
4319           erij(2)=yj*rmij
4320           erij(3)=zj*rmij
4321 *
4322 * Radial derivatives. First process both termini of the fragment (i,j)
4323 *
4324           ggg(1)=fac*xj
4325 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4326           ggg(2)=fac*yj
4327 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4328           ggg(3)=fac*zj
4329 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4330 c          do k=1,3
4331 c            ghalf=0.5D0*ggg(k)
4332 c            gelc(k,i)=gelc(k,i)+ghalf
4333 c            gelc(k,j)=gelc(k,j)+ghalf
4334 c          enddo
4335 c 9/28/08 AL Gradient compotents will be summed only at the end
4336           do k=1,3
4337             gelc_long(k,j)=gelc(k,j)+ggg(k)
4338             gelc_long(k,i)=gelc(k,i)-ggg(k)
4339           enddo
4340 *
4341 * Loop over residues i+1 thru j-1.
4342 *
4343 cgrad          do k=i+1,j-1
4344 cgrad            do l=1,3
4345 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4346 cgrad            enddo
4347 cgrad          enddo
4348 c 9/28/08 AL Gradient compotents will be summed only at the end
4349           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4350           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4351           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4352           do k=1,3
4353             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4354             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4355           enddo
4356 #endif
4357 *
4358 * Angular part
4359 *
4360           ecosa=2.0D0*fac3*fac1+fac4
4361           fac4=-3.0D0*fac4
4362           fac3=-6.0D0*fac3
4363           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4364           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4365           do k=1,3
4366             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4367             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4368           enddo
4369 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4370 cd   &          (dcosg(k),k=1,3)
4371           do k=1,3
4372             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4373      &      fac_shield(i)**2*fac_shield(j)**2*sss
4374           enddo
4375 c          do k=1,3
4376 c            ghalf=0.5D0*ggg(k)
4377 c            gelc(k,i)=gelc(k,i)+ghalf
4378 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4379 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4380 c            gelc(k,j)=gelc(k,j)+ghalf
4381 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4382 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4383 c          enddo
4384 cgrad          do k=i+1,j-1
4385 cgrad            do l=1,3
4386 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4387 cgrad            enddo
4388 cgrad          enddo
4389 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4390           do k=1,3
4391             gelc(k,i)=gelc(k,i)
4392      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4393      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4394      &           *fac_shield(i)**2*fac_shield(j)**2
4395             gelc(k,j)=gelc(k,j)
4396      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4397      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4398      &           *fac_shield(i)**2*fac_shield(j)**2
4399             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4400             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4401           enddo
4402 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4403
4404 C MARYSIA
4405 c          endif !sscale
4406           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4407      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4408      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4409 C
4410 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4411 C   energy of a peptide unit is assumed in the form of a second-order
4412 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4413 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4414 C   are computed for EVERY pair of non-contiguous peptide groups.
4415 C
4416
4417           if (j.lt.nres-1) then
4418             j1=j+1
4419             j2=j-1
4420           else
4421             j1=j-1
4422             j2=j-2
4423           endif
4424           kkk=0
4425           lll=0
4426           do k=1,2
4427             do l=1,2
4428               kkk=kkk+1
4429               muij(kkk)=mu(k,i)*mu(l,j)
4430 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4431 #ifdef NEWCORR
4432              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4433 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4434              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4435              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4436 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4437              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4438 #endif
4439             enddo
4440           enddo
4441 #ifdef DEBUG
4442           write (iout,*) 'EELEC: i',i,' j',j
4443           write (iout,*) 'j',j,' j1',j1,' j2',j2
4444           write(iout,*) 'muij',muij
4445 #endif
4446           ury=scalar(uy(1,i),erij)
4447           urz=scalar(uz(1,i),erij)
4448           vry=scalar(uy(1,j),erij)
4449           vrz=scalar(uz(1,j),erij)
4450           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4451           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4452           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4453           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4454           fac=dsqrt(-ael6i)*r3ij
4455 #ifdef DEBUG
4456           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4457           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4458      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4459      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4460      &      "uzvz",scalar(uz(1,i),uz(1,j))
4461           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4462           write (iout,*) "fac",fac
4463 #endif
4464           a22=a22*fac
4465           a23=a23*fac
4466           a32=a32*fac
4467           a33=a33*fac
4468 #ifdef DEBUG
4469           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4470 #endif
4471 #undef DEBUG
4472 cd          write (iout,'(4i5,4f10.5)')
4473 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4474 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4475 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4476 cd     &      uy(:,j),uz(:,j)
4477 cd          write (iout,'(4f10.5)')
4478 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4479 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4480 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4481 cd           write (iout,'(9f10.5/)')
4482 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4483 C Derivatives of the elements of A in virtual-bond vectors
4484           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4485           do k=1,3
4486             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4487             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4488             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4489             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4490             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4491             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4492             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4493             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4494             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4495             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4496             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4497             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4498           enddo
4499 C Compute radial contributions to the gradient
4500           facr=-3.0d0*rrmij
4501           a22der=a22*facr
4502           a23der=a23*facr
4503           a32der=a32*facr
4504           a33der=a33*facr
4505           agg(1,1)=a22der*xj
4506           agg(2,1)=a22der*yj
4507           agg(3,1)=a22der*zj
4508           agg(1,2)=a23der*xj
4509           agg(2,2)=a23der*yj
4510           agg(3,2)=a23der*zj
4511           agg(1,3)=a32der*xj
4512           agg(2,3)=a32der*yj
4513           agg(3,3)=a32der*zj
4514           agg(1,4)=a33der*xj
4515           agg(2,4)=a33der*yj
4516           agg(3,4)=a33der*zj
4517 C Add the contributions coming from er
4518           fac3=-3.0d0*fac
4519           do k=1,3
4520             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4521             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4522             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4523             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4524           enddo
4525           do k=1,3
4526 C Derivatives in DC(i)
4527 cgrad            ghalf1=0.5d0*agg(k,1)
4528 cgrad            ghalf2=0.5d0*agg(k,2)
4529 cgrad            ghalf3=0.5d0*agg(k,3)
4530 cgrad            ghalf4=0.5d0*agg(k,4)
4531             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4532      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4533             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4534      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4535             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4536      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4537             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4538      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4539 C Derivatives in DC(i+1)
4540             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4541      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4542             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4543      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4544             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4545      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4546             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4547      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4548 C Derivatives in DC(j)
4549             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4550      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4551             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4552      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4553             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4554      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4555             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4556      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4557 C Derivatives in DC(j+1) or DC(nres-1)
4558             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4559      &      -3.0d0*vryg(k,3)*ury)
4560             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4561      &      -3.0d0*vrzg(k,3)*ury)
4562             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4563      &      -3.0d0*vryg(k,3)*urz)
4564             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4565      &      -3.0d0*vrzg(k,3)*urz)
4566 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4567 cgrad              do l=1,4
4568 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4569 cgrad              enddo
4570 cgrad            endif
4571           enddo
4572           acipa(1,1)=a22
4573           acipa(1,2)=a23
4574           acipa(2,1)=a32
4575           acipa(2,2)=a33
4576           a22=-a22
4577           a23=-a23
4578           do l=1,2
4579             do k=1,3
4580               agg(k,l)=-agg(k,l)
4581               aggi(k,l)=-aggi(k,l)
4582               aggi1(k,l)=-aggi1(k,l)
4583               aggj(k,l)=-aggj(k,l)
4584               aggj1(k,l)=-aggj1(k,l)
4585             enddo
4586           enddo
4587           if (j.lt.nres-1) then
4588             a22=-a22
4589             a32=-a32
4590             do l=1,3,2
4591               do k=1,3
4592                 agg(k,l)=-agg(k,l)
4593                 aggi(k,l)=-aggi(k,l)
4594                 aggi1(k,l)=-aggi1(k,l)
4595                 aggj(k,l)=-aggj(k,l)
4596                 aggj1(k,l)=-aggj1(k,l)
4597               enddo
4598             enddo
4599           else
4600             a22=-a22
4601             a23=-a23
4602             a32=-a32
4603             a33=-a33
4604             do l=1,4
4605               do k=1,3
4606                 agg(k,l)=-agg(k,l)
4607                 aggi(k,l)=-aggi(k,l)
4608                 aggi1(k,l)=-aggi1(k,l)
4609                 aggj(k,l)=-aggj(k,l)
4610                 aggj1(k,l)=-aggj1(k,l)
4611               enddo
4612             enddo
4613           endif
4614           ENDIF ! WCORR
4615           IF (wel_loc.gt.0.0d0) THEN
4616 C Contribution to the local-electrostatic energy coming from the i-j pair
4617           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4618      &     +a33*muij(4)
4619 #ifdef DEBUG
4620           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4621      &     " a33",a33
4622           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4623      &     " wel_loc",wel_loc
4624 #endif
4625           if (shield_mode.eq.0) then
4626            fac_shield(i)=1.0
4627            fac_shield(j)=1.0
4628 C          else
4629 C           fac_shield(i)=0.4
4630 C           fac_shield(j)=0.6
4631           endif
4632           eel_loc_ij=eel_loc_ij
4633      &    *fac_shield(i)*fac_shield(j)*sss
4634 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4635 c     &            'eelloc',i,j,eel_loc_ij
4636 C Now derivative over eel_loc
4637           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4638      &  (shield_mode.gt.0)) then
4639 C          print *,i,j
4640
4641           do ilist=1,ishield_list(i)
4642            iresshield=shield_list(ilist,i)
4643            do k=1,3
4644            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4645      &                                          /fac_shield(i)
4646 C     &      *2.0
4647            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4648      &              rlocshield
4649      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4650             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4651      &      +rlocshield
4652            enddo
4653           enddo
4654           do ilist=1,ishield_list(j)
4655            iresshield=shield_list(ilist,j)
4656            do k=1,3
4657            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4658      &                                       /fac_shield(j)
4659 C     &     *2.0
4660            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4661      &              rlocshield
4662      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4663            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4664      &             +rlocshield
4665
4666            enddo
4667           enddo
4668
4669           do k=1,3
4670             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4671      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4672             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4673      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4674             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4675      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4676             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4677      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4678            enddo
4679            endif
4680
4681
4682 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4683 c     &                     ' eel_loc_ij',eel_loc_ij
4684 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4685 C Calculate patrial derivative for theta angle
4686 #ifdef NEWCORR
4687          geel_loc_ij=(a22*gmuij1(1)
4688      &     +a23*gmuij1(2)
4689      &     +a32*gmuij1(3)
4690      &     +a33*gmuij1(4))
4691      &    *fac_shield(i)*fac_shield(j)*sss
4692 c         write(iout,*) "derivative over thatai"
4693 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4694 c     &   a33*gmuij1(4)
4695          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4696      &      geel_loc_ij*wel_loc
4697 c         write(iout,*) "derivative over thatai-1"
4698 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4699 c     &   a33*gmuij2(4)
4700          geel_loc_ij=
4701      &     a22*gmuij2(1)
4702      &     +a23*gmuij2(2)
4703      &     +a32*gmuij2(3)
4704      &     +a33*gmuij2(4)
4705          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4706      &      geel_loc_ij*wel_loc
4707      &    *fac_shield(i)*fac_shield(j)*sss
4708
4709 c  Derivative over j residue
4710          geel_loc_ji=a22*gmuji1(1)
4711      &     +a23*gmuji1(2)
4712      &     +a32*gmuji1(3)
4713      &     +a33*gmuji1(4)
4714 c         write(iout,*) "derivative over thataj"
4715 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4716 c     &   a33*gmuji1(4)
4717
4718         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4719      &      geel_loc_ji*wel_loc
4720      &    *fac_shield(i)*fac_shield(j)*sss
4721
4722          geel_loc_ji=
4723      &     +a22*gmuji2(1)
4724      &     +a23*gmuji2(2)
4725      &     +a32*gmuji2(3)
4726      &     +a33*gmuji2(4)
4727 c         write(iout,*) "derivative over thataj-1"
4728 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4729 c     &   a33*gmuji2(4)
4730          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4731      &      geel_loc_ji*wel_loc
4732      &    *fac_shield(i)*fac_shield(j)*sss
4733 #endif
4734 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4735
4736           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4737      &            'eelloc',i,j,eel_loc_ij
4738 c           if (eel_loc_ij.ne.0)
4739 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4740 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4741
4742           eel_loc=eel_loc+eel_loc_ij
4743 C Partial derivatives in virtual-bond dihedral angles gamma
4744           if (i.gt.1)
4745      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4746      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4747      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4748      &    *fac_shield(i)*fac_shield(j)*sss
4749
4750           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4751      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4752      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4753      &    *fac_shield(i)*fac_shield(j)*sss
4754 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4755           aux=eel_loc_ij/sss*sssgrad*rmij
4756           ggg(1)=aux*xj
4757           ggg(2)=aux*yj
4758           ggg(3)=aux*zj
4759           do l=1,3
4760             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4761      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4762      &    *fac_shield(i)*fac_shield(j)*sss
4763             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4764             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4765 cgrad            ghalf=0.5d0*ggg(l)
4766 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4767 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4768           enddo
4769 cgrad          do k=i+1,j2
4770 cgrad            do l=1,3
4771 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4772 cgrad            enddo
4773 cgrad          enddo
4774 C Remaining derivatives of eello
4775           do l=1,3
4776             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4777      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4778      &    *fac_shield(i)*fac_shield(j)*sss
4779
4780             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4781      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4782      &    *fac_shield(i)*fac_shield(j)*sss
4783
4784             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4785      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4786      &    *fac_shield(i)*fac_shield(j)*sss
4787
4788             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4789      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4790      &    *fac_shield(i)*fac_shield(j)*sss
4791
4792           enddo
4793           ENDIF
4794 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4795 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4796 #ifdef FOURBODY
4797           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4798      &       .and. num_conti.le.maxconts) then
4799 c            write (iout,*) i,j," entered corr"
4800 C
4801 C Calculate the contact function. The ith column of the array JCONT will
4802 C contain the numbers of atoms that make contacts with the atom I (of numbers
4803 C greater than I). The arrays FACONT and GACONT will contain the values of
4804 C the contact function and its derivative.
4805 c           r0ij=1.02D0*rpp(iteli,itelj)
4806 c           r0ij=1.11D0*rpp(iteli,itelj)
4807             r0ij=2.20D0*rpp(iteli,itelj)
4808 c           r0ij=1.55D0*rpp(iteli,itelj)
4809             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4810             if (fcont.gt.0.0D0) then
4811               num_conti=num_conti+1
4812               if (num_conti.gt.maxconts) then
4813                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4814      &                         ' will skip next contacts for this conf.'
4815               else
4816                 jcont_hb(num_conti,i)=j
4817 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4818 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4819                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4820      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4821 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4822 C  terms.
4823                 d_cont(num_conti,i)=rij
4824 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4825 C     --- Electrostatic-interaction matrix ---
4826                 a_chuj(1,1,num_conti,i)=a22
4827                 a_chuj(1,2,num_conti,i)=a23
4828                 a_chuj(2,1,num_conti,i)=a32
4829                 a_chuj(2,2,num_conti,i)=a33
4830 C     --- Gradient of rij
4831                 do kkk=1,3
4832                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4833                 enddo
4834                 kkll=0
4835                 do k=1,2
4836                   do l=1,2
4837                     kkll=kkll+1
4838                     do m=1,3
4839                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4840                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4841                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4842                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4843                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4844                     enddo
4845                   enddo
4846                 enddo
4847                 ENDIF
4848                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4849 C Calculate contact energies
4850                 cosa4=4.0D0*cosa
4851                 wij=cosa-3.0D0*cosb*cosg
4852                 cosbg1=cosb+cosg
4853                 cosbg2=cosb-cosg
4854 c               fac3=dsqrt(-ael6i)/r0ij**3
4855                 fac3=dsqrt(-ael6i)*r3ij
4856 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4857                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4858                 if (ees0tmp.gt.0) then
4859                   ees0pij=dsqrt(ees0tmp)
4860                 else
4861                   ees0pij=0
4862                 endif
4863 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4864                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4865                 if (ees0tmp.gt.0) then
4866                   ees0mij=dsqrt(ees0tmp)
4867                 else
4868                   ees0mij=0
4869                 endif
4870 c               ees0mij=0.0D0
4871                 if (shield_mode.eq.0) then
4872                 fac_shield(i)=1.0d0
4873                 fac_shield(j)=1.0d0
4874                 else
4875                 ees0plist(num_conti,i)=j
4876 C                fac_shield(i)=0.4d0
4877 C                fac_shield(j)=0.6d0
4878                 endif
4879                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4880      &          *fac_shield(i)*fac_shield(j)*sss
4881                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4882      &          *fac_shield(i)*fac_shield(j)*sss
4883 C Diagnostics. Comment out or remove after debugging!
4884 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4885 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4886 c               ees0m(num_conti,i)=0.0D0
4887 C End diagnostics.
4888 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4889 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4890 C Angular derivatives of the contact function
4891                 ees0pij1=fac3/ees0pij
4892                 ees0mij1=fac3/ees0mij
4893                 fac3p=-3.0D0*fac3*rrmij
4894                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4895                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4896 c               ees0mij1=0.0D0
4897                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4898                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4899                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4900                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4901                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4902                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4903                 ecosap=ecosa1+ecosa2
4904                 ecosbp=ecosb1+ecosb2
4905                 ecosgp=ecosg1+ecosg2
4906                 ecosam=ecosa1-ecosa2
4907                 ecosbm=ecosb1-ecosb2
4908                 ecosgm=ecosg1-ecosg2
4909 C Diagnostics
4910 c               ecosap=ecosa1
4911 c               ecosbp=ecosb1
4912 c               ecosgp=ecosg1
4913 c               ecosam=0.0D0
4914 c               ecosbm=0.0D0
4915 c               ecosgm=0.0D0
4916 C End diagnostics
4917                 facont_hb(num_conti,i)=fcont
4918                 fprimcont=fprimcont/rij
4919 cd              facont_hb(num_conti,i)=1.0D0
4920 C Following line is for diagnostics.
4921 cd              fprimcont=0.0D0
4922                 do k=1,3
4923                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4924                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4925                 enddo
4926                 do k=1,3
4927                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4928                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4929                 enddo
4930                 gggp(1)=gggp(1)+ees0pijp*xj
4931      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4932                 gggp(2)=gggp(2)+ees0pijp*yj
4933      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4934                 gggp(3)=gggp(3)+ees0pijp*zj
4935      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4936                 gggm(1)=gggm(1)+ees0mijp*xj
4937      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4938                 gggm(2)=gggm(2)+ees0mijp*yj
4939      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4940                 gggm(3)=gggm(3)+ees0mijp*zj
4941      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4942 C Derivatives due to the contact function
4943                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4944                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4945                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4946                 do k=1,3
4947 c
4948 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4949 c          following the change of gradient-summation algorithm.
4950 c
4951 cgrad                  ghalfp=0.5D0*gggp(k)
4952 cgrad                  ghalfm=0.5D0*gggm(k)
4953                   gacontp_hb1(k,num_conti,i)=!ghalfp
4954      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4955      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4956      &          *fac_shield(i)*fac_shield(j)*sss
4957
4958                   gacontp_hb2(k,num_conti,i)=!ghalfp
4959      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4960      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4961      &          *fac_shield(i)*fac_shield(j)*sss
4962
4963                   gacontp_hb3(k,num_conti,i)=gggp(k)
4964      &          *fac_shield(i)*fac_shield(j)*sss
4965
4966                   gacontm_hb1(k,num_conti,i)=!ghalfm
4967      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4968      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4969      &          *fac_shield(i)*fac_shield(j)*sss
4970
4971                   gacontm_hb2(k,num_conti,i)=!ghalfm
4972      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4973      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4974      &          *fac_shield(i)*fac_shield(j)*sss
4975
4976                   gacontm_hb3(k,num_conti,i)=gggm(k)
4977      &          *fac_shield(i)*fac_shield(j)*sss
4978
4979                 enddo
4980 C Diagnostics. Comment out or remove after debugging!
4981 cdiag           do k=1,3
4982 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4983 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4984 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4985 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4986 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4987 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4988 cdiag           enddo
4989               ENDIF ! wcorr
4990               endif  ! num_conti.le.maxconts
4991             endif  ! fcont.gt.0
4992           endif    ! j.gt.i+1
4993 #endif
4994           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4995             do k=1,4
4996               do l=1,3
4997                 ghalf=0.5d0*agg(l,k)
4998                 aggi(l,k)=aggi(l,k)+ghalf
4999                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
5000                 aggj(l,k)=aggj(l,k)+ghalf
5001               enddo
5002             enddo
5003             if (j.eq.nres-1 .and. i.lt.j-2) then
5004               do k=1,4
5005                 do l=1,3
5006                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
5007                 enddo
5008               enddo
5009             endif
5010           endif
5011 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
5012       return
5013       end
5014 C-----------------------------------------------------------------------------
5015       subroutine eturn3(i,eello_turn3)
5016 C Third- and fourth-order contributions from turns
5017       implicit real*8 (a-h,o-z)
5018       include 'DIMENSIONS'
5019       include 'COMMON.IOUNITS'
5020       include 'COMMON.GEO'
5021       include 'COMMON.VAR'
5022       include 'COMMON.LOCAL'
5023       include 'COMMON.CHAIN'
5024       include 'COMMON.DERIV'
5025       include 'COMMON.INTERACT'
5026       include 'COMMON.CORRMAT'
5027       include 'COMMON.TORSION'
5028       include 'COMMON.VECTORS'
5029       include 'COMMON.FFIELD'
5030       include 'COMMON.CONTROL'
5031       include 'COMMON.SHIELD'
5032       dimension ggg(3)
5033       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5034      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5035      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
5036      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
5037      &  auxgmat2(2,2),auxgmatt2(2,2)
5038       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5039      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5040       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5041      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5042      &    num_conti,j1,j2
5043       j=i+2
5044 c      write (iout,*) "eturn3",i,j,j1,j2
5045       a_temp(1,1)=a22
5046       a_temp(1,2)=a23
5047       a_temp(2,1)=a32
5048       a_temp(2,2)=a33
5049 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5050 C
5051 C               Third-order contributions
5052 C
5053 C                 (i+2)o----(i+3)
5054 C                      | |
5055 C                      | |
5056 C                 (i+1)o----i
5057 C
5058 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5059 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5060         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5061 c auxalary matices for theta gradient
5062 c auxalary matrix for i+1 and constant i+2
5063         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5064 c auxalary matrix for i+2 and constant i+1
5065         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5066         call transpose2(auxmat(1,1),auxmat1(1,1))
5067         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5068         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5069         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5070         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5071         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5072         if (shield_mode.eq.0) then
5073         fac_shield(i)=1.0
5074         fac_shield(j)=1.0
5075 C        else
5076 C        fac_shield(i)=0.4
5077 C        fac_shield(j)=0.6
5078         endif
5079         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5080      &  *fac_shield(i)*fac_shield(j)
5081         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5082      &  *fac_shield(i)*fac_shield(j)
5083         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5084      &    eello_t3
5085 C#ifdef NEWCORR
5086 C Derivatives in theta
5087         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5088      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5089      &   *fac_shield(i)*fac_shield(j)
5090         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5091      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5092      &   *fac_shield(i)*fac_shield(j)
5093 C#endif
5094
5095 C Derivatives in shield mode
5096           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5097      &  (shield_mode.gt.0)) then
5098 C          print *,i,j
5099
5100           do ilist=1,ishield_list(i)
5101            iresshield=shield_list(ilist,i)
5102            do k=1,3
5103            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5104 C     &      *2.0
5105            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5106      &              rlocshield
5107      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5108             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5109      &      +rlocshield
5110            enddo
5111           enddo
5112           do ilist=1,ishield_list(j)
5113            iresshield=shield_list(ilist,j)
5114            do k=1,3
5115            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5116 C     &     *2.0
5117            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5118      &              rlocshield
5119      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5120            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5121      &             +rlocshield
5122
5123            enddo
5124           enddo
5125
5126           do k=1,3
5127             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5128      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5129             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5130      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5131             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5132      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5133             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5134      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5135            enddo
5136            endif
5137
5138 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5139 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5140 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5141 cd     &    ' eello_turn3_num',4*eello_turn3_num
5142 C Derivatives in gamma(i)
5143         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5144         call transpose2(auxmat2(1,1),auxmat3(1,1))
5145         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5146         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5147      &   *fac_shield(i)*fac_shield(j)
5148 C Derivatives in gamma(i+1)
5149         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5150         call transpose2(auxmat2(1,1),auxmat3(1,1))
5151         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5152         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5153      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5154      &   *fac_shield(i)*fac_shield(j)
5155 C Cartesian derivatives
5156         do l=1,3
5157 c            ghalf1=0.5d0*agg(l,1)
5158 c            ghalf2=0.5d0*agg(l,2)
5159 c            ghalf3=0.5d0*agg(l,3)
5160 c            ghalf4=0.5d0*agg(l,4)
5161           a_temp(1,1)=aggi(l,1)!+ghalf1
5162           a_temp(1,2)=aggi(l,2)!+ghalf2
5163           a_temp(2,1)=aggi(l,3)!+ghalf3
5164           a_temp(2,2)=aggi(l,4)!+ghalf4
5165           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5166           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5167      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5168      &   *fac_shield(i)*fac_shield(j)
5169
5170           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5171           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5172           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5173           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5174           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5175           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5176      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5177      &   *fac_shield(i)*fac_shield(j)
5178           a_temp(1,1)=aggj(l,1)!+ghalf1
5179           a_temp(1,2)=aggj(l,2)!+ghalf2
5180           a_temp(2,1)=aggj(l,3)!+ghalf3
5181           a_temp(2,2)=aggj(l,4)!+ghalf4
5182           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5183           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5184      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5185      &   *fac_shield(i)*fac_shield(j)
5186           a_temp(1,1)=aggj1(l,1)
5187           a_temp(1,2)=aggj1(l,2)
5188           a_temp(2,1)=aggj1(l,3)
5189           a_temp(2,2)=aggj1(l,4)
5190           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5191           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5192      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5193      &   *fac_shield(i)*fac_shield(j)
5194         enddo
5195       return
5196       end
5197 C-------------------------------------------------------------------------------
5198       subroutine eturn4(i,eello_turn4)
5199 C Third- and fourth-order contributions from turns
5200       implicit real*8 (a-h,o-z)
5201       include 'DIMENSIONS'
5202       include 'COMMON.IOUNITS'
5203       include 'COMMON.GEO'
5204       include 'COMMON.VAR'
5205       include 'COMMON.LOCAL'
5206       include 'COMMON.CHAIN'
5207       include 'COMMON.DERIV'
5208       include 'COMMON.INTERACT'
5209       include 'COMMON.CORRMAT'
5210       include 'COMMON.TORSION'
5211       include 'COMMON.VECTORS'
5212       include 'COMMON.FFIELD'
5213       include 'COMMON.CONTROL'
5214       include 'COMMON.SHIELD'
5215       dimension ggg(3)
5216       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5217      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5218      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5219      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5220      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5221      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5222      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5223       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5224      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5225       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5226      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5227      &    num_conti,j1,j2
5228       j=i+3
5229 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5230 C
5231 C               Fourth-order contributions
5232 C
5233 C                 (i+3)o----(i+4)
5234 C                     /  |
5235 C               (i+2)o   |
5236 C                     \  |
5237 C                 (i+1)o----i
5238 C
5239 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5240 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5241 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5242 c        write(iout,*)"WCHODZE W PROGRAM"
5243         a_temp(1,1)=a22
5244         a_temp(1,2)=a23
5245         a_temp(2,1)=a32
5246         a_temp(2,2)=a33
5247         iti1=itype2loc(itype(i+1))
5248         iti2=itype2loc(itype(i+2))
5249         iti3=itype2loc(itype(i+3))
5250 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5251         call transpose2(EUg(1,1,i+1),e1t(1,1))
5252         call transpose2(Eug(1,1,i+2),e2t(1,1))
5253         call transpose2(Eug(1,1,i+3),e3t(1,1))
5254 C Ematrix derivative in theta
5255         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5256         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5257         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5258         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5259 c       eta1 in derivative theta
5260         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5261         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5262 c       auxgvec is derivative of Ub2 so i+3 theta
5263         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5264 c       auxalary matrix of E i+1
5265         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5266 c        s1=0.0
5267 c        gs1=0.0
5268         s1=scalar2(b1(1,i+2),auxvec(1))
5269 c derivative of theta i+2 with constant i+3
5270         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5271 c derivative of theta i+2 with constant i+2
5272         gs32=scalar2(b1(1,i+2),auxgvec(1))
5273 c derivative of E matix in theta of i+1
5274         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5275
5276         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5277 c       ea31 in derivative theta
5278         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5279         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5280 c auxilary matrix auxgvec of Ub2 with constant E matirx
5281         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5282 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5283         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5284
5285 c        s2=0.0
5286 c        gs2=0.0
5287         s2=scalar2(b1(1,i+1),auxvec(1))
5288 c derivative of theta i+1 with constant i+3
5289         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5290 c derivative of theta i+2 with constant i+1
5291         gs21=scalar2(b1(1,i+1),auxgvec(1))
5292 c derivative of theta i+3 with constant i+1
5293         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5294 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5295 c     &  gtb1(1,i+1)
5296         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5297 c two derivatives over diffetent matrices
5298 c gtae3e2 is derivative over i+3
5299         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5300 c ae3gte2 is derivative over i+2
5301         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5302         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5303 c three possible derivative over theta E matices
5304 c i+1
5305         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5306 c i+2
5307         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5308 c i+3
5309         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5310         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5311
5312         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5313         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5314         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5315         if (shield_mode.eq.0) then
5316         fac_shield(i)=1.0
5317         fac_shield(j)=1.0
5318 C        else
5319 C        fac_shield(i)=0.6
5320 C        fac_shield(j)=0.4
5321         endif
5322         eello_turn4=eello_turn4-(s1+s2+s3)
5323      &  *fac_shield(i)*fac_shield(j)
5324         eello_t4=-(s1+s2+s3)
5325      &  *fac_shield(i)*fac_shield(j)
5326 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5327         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5328      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5329 C Now derivative over shield:
5330           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5331      &  (shield_mode.gt.0)) then
5332 C          print *,i,j
5333
5334           do ilist=1,ishield_list(i)
5335            iresshield=shield_list(ilist,i)
5336            do k=1,3
5337            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5338 C     &      *2.0
5339            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5340      &              rlocshield
5341      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5342             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5343      &      +rlocshield
5344            enddo
5345           enddo
5346           do ilist=1,ishield_list(j)
5347            iresshield=shield_list(ilist,j)
5348            do k=1,3
5349            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5350 C     &     *2.0
5351            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5352      &              rlocshield
5353      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5354            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5355      &             +rlocshield
5356
5357            enddo
5358           enddo
5359
5360           do k=1,3
5361             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5362      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5363             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5364      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5365             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5366      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5367             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5368      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5369            enddo
5370            endif
5371
5372
5373
5374
5375
5376
5377 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5378 cd     &    ' eello_turn4_num',8*eello_turn4_num
5379 #ifdef NEWCORR
5380         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5381      &                  -(gs13+gsE13+gsEE1)*wturn4
5382      &  *fac_shield(i)*fac_shield(j)
5383         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5384      &                    -(gs23+gs21+gsEE2)*wturn4
5385      &  *fac_shield(i)*fac_shield(j)
5386
5387         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5388      &                    -(gs32+gsE31+gsEE3)*wturn4
5389      &  *fac_shield(i)*fac_shield(j)
5390
5391 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5392 c     &   gs2
5393 #endif
5394         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5395      &      'eturn4',i,j,-(s1+s2+s3)
5396 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5397 c     &    ' eello_turn4_num',8*eello_turn4_num
5398 C Derivatives in gamma(i)
5399         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5400         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5401         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5402         s1=scalar2(b1(1,i+2),auxvec(1))
5403         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5404         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5405         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5406      &  *fac_shield(i)*fac_shield(j)
5407 C Derivatives in gamma(i+1)
5408         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5409         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5410         s2=scalar2(b1(1,i+1),auxvec(1))
5411         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5412         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5413         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5414         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5415      &  *fac_shield(i)*fac_shield(j)
5416 C Derivatives in gamma(i+2)
5417         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5418         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5419         s1=scalar2(b1(1,i+2),auxvec(1))
5420         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5421         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5422         s2=scalar2(b1(1,i+1),auxvec(1))
5423         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5424         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5425         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5426         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5427      &  *fac_shield(i)*fac_shield(j)
5428 C Cartesian derivatives
5429 C Derivatives of this turn contributions in DC(i+2)
5430         if (j.lt.nres-1) then
5431           do l=1,3
5432             a_temp(1,1)=agg(l,1)
5433             a_temp(1,2)=agg(l,2)
5434             a_temp(2,1)=agg(l,3)
5435             a_temp(2,2)=agg(l,4)
5436             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5437             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5438             s1=scalar2(b1(1,i+2),auxvec(1))
5439             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5440             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5441             s2=scalar2(b1(1,i+1),auxvec(1))
5442             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5443             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5444             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5445             ggg(l)=-(s1+s2+s3)
5446             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5447      &  *fac_shield(i)*fac_shield(j)
5448           enddo
5449         endif
5450 C Remaining derivatives of this turn contribution
5451         do l=1,3
5452           a_temp(1,1)=aggi(l,1)
5453           a_temp(1,2)=aggi(l,2)
5454           a_temp(2,1)=aggi(l,3)
5455           a_temp(2,2)=aggi(l,4)
5456           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5457           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5458           s1=scalar2(b1(1,i+2),auxvec(1))
5459           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5460           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5461           s2=scalar2(b1(1,i+1),auxvec(1))
5462           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5463           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5464           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5465           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5466      &  *fac_shield(i)*fac_shield(j)
5467           a_temp(1,1)=aggi1(l,1)
5468           a_temp(1,2)=aggi1(l,2)
5469           a_temp(2,1)=aggi1(l,3)
5470           a_temp(2,2)=aggi1(l,4)
5471           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5472           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5473           s1=scalar2(b1(1,i+2),auxvec(1))
5474           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5475           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5476           s2=scalar2(b1(1,i+1),auxvec(1))
5477           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5478           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5479           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5480           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5481      &  *fac_shield(i)*fac_shield(j)
5482           a_temp(1,1)=aggj(l,1)
5483           a_temp(1,2)=aggj(l,2)
5484           a_temp(2,1)=aggj(l,3)
5485           a_temp(2,2)=aggj(l,4)
5486           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5487           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5488           s1=scalar2(b1(1,i+2),auxvec(1))
5489           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5490           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5491           s2=scalar2(b1(1,i+1),auxvec(1))
5492           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5493           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5494           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5495           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5496      &  *fac_shield(i)*fac_shield(j)
5497           a_temp(1,1)=aggj1(l,1)
5498           a_temp(1,2)=aggj1(l,2)
5499           a_temp(2,1)=aggj1(l,3)
5500           a_temp(2,2)=aggj1(l,4)
5501           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5502           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5503           s1=scalar2(b1(1,i+2),auxvec(1))
5504           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5505           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5506           s2=scalar2(b1(1,i+1),auxvec(1))
5507           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5508           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5509           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5510 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5511           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5512      &  *fac_shield(i)*fac_shield(j)
5513         enddo
5514       return
5515       end
5516 C-----------------------------------------------------------------------------
5517       subroutine vecpr(u,v,w)
5518       implicit real*8(a-h,o-z)
5519       dimension u(3),v(3),w(3)
5520       w(1)=u(2)*v(3)-u(3)*v(2)
5521       w(2)=-u(1)*v(3)+u(3)*v(1)
5522       w(3)=u(1)*v(2)-u(2)*v(1)
5523       return
5524       end
5525 C-----------------------------------------------------------------------------
5526       subroutine unormderiv(u,ugrad,unorm,ungrad)
5527 C This subroutine computes the derivatives of a normalized vector u, given
5528 C the derivatives computed without normalization conditions, ugrad. Returns
5529 C ungrad.
5530       implicit none
5531       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5532       double precision vec(3)
5533       double precision scalar
5534       integer i,j
5535 c      write (2,*) 'ugrad',ugrad
5536 c      write (2,*) 'u',u
5537       do i=1,3
5538         vec(i)=scalar(ugrad(1,i),u(1))
5539       enddo
5540 c      write (2,*) 'vec',vec
5541       do i=1,3
5542         do j=1,3
5543           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5544         enddo
5545       enddo
5546 c      write (2,*) 'ungrad',ungrad
5547       return
5548       end
5549 C-----------------------------------------------------------------------------
5550       subroutine escp_soft_sphere(evdw2,evdw2_14)
5551 C
5552 C This subroutine calculates the excluded-volume interaction energy between
5553 C peptide-group centers and side chains and its gradient in virtual-bond and
5554 C side-chain vectors.
5555 C
5556       implicit real*8 (a-h,o-z)
5557       include 'DIMENSIONS'
5558       include 'COMMON.GEO'
5559       include 'COMMON.VAR'
5560       include 'COMMON.LOCAL'
5561       include 'COMMON.CHAIN'
5562       include 'COMMON.DERIV'
5563       include 'COMMON.INTERACT'
5564       include 'COMMON.FFIELD'
5565       include 'COMMON.IOUNITS'
5566       include 'COMMON.CONTROL'
5567       dimension ggg(3)
5568       integer xshift,yshift,zshift
5569       evdw2=0.0D0
5570       evdw2_14=0.0d0
5571       r0_scp=4.5d0
5572 cd    print '(a)','Enter ESCP'
5573 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5574 C      do xshift=-1,1
5575 C      do yshift=-1,1
5576 C      do zshift=-1,1
5577 c      do i=iatscp_s,iatscp_e
5578       do icont=g_listscp_start,g_listscp_end
5579         i=newcontlistscpi(icont)
5580         j=newcontlistscpj(icont)
5581         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5582         iteli=itel(i)
5583         xi=0.5D0*(c(1,i)+c(1,i+1))
5584         yi=0.5D0*(c(2,i)+c(2,i+1))
5585         zi=0.5D0*(c(3,i)+c(3,i+1))
5586 C Return atom into box, boxxsize is size of box in x dimension
5587 c  134   continue
5588 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5589 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5590 C Condition for being inside the proper box
5591 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5592 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5593 c        go to 134
5594 c        endif
5595 c  135   continue
5596 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5597 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5598 C Condition for being inside the proper box
5599 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5600 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5601 c        go to 135
5602 c c       endif
5603 c  136   continue
5604 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5605 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5606 cC Condition for being inside the proper box
5607 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5608 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5609 c        go to 136
5610 c        endif
5611           xi=mod(xi,boxxsize)
5612           if (xi.lt.0) xi=xi+boxxsize
5613           yi=mod(yi,boxysize)
5614           if (yi.lt.0) yi=yi+boxysize
5615           zi=mod(zi,boxzsize)
5616           if (zi.lt.0) zi=zi+boxzsize
5617 C          xi=xi+xshift*boxxsize
5618 C          yi=yi+yshift*boxysize
5619 C          zi=zi+zshift*boxzsize
5620 c        do iint=1,nscp_gr(i)
5621
5622 c        do j=iscpstart(i,iint),iscpend(i,iint)
5623           if (itype(j).eq.ntyp1) cycle
5624           itypj=iabs(itype(j))
5625 C Uncomment following three lines for SC-p interactions
5626 c         xj=c(1,nres+j)-xi
5627 c         yj=c(2,nres+j)-yi
5628 c         zj=c(3,nres+j)-zi
5629 C Uncomment following three lines for Ca-p interactions
5630           xj=c(1,j)
5631           yj=c(2,j)
5632           zj=c(3,j)
5633 c  174   continue
5634 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5635 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5636 C Condition for being inside the proper box
5637 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5638 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5639 c        go to 174
5640 c        endif
5641 c  175   continue
5642 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5643 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5644 cC Condition for being inside the proper box
5645 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5646 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5647 c        go to 175
5648 c        endif
5649 c  176   continue
5650 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5651 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5652 C Condition for being inside the proper box
5653 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5654 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5655 c        go to 176
5656           xj=mod(xj,boxxsize)
5657           if (xj.lt.0) xj=xj+boxxsize
5658           yj=mod(yj,boxysize)
5659           if (yj.lt.0) yj=yj+boxysize
5660           zj=mod(zj,boxzsize)
5661           if (zj.lt.0) zj=zj+boxzsize
5662       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5663       xj_safe=xj
5664       yj_safe=yj
5665       zj_safe=zj
5666       subchap=0
5667       do xshift=-1,1
5668       do yshift=-1,1
5669       do zshift=-1,1
5670           xj=xj_safe+xshift*boxxsize
5671           yj=yj_safe+yshift*boxysize
5672           zj=zj_safe+zshift*boxzsize
5673           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5674           if(dist_temp.lt.dist_init) then
5675             dist_init=dist_temp
5676             xj_temp=xj
5677             yj_temp=yj
5678             zj_temp=zj
5679             subchap=1
5680           endif
5681        enddo
5682        enddo
5683        enddo
5684        if (subchap.eq.1) then
5685           xj=xj_temp-xi
5686           yj=yj_temp-yi
5687           zj=zj_temp-zi
5688        else
5689           xj=xj_safe-xi
5690           yj=yj_safe-yi
5691           zj=zj_safe-zi
5692        endif
5693 c c       endif
5694 C          xj=xj-xi
5695 C          yj=yj-yi
5696 C          zj=zj-zi
5697           rij=xj*xj+yj*yj+zj*zj
5698
5699           r0ij=r0_scp
5700           r0ijsq=r0ij*r0ij
5701           if (rij.lt.r0ijsq) then
5702             evdwij=0.25d0*(rij-r0ijsq)**2
5703             fac=rij-r0ijsq
5704           else
5705             evdwij=0.0d0
5706             fac=0.0d0
5707           endif
5708           evdw2=evdw2+evdwij
5709 C
5710 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5711 C
5712           ggg(1)=xj*fac
5713           ggg(2)=yj*fac
5714           ggg(3)=zj*fac
5715 cgrad          if (j.lt.i) then
5716 cd          write (iout,*) 'j<i'
5717 C Uncomment following three lines for SC-p interactions
5718 c           do k=1,3
5719 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5720 c           enddo
5721 cgrad          else
5722 cd          write (iout,*) 'j>i'
5723 cgrad            do k=1,3
5724 cgrad              ggg(k)=-ggg(k)
5725 C Uncomment following line for SC-p interactions
5726 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5727 cgrad            enddo
5728 cgrad          endif
5729 cgrad          do k=1,3
5730 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5731 cgrad          enddo
5732 cgrad          kstart=min0(i+1,j)
5733 cgrad          kend=max0(i-1,j-1)
5734 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5735 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5736 cgrad          do k=kstart,kend
5737 cgrad            do l=1,3
5738 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5739 cgrad            enddo
5740 cgrad          enddo
5741           do k=1,3
5742             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5743             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5744           enddo
5745 c        enddo
5746
5747 c        enddo ! iint
5748       enddo ! i
5749 C      enddo !zshift
5750 C      enddo !yshift
5751 C      enddo !xshift
5752       return
5753       end
5754 C-----------------------------------------------------------------------------
5755       subroutine escp(evdw2,evdw2_14)
5756 C
5757 C This subroutine calculates the excluded-volume interaction energy between
5758 C peptide-group centers and side chains and its gradient in virtual-bond and
5759 C side-chain vectors.
5760 C
5761       implicit none
5762       include 'DIMENSIONS'
5763       include 'COMMON.GEO'
5764       include 'COMMON.VAR'
5765       include 'COMMON.LOCAL'
5766       include 'COMMON.CHAIN'
5767       include 'COMMON.DERIV'
5768       include 'COMMON.INTERACT'
5769       include 'COMMON.FFIELD'
5770       include 'COMMON.IOUNITS'
5771       include 'COMMON.CONTROL'
5772       include 'COMMON.SPLITELE'
5773       integer xshift,yshift,zshift
5774       double precision ggg(3)
5775       integer i,iint,j,k,iteli,itypj,subchap,icont
5776       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5777      & fac,e1,e2,rij
5778       double precision evdw2,evdw2_14,evdwij
5779       double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,
5780      & dist_temp, dist_init
5781       double precision sscale,sscagrad
5782       evdw2=0.0D0
5783       evdw2_14=0.0d0
5784 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5785 cd    print '(a)','Enter ESCP'
5786 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5787 C      do xshift=-1,1
5788 C      do yshift=-1,1
5789 C      do zshift=-1,1
5790       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5791 c      do i=iatscp_s,iatscp_e
5792       do icont=g_listscp_start,g_listscp_end
5793         i=newcontlistscpi(icont)
5794         j=newcontlistscpj(icont)
5795         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5796         iteli=itel(i)
5797         xi=0.5D0*(c(1,i)+c(1,i+1))
5798         yi=0.5D0*(c(2,i)+c(2,i+1))
5799         zi=0.5D0*(c(3,i)+c(3,i+1))
5800           xi=mod(xi,boxxsize)
5801           if (xi.lt.0) xi=xi+boxxsize
5802           yi=mod(yi,boxysize)
5803           if (yi.lt.0) yi=yi+boxysize
5804           zi=mod(zi,boxzsize)
5805           if (zi.lt.0) zi=zi+boxzsize
5806 c          xi=xi+xshift*boxxsize
5807 c          yi=yi+yshift*boxysize
5808 c          zi=zi+zshift*boxzsize
5809 c        print *,xi,yi,zi,'polozenie i'
5810 C Return atom into box, boxxsize is size of box in x dimension
5811 c  134   continue
5812 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5813 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5814 C Condition for being inside the proper box
5815 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5816 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5817 c        go to 134
5818 c        endif
5819 c  135   continue
5820 c          print *,xi,boxxsize,"pierwszy"
5821
5822 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5823 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5824 C Condition for being inside the proper box
5825 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5826 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5827 c        go to 135
5828 c        endif
5829 c  136   continue
5830 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5831 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5832 C Condition for being inside the proper box
5833 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5834 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5835 c        go to 136
5836 c        endif
5837 c        do iint=1,nscp_gr(i)
5838
5839 c        do j=iscpstart(i,iint),iscpend(i,iint)
5840           itypj=iabs(itype(j))
5841           if (itypj.eq.ntyp1) cycle
5842 C Uncomment following three lines for SC-p interactions
5843 c         xj=c(1,nres+j)-xi
5844 c         yj=c(2,nres+j)-yi
5845 c         zj=c(3,nres+j)-zi
5846 C Uncomment following three lines for Ca-p interactions
5847           xj=c(1,j)
5848           yj=c(2,j)
5849           zj=c(3,j)
5850           xj=mod(xj,boxxsize)
5851           if (xj.lt.0) xj=xj+boxxsize
5852           yj=mod(yj,boxysize)
5853           if (yj.lt.0) yj=yj+boxysize
5854           zj=mod(zj,boxzsize)
5855           if (zj.lt.0) zj=zj+boxzsize
5856 c  174   continue
5857 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5858 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5859 C Condition for being inside the proper box
5860 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5861 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5862 c        go to 174
5863 c        endif
5864 c  175   continue
5865 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5866 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5867 cC Condition for being inside the proper box
5868 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5869 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5870 c        go to 175
5871 c        endif
5872 c  176   continue
5873 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5874 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5875 C Condition for being inside the proper box
5876 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5877 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5878 c        go to 176
5879 c        endif
5880 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5881       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5882       xj_safe=xj
5883       yj_safe=yj
5884       zj_safe=zj
5885       subchap=0
5886       do xshift=-1,1
5887       do yshift=-1,1
5888       do zshift=-1,1
5889           xj=xj_safe+xshift*boxxsize
5890           yj=yj_safe+yshift*boxysize
5891           zj=zj_safe+zshift*boxzsize
5892           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5893           if(dist_temp.lt.dist_init) then
5894             dist_init=dist_temp
5895             xj_temp=xj
5896             yj_temp=yj
5897             zj_temp=zj
5898             subchap=1
5899           endif
5900        enddo
5901        enddo
5902        enddo
5903        if (subchap.eq.1) then
5904           xj=xj_temp-xi
5905           yj=yj_temp-yi
5906           zj=zj_temp-zi
5907        else
5908           xj=xj_safe-xi
5909           yj=yj_safe-yi
5910           zj=zj_safe-zi
5911        endif
5912 c          print *,xj,yj,zj,'polozenie j'
5913           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5914 c          print *,rrij
5915           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5916 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5917 c          if (sss.eq.0) print *,'czasem jest OK'
5918           if (sss.le.0.0d0) cycle
5919           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5920           fac=rrij**expon2
5921           e1=fac*fac*aad(itypj,iteli)
5922           e2=fac*bad(itypj,iteli)
5923           if (iabs(j-i) .le. 2) then
5924             e1=scal14*e1
5925             e2=scal14*e2
5926             evdw2_14=evdw2_14+(e1+e2)*sss
5927           endif
5928           evdwij=e1+e2
5929           evdw2=evdw2+evdwij*sss
5930           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5931      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5932      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5933      &       bad(itypj,iteli)
5934 C
5935 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5936 C
5937           fac=-(evdwij+e1)*rrij*sss
5938           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5939           ggg(1)=xj*fac
5940           ggg(2)=yj*fac
5941           ggg(3)=zj*fac
5942 cgrad          if (j.lt.i) then
5943 cd          write (iout,*) 'j<i'
5944 C Uncomment following three lines for SC-p interactions
5945 c           do k=1,3
5946 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5947 c           enddo
5948 cgrad          else
5949 cd          write (iout,*) 'j>i'
5950 cgrad            do k=1,3
5951 cgrad              ggg(k)=-ggg(k)
5952 C Uncomment following line for SC-p interactions
5953 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5954 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5955 cgrad            enddo
5956 cgrad          endif
5957 cgrad          do k=1,3
5958 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5959 cgrad          enddo
5960 cgrad          kstart=min0(i+1,j)
5961 cgrad          kend=max0(i-1,j-1)
5962 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5963 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5964 cgrad          do k=kstart,kend
5965 cgrad            do l=1,3
5966 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5967 cgrad            enddo
5968 cgrad          enddo
5969           do k=1,3
5970             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5971             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5972           enddo
5973 c        endif !endif for sscale cutoff
5974 c        enddo ! j
5975
5976 c        enddo ! iint
5977       enddo ! i
5978 c      enddo !zshift
5979 c      enddo !yshift
5980 c      enddo !xshift
5981       do i=1,nct
5982         do j=1,3
5983           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5984           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5985           gradx_scp(j,i)=expon*gradx_scp(j,i)
5986         enddo
5987       enddo
5988 C******************************************************************************
5989 C
5990 C                              N O T E !!!
5991 C
5992 C To save time the factor EXPON has been extracted from ALL components
5993 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5994 C use!
5995 C
5996 C******************************************************************************
5997       return
5998       end
5999 C--------------------------------------------------------------------------
6000       subroutine edis(ehpb)
6001 C
6002 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6003 C
6004       implicit real*8 (a-h,o-z)
6005       include 'DIMENSIONS'
6006       include 'COMMON.SBRIDGE'
6007       include 'COMMON.CHAIN'
6008       include 'COMMON.DERIV'
6009       include 'COMMON.VAR'
6010       include 'COMMON.INTERACT'
6011       include 'COMMON.IOUNITS'
6012       include 'COMMON.CONTROL'
6013       dimension ggg(3),ggg_peak(3,1000)
6014       ehpb=0.0D0
6015       do i=1,3
6016        ggg(i)=0.0d0
6017       enddo
6018 c 8/21/18 AL: added explicit restraints on reference coords
6019 c      write (iout,*) "restr_on_coord",restr_on_coord
6020       if (restr_on_coord) then
6021
6022       do i=nnt,nct
6023         ecoor=0.0d0
6024         if (itype(i).eq.ntyp1) cycle
6025         do j=1,3
6026           ecoor=ecoor+(c(j,i)-cref(j,i))**2
6027           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
6028         enddo
6029         if (itype(i).ne.10) then
6030           do j=1,3
6031             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
6032             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
6033           enddo
6034         endif
6035         if (energy_dec) write (iout,*)
6036      &     "i",i," bfac",bfac(i)," ecoor",ecoor
6037         ehpb=ehpb+0.5d0*bfac(i)*ecoor
6038       enddo
6039
6040       endif
6041 C      write (iout,*) ,"link_end",link_end,constr_dist
6042 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6043 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
6044 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
6045 c     &  " link_end_peak",link_end_peak
6046       if (link_end.eq.0.and.link_end_peak.eq.0) return
6047       do i=link_start_peak,link_end_peak
6048         ehpb_peak=0.0d0
6049 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
6050 c     &   ipeak(1,i),ipeak(2,i)
6051         do ip=ipeak(1,i),ipeak(2,i)
6052           ii=ihpb_peak(ip)
6053           jj=jhpb_peak(ip)
6054           dd=dist(ii,jj)
6055           iip=ip-ipeak(1,i)+1
6056 C iii and jjj point to the residues for which the distance is assigned.
6057 c          if (ii.gt.nres) then
6058 c            iii=ii-nres
6059 c            jjj=jj-nres
6060 c          else
6061 c            iii=ii
6062 c            jjj=jj
6063 c          endif
6064           if (ii.gt.nres) then
6065             iii=ii-nres
6066           else
6067             iii=ii
6068           endif
6069           if (jj.gt.nres) then
6070             jjj=jj-nres
6071           else
6072             jjj=jj
6073           endif
6074           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
6075           aux=dexp(-scal_peak*aux)
6076           ehpb_peak=ehpb_peak+aux
6077           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
6078      &      forcon_peak(ip))*aux/dd
6079           do j=1,3
6080             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
6081           enddo
6082           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
6083      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
6084      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
6085         enddo
6086 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
6087         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
6088         do ip=ipeak(1,i),ipeak(2,i)
6089           iip=ip-ipeak(1,i)+1
6090           do j=1,3
6091             ggg(j)=ggg_peak(j,iip)/ehpb_peak
6092           enddo
6093           ii=ihpb_peak(ip)
6094           jj=jhpb_peak(ip)
6095 C iii and jjj point to the residues for which the distance is assigned.
6096 c          if (ii.gt.nres) then
6097 c            iii=ii-nres
6098 c            jjj=jj-nres
6099 c          else
6100 c            iii=ii
6101 c            jjj=jj
6102 c          endif
6103           if (ii.gt.nres) then
6104             iii=ii-nres
6105           else
6106             iii=ii
6107           endif
6108           if (jj.gt.nres) then
6109             jjj=jj-nres
6110           else
6111             jjj=jj
6112           endif
6113           if (iii.lt.ii) then
6114             do j=1,3
6115               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6116             enddo
6117           endif
6118           if (jjj.lt.jj) then
6119             do j=1,3
6120               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6121             enddo
6122           endif
6123           do k=1,3
6124             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6125             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6126           enddo
6127         enddo
6128       enddo
6129       do i=link_start,link_end
6130 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6131 C CA-CA distance used in regularization of structure.
6132         ii=ihpb(i)
6133         jj=jhpb(i)
6134 C iii and jjj point to the residues for which the distance is assigned.
6135         if (ii.gt.nres) then
6136           iii=ii-nres
6137         else
6138           iii=ii
6139         endif
6140         if (jj.gt.nres) then
6141           jjj=jj-nres
6142         else
6143           jjj=jj
6144         endif
6145 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6146 c     &    dhpb(i),dhpb1(i),forcon(i)
6147 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6148 C    distance and angle dependent SS bond potential.
6149 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6150 C     & iabs(itype(jjj)).eq.1) then
6151 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6152 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6153         if (.not.dyn_ss .and. i.le.nss) then
6154 C 15/02/13 CC dynamic SSbond - additional check
6155           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6156      &        iabs(itype(jjj)).eq.1) then
6157            call ssbond_ene(iii,jjj,eij)
6158            ehpb=ehpb+2*eij
6159          endif
6160 cd          write (iout,*) "eij",eij
6161 cd   &   ' waga=',waga,' fac=',fac
6162 !        else if (ii.gt.nres .and. jj.gt.nres) then
6163         else
6164 C Calculate the distance between the two points and its difference from the
6165 C target distance.
6166           dd=dist(ii,jj)
6167           if (irestr_type(i).eq.11) then
6168             ehpb=ehpb+fordepth(i)!**4.0d0
6169      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6170             fac=fordepth(i)!**4.0d0
6171      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6172             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6173      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6174      &        ehpb,irestr_type(i)
6175           else if (irestr_type(i).eq.10) then
6176 c AL 6//19/2018 cross-link restraints
6177             xdis = 0.5d0*(dd/forcon(i))**2
6178             expdis = dexp(-xdis)
6179 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6180             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6181 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6182 c     &          " wboltzd",wboltzd
6183             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6184 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6185             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6186      &           *expdis/(aux*forcon(i)**2)
6187             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6188      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6189      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6190           else if (irestr_type(i).eq.2) then
6191 c Quartic restraints
6192             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6193             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6194      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6195      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6196             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6197           else
6198 c Quadratic restraints
6199             rdis=dd-dhpb(i)
6200 C Get the force constant corresponding to this distance.
6201             waga=forcon(i)
6202 C Calculate the contribution to energy.
6203             ehpb=ehpb+0.5d0*waga*rdis*rdis
6204             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6205      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6206      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6207 C
6208 C Evaluate gradient.
6209 C
6210             fac=waga*rdis/dd
6211           endif
6212 c Calculate Cartesian gradient
6213           do j=1,3
6214             ggg(j)=fac*(c(j,jj)-c(j,ii))
6215           enddo
6216 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6217 C If this is a SC-SC distance, we need to calculate the contributions to the
6218 C Cartesian gradient in the SC vectors (ghpbx).
6219           if (iii.lt.ii) then
6220             do j=1,3
6221               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6222             enddo
6223           endif
6224           if (jjj.lt.jj) then
6225             do j=1,3
6226               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6227             enddo
6228           endif
6229           do k=1,3
6230             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6231             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6232           enddo
6233         endif
6234       enddo
6235       return
6236       end
6237 C--------------------------------------------------------------------------
6238       subroutine ssbond_ene(i,j,eij)
6239 C
6240 C Calculate the distance and angle dependent SS-bond potential energy
6241 C using a free-energy function derived based on RHF/6-31G** ab initio
6242 C calculations of diethyl disulfide.
6243 C
6244 C A. Liwo and U. Kozlowska, 11/24/03
6245 C
6246       implicit real*8 (a-h,o-z)
6247       include 'DIMENSIONS'
6248       include 'COMMON.SBRIDGE'
6249       include 'COMMON.CHAIN'
6250       include 'COMMON.DERIV'
6251       include 'COMMON.LOCAL'
6252       include 'COMMON.INTERACT'
6253       include 'COMMON.VAR'
6254       include 'COMMON.IOUNITS'
6255       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6256       itypi=iabs(itype(i))
6257       xi=c(1,nres+i)
6258       yi=c(2,nres+i)
6259       zi=c(3,nres+i)
6260       dxi=dc_norm(1,nres+i)
6261       dyi=dc_norm(2,nres+i)
6262       dzi=dc_norm(3,nres+i)
6263 c      dsci_inv=dsc_inv(itypi)
6264       dsci_inv=vbld_inv(nres+i)
6265       itypj=iabs(itype(j))
6266 c      dscj_inv=dsc_inv(itypj)
6267       dscj_inv=vbld_inv(nres+j)
6268       xj=c(1,nres+j)-xi
6269       yj=c(2,nres+j)-yi
6270       zj=c(3,nres+j)-zi
6271       dxj=dc_norm(1,nres+j)
6272       dyj=dc_norm(2,nres+j)
6273       dzj=dc_norm(3,nres+j)
6274       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6275       rij=dsqrt(rrij)
6276       erij(1)=xj*rij
6277       erij(2)=yj*rij
6278       erij(3)=zj*rij
6279       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6280       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6281       om12=dxi*dxj+dyi*dyj+dzi*dzj
6282       do k=1,3
6283         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6284         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6285       enddo
6286       rij=1.0d0/rij
6287       deltad=rij-d0cm
6288       deltat1=1.0d0-om1
6289       deltat2=1.0d0+om2
6290       deltat12=om2-om1+2.0d0
6291       cosphi=om12-om1*om2
6292       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6293      &  +akct*deltad*deltat12
6294      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6295 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6296 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6297 c     &  " deltat12",deltat12," eij",eij
6298       ed=2*akcm*deltad+akct*deltat12
6299       pom1=akct*deltad
6300       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6301       eom1=-2*akth*deltat1-pom1-om2*pom2
6302       eom2= 2*akth*deltat2+pom1-om1*pom2
6303       eom12=pom2
6304       do k=1,3
6305         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6306         ghpbx(k,i)=ghpbx(k,i)-ggk
6307      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6308      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6309         ghpbx(k,j)=ghpbx(k,j)+ggk
6310      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6311      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6312         ghpbc(k,i)=ghpbc(k,i)-ggk
6313         ghpbc(k,j)=ghpbc(k,j)+ggk
6314       enddo
6315 C
6316 C Calculate the components of the gradient in DC and X
6317 C
6318 cgrad      do k=i,j-1
6319 cgrad        do l=1,3
6320 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6321 cgrad        enddo
6322 cgrad      enddo
6323       return
6324       end
6325 C--------------------------------------------------------------------------
6326       subroutine ebond(estr)
6327 c
6328 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6329 c
6330       implicit real*8 (a-h,o-z)
6331       include 'DIMENSIONS'
6332       include 'COMMON.LOCAL'
6333       include 'COMMON.GEO'
6334       include 'COMMON.INTERACT'
6335       include 'COMMON.DERIV'
6336       include 'COMMON.VAR'
6337       include 'COMMON.CHAIN'
6338       include 'COMMON.IOUNITS'
6339       include 'COMMON.NAMES'
6340       include 'COMMON.FFIELD'
6341       include 'COMMON.CONTROL'
6342       include 'COMMON.SETUP'
6343       double precision u(3),ud(3)
6344       estr=0.0d0
6345       estr1=0.0d0
6346       do i=ibondp_start,ibondp_end
6347 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6348 c      used
6349 #ifdef FIVEDIAG
6350         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6351         diff = vbld(i)-vbldp0
6352 #else
6353         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6354 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6355 c          do j=1,3
6356 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6357 c     &      *dc(j,i-1)/vbld(i)
6358 c          enddo
6359 c          if (energy_dec) write(iout,*)
6360 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6361 c        else
6362 C       Checking if it involves dummy (NH3+ or COO-) group
6363         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6364 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6365           diff = vbld(i)-vbldpDUM
6366           if (energy_dec) write(iout,*) "dum_bond",i,diff
6367         else
6368 C NO    vbldp0 is the equlibrium length of spring for peptide group
6369           diff = vbld(i)-vbldp0
6370         endif
6371 #endif
6372         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6373      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6374         estr=estr+diff*diff
6375         do j=1,3
6376           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6377         enddo
6378 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6379 c        endif
6380       enddo
6381
6382       estr=0.5d0*AKP*estr+estr1
6383 c
6384 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6385 c
6386       do i=ibond_start,ibond_end
6387         iti=iabs(itype(i))
6388         if (iti.ne.10 .and. iti.ne.ntyp1) then
6389           nbi=nbondterm(iti)
6390           if (nbi.eq.1) then
6391             diff=vbld(i+nres)-vbldsc0(1,iti)
6392             if (energy_dec)  write (iout,*)
6393      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6394      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6395             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6396             do j=1,3
6397               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6398             enddo
6399           else
6400             do j=1,nbi
6401               diff=vbld(i+nres)-vbldsc0(j,iti)
6402               ud(j)=aksc(j,iti)*diff
6403               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6404             enddo
6405             uprod=u(1)
6406             do j=2,nbi
6407               uprod=uprod*u(j)
6408             enddo
6409             usum=0.0d0
6410             usumsqder=0.0d0
6411             do j=1,nbi
6412               uprod1=1.0d0
6413               uprod2=1.0d0
6414               do k=1,nbi
6415                 if (k.ne.j) then
6416                   uprod1=uprod1*u(k)
6417                   uprod2=uprod2*u(k)*u(k)
6418                 endif
6419               enddo
6420               usum=usum+uprod1
6421               usumsqder=usumsqder+ud(j)*uprod2
6422             enddo
6423             estr=estr+uprod/usum
6424             do j=1,3
6425              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6426             enddo
6427           endif
6428         endif
6429       enddo
6430       return
6431       end
6432 #ifdef CRYST_THETA
6433 C--------------------------------------------------------------------------
6434       subroutine ebend(etheta)
6435 C
6436 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6437 C angles gamma and its derivatives in consecutive thetas and gammas.
6438 C
6439       implicit real*8 (a-h,o-z)
6440       include 'DIMENSIONS'
6441       include 'COMMON.LOCAL'
6442       include 'COMMON.GEO'
6443       include 'COMMON.INTERACT'
6444       include 'COMMON.DERIV'
6445       include 'COMMON.VAR'
6446       include 'COMMON.CHAIN'
6447       include 'COMMON.IOUNITS'
6448       include 'COMMON.NAMES'
6449       include 'COMMON.FFIELD'
6450       include 'COMMON.CONTROL'
6451       include 'COMMON.TORCNSTR'
6452       common /calcthet/ term1,term2,termm,diffak,ratak,
6453      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6454      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6455       double precision y(2),z(2)
6456       delta=0.02d0*pi
6457 c      time11=dexp(-2*time)
6458 c      time12=1.0d0
6459       etheta=0.0D0
6460 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6461       do i=ithet_start,ithet_end
6462         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6463      &  .or.itype(i).eq.ntyp1) cycle
6464 C Zero the energy function and its derivative at 0 or pi.
6465         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6466         it=itype(i-1)
6467         ichir1=isign(1,itype(i-2))
6468         ichir2=isign(1,itype(i))
6469          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6470          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6471          if (itype(i-1).eq.10) then
6472           itype1=isign(10,itype(i-2))
6473           ichir11=isign(1,itype(i-2))
6474           ichir12=isign(1,itype(i-2))
6475           itype2=isign(10,itype(i))
6476           ichir21=isign(1,itype(i))
6477           ichir22=isign(1,itype(i))
6478          endif
6479
6480         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6481 #ifdef OSF
6482           phii=phi(i)
6483           if (phii.ne.phii) phii=150.0
6484 #else
6485           phii=phi(i)
6486 #endif
6487           y(1)=dcos(phii)
6488           y(2)=dsin(phii)
6489         else
6490           y(1)=0.0D0
6491           y(2)=0.0D0
6492         endif
6493         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6494 #ifdef OSF
6495           phii1=phi(i+1)
6496           if (phii1.ne.phii1) phii1=150.0
6497           phii1=pinorm(phii1)
6498           z(1)=cos(phii1)
6499 #else
6500           phii1=phi(i+1)
6501 #endif
6502           z(1)=dcos(phii1)
6503           z(2)=dsin(phii1)
6504         else
6505           z(1)=0.0D0
6506           z(2)=0.0D0
6507         endif
6508 C Calculate the "mean" value of theta from the part of the distribution
6509 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6510 C In following comments this theta will be referred to as t_c.
6511         thet_pred_mean=0.0d0
6512         do k=1,2
6513             athetk=athet(k,it,ichir1,ichir2)
6514             bthetk=bthet(k,it,ichir1,ichir2)
6515           if (it.eq.10) then
6516              athetk=athet(k,itype1,ichir11,ichir12)
6517              bthetk=bthet(k,itype2,ichir21,ichir22)
6518           endif
6519          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6520 c         write(iout,*) 'chuj tu', y(k),z(k)
6521         enddo
6522         dthett=thet_pred_mean*ssd
6523         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6524 C Derivatives of the "mean" values in gamma1 and gamma2.
6525         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6526      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6527          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6528      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6529          if (it.eq.10) then
6530       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6531      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6532         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6533      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6534          endif
6535         if (theta(i).gt.pi-delta) then
6536           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6537      &         E_tc0)
6538           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6539           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6540           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6541      &        E_theta)
6542           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6543      &        E_tc)
6544         else if (theta(i).lt.delta) then
6545           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6546           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6547           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6548      &        E_theta)
6549           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6550           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6551      &        E_tc)
6552         else
6553           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6554      &        E_theta,E_tc)
6555         endif
6556         etheta=etheta+ethetai
6557         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6558      &      'ebend',i,ethetai,theta(i),itype(i)
6559         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6560         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6561         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6562       enddo
6563
6564 C Ufff.... We've done all this!!!
6565       return
6566       end
6567 C---------------------------------------------------------------------------
6568       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6569      &     E_tc)
6570       implicit real*8 (a-h,o-z)
6571       include 'DIMENSIONS'
6572       include 'COMMON.LOCAL'
6573       include 'COMMON.IOUNITS'
6574       common /calcthet/ term1,term2,termm,diffak,ratak,
6575      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6576      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6577 C Calculate the contributions to both Gaussian lobes.
6578 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6579 C The "polynomial part" of the "standard deviation" of this part of
6580 C the distributioni.
6581 ccc        write (iout,*) thetai,thet_pred_mean
6582         sig=polthet(3,it)
6583         do j=2,0,-1
6584           sig=sig*thet_pred_mean+polthet(j,it)
6585         enddo
6586 C Derivative of the "interior part" of the "standard deviation of the"
6587 C gamma-dependent Gaussian lobe in t_c.
6588         sigtc=3*polthet(3,it)
6589         do j=2,1,-1
6590           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6591         enddo
6592         sigtc=sig*sigtc
6593 C Set the parameters of both Gaussian lobes of the distribution.
6594 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6595         fac=sig*sig+sigc0(it)
6596         sigcsq=fac+fac
6597         sigc=1.0D0/sigcsq
6598 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6599         sigsqtc=-4.0D0*sigcsq*sigtc
6600 c       print *,i,sig,sigtc,sigsqtc
6601 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6602         sigtc=-sigtc/(fac*fac)
6603 C Following variable is sigma(t_c)**(-2)
6604         sigcsq=sigcsq*sigcsq
6605         sig0i=sig0(it)
6606         sig0inv=1.0D0/sig0i**2
6607         delthec=thetai-thet_pred_mean
6608         delthe0=thetai-theta0i
6609         term1=-0.5D0*sigcsq*delthec*delthec
6610         term2=-0.5D0*sig0inv*delthe0*delthe0
6611 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6612 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6613 C NaNs in taking the logarithm. We extract the largest exponent which is added
6614 C to the energy (this being the log of the distribution) at the end of energy
6615 C term evaluation for this virtual-bond angle.
6616         if (term1.gt.term2) then
6617           termm=term1
6618           term2=dexp(term2-termm)
6619           term1=1.0d0
6620         else
6621           termm=term2
6622           term1=dexp(term1-termm)
6623           term2=1.0d0
6624         endif
6625 C The ratio between the gamma-independent and gamma-dependent lobes of
6626 C the distribution is a Gaussian function of thet_pred_mean too.
6627         diffak=gthet(2,it)-thet_pred_mean
6628         ratak=diffak/gthet(3,it)**2
6629         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6630 C Let's differentiate it in thet_pred_mean NOW.
6631         aktc=ak*ratak
6632 C Now put together the distribution terms to make complete distribution.
6633         termexp=term1+ak*term2
6634         termpre=sigc+ak*sig0i
6635 C Contribution of the bending energy from this theta is just the -log of
6636 C the sum of the contributions from the two lobes and the pre-exponential
6637 C factor. Simple enough, isn't it?
6638         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6639 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6640 C NOW the derivatives!!!
6641 C 6/6/97 Take into account the deformation.
6642         E_theta=(delthec*sigcsq*term1
6643      &       +ak*delthe0*sig0inv*term2)/termexp
6644         E_tc=((sigtc+aktc*sig0i)/termpre
6645      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6646      &       aktc*term2)/termexp)
6647       return
6648       end
6649 c-----------------------------------------------------------------------------
6650       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6651       implicit real*8 (a-h,o-z)
6652       include 'DIMENSIONS'
6653       include 'COMMON.LOCAL'
6654       include 'COMMON.IOUNITS'
6655       common /calcthet/ term1,term2,termm,diffak,ratak,
6656      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6657      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6658       delthec=thetai-thet_pred_mean
6659       delthe0=thetai-theta0i
6660 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6661       t3 = thetai-thet_pred_mean
6662       t6 = t3**2
6663       t9 = term1
6664       t12 = t3*sigcsq
6665       t14 = t12+t6*sigsqtc
6666       t16 = 1.0d0
6667       t21 = thetai-theta0i
6668       t23 = t21**2
6669       t26 = term2
6670       t27 = t21*t26
6671       t32 = termexp
6672       t40 = t32**2
6673       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6674      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6675      & *(-t12*t9-ak*sig0inv*t27)
6676       return
6677       end
6678 #else
6679 C--------------------------------------------------------------------------
6680       subroutine ebend(etheta)
6681 C
6682 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6683 C angles gamma and its derivatives in consecutive thetas and gammas.
6684 C ab initio-derived potentials from
6685 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6686 C
6687       implicit real*8 (a-h,o-z)
6688       include 'DIMENSIONS'
6689       include 'COMMON.LOCAL'
6690       include 'COMMON.GEO'
6691       include 'COMMON.INTERACT'
6692       include 'COMMON.DERIV'
6693       include 'COMMON.VAR'
6694       include 'COMMON.CHAIN'
6695       include 'COMMON.IOUNITS'
6696       include 'COMMON.NAMES'
6697       include 'COMMON.FFIELD'
6698       include 'COMMON.CONTROL'
6699       include 'COMMON.TORCNSTR'
6700       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6701      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6702      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6703      & sinph1ph2(maxdouble,maxdouble)
6704       logical lprn /.false./, lprn1 /.false./
6705       etheta=0.0D0
6706       do i=ithet_start,ithet_end
6707 c        print *,i,itype(i-1),itype(i),itype(i-2)
6708         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6709      &  .or.itype(i).eq.ntyp1) cycle
6710 C        print *,i,theta(i)
6711         if (iabs(itype(i+1)).eq.20) iblock=2
6712         if (iabs(itype(i+1)).ne.20) iblock=1
6713         dethetai=0.0d0
6714         dephii=0.0d0
6715         dephii1=0.0d0
6716         theti2=0.5d0*theta(i)
6717         ityp2=ithetyp((itype(i-1)))
6718         do k=1,nntheterm
6719           coskt(k)=dcos(k*theti2)
6720           sinkt(k)=dsin(k*theti2)
6721         enddo
6722 C        print *,ethetai
6723         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6724 #ifdef OSF
6725           phii=phi(i)
6726           if (phii.ne.phii) phii=150.0
6727 #else
6728           phii=phi(i)
6729 #endif
6730           ityp1=ithetyp((itype(i-2)))
6731 C propagation of chirality for glycine type
6732           do k=1,nsingle
6733             cosph1(k)=dcos(k*phii)
6734             sinph1(k)=dsin(k*phii)
6735           enddo
6736         else
6737           phii=0.0d0
6738           do k=1,nsingle
6739           ityp1=ithetyp((itype(i-2)))
6740             cosph1(k)=0.0d0
6741             sinph1(k)=0.0d0
6742           enddo
6743         endif
6744         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6745 #ifdef OSF
6746           phii1=phi(i+1)
6747           if (phii1.ne.phii1) phii1=150.0
6748           phii1=pinorm(phii1)
6749 #else
6750           phii1=phi(i+1)
6751 #endif
6752           ityp3=ithetyp((itype(i)))
6753           do k=1,nsingle
6754             cosph2(k)=dcos(k*phii1)
6755             sinph2(k)=dsin(k*phii1)
6756           enddo
6757         else
6758           phii1=0.0d0
6759           ityp3=ithetyp((itype(i)))
6760           do k=1,nsingle
6761             cosph2(k)=0.0d0
6762             sinph2(k)=0.0d0
6763           enddo
6764         endif
6765         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6766         do k=1,ndouble
6767           do l=1,k-1
6768             ccl=cosph1(l)*cosph2(k-l)
6769             ssl=sinph1(l)*sinph2(k-l)
6770             scl=sinph1(l)*cosph2(k-l)
6771             csl=cosph1(l)*sinph2(k-l)
6772             cosph1ph2(l,k)=ccl-ssl
6773             cosph1ph2(k,l)=ccl+ssl
6774             sinph1ph2(l,k)=scl+csl
6775             sinph1ph2(k,l)=scl-csl
6776           enddo
6777         enddo
6778         if (lprn) then
6779         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6780      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6781         write (iout,*) "coskt and sinkt"
6782         do k=1,nntheterm
6783           write (iout,*) k,coskt(k),sinkt(k)
6784         enddo
6785         endif
6786         do k=1,ntheterm
6787           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6788           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6789      &      *coskt(k)
6790           if (lprn)
6791      &    write (iout,*) "k",k,"
6792      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6793      &     " ethetai",ethetai
6794         enddo
6795         if (lprn) then
6796         write (iout,*) "cosph and sinph"
6797         do k=1,nsingle
6798           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6799         enddo
6800         write (iout,*) "cosph1ph2 and sinph2ph2"
6801         do k=2,ndouble
6802           do l=1,k-1
6803             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6804      &         sinph1ph2(l,k),sinph1ph2(k,l)
6805           enddo
6806         enddo
6807         write(iout,*) "ethetai",ethetai
6808         endif
6809 C       print *,ethetai
6810         do m=1,ntheterm2
6811           do k=1,nsingle
6812             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6813      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6814      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6815      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6816             ethetai=ethetai+sinkt(m)*aux
6817             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6818             dephii=dephii+k*sinkt(m)*(
6819      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6820      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6821             dephii1=dephii1+k*sinkt(m)*(
6822      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6823      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6824             if (lprn)
6825      &      write (iout,*) "m",m," k",k," bbthet",
6826      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6827      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6828      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6829      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6830 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6831           enddo
6832         enddo
6833 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6834 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6835 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6836 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6837         if (lprn)
6838      &  write(iout,*) "ethetai",ethetai
6839 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6840         do m=1,ntheterm3
6841           do k=2,ndouble
6842             do l=1,k-1
6843               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6844      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6845      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6846      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6847               ethetai=ethetai+sinkt(m)*aux
6848               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6849               dephii=dephii+l*sinkt(m)*(
6850      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6851      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6852      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6853      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6854               dephii1=dephii1+(k-l)*sinkt(m)*(
6855      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6856      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6857      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6858      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6859               if (lprn) then
6860               write (iout,*) "m",m," k",k," l",l," ffthet",
6861      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6862      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6863      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6864      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6865      &            " ethetai",ethetai
6866               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6867      &            cosph1ph2(k,l)*sinkt(m),
6868      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6869               endif
6870             enddo
6871           enddo
6872         enddo
6873 10      continue
6874 c        lprn1=.true.
6875 C        print *,ethetai
6876         if (lprn1)
6877      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6878      &   i,theta(i)*rad2deg,phii*rad2deg,
6879      &   phii1*rad2deg,ethetai
6880 c        lprn1=.false.
6881         etheta=etheta+ethetai
6882         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6883         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6884         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6885       enddo
6886
6887       return
6888       end
6889 #endif
6890 #ifdef CRYST_SC
6891 c-----------------------------------------------------------------------------
6892       subroutine esc(escloc)
6893 C Calculate the local energy of a side chain and its derivatives in the
6894 C corresponding virtual-bond valence angles THETA and the spherical angles
6895 C ALPHA and OMEGA.
6896       implicit real*8 (a-h,o-z)
6897       include 'DIMENSIONS'
6898       include 'COMMON.GEO'
6899       include 'COMMON.LOCAL'
6900       include 'COMMON.VAR'
6901       include 'COMMON.INTERACT'
6902       include 'COMMON.DERIV'
6903       include 'COMMON.CHAIN'
6904       include 'COMMON.IOUNITS'
6905       include 'COMMON.NAMES'
6906       include 'COMMON.FFIELD'
6907       include 'COMMON.CONTROL'
6908       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6909      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6910       common /sccalc/ time11,time12,time112,theti,it,nlobit
6911       delta=0.02d0*pi
6912       escloc=0.0D0
6913 c     write (iout,'(a)') 'ESC'
6914       do i=loc_start,loc_end
6915         it=itype(i)
6916         if (it.eq.ntyp1) cycle
6917         if (it.eq.10) goto 1
6918         nlobit=nlob(iabs(it))
6919 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6920 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6921         theti=theta(i+1)-pipol
6922         x(1)=dtan(theti)
6923         x(2)=alph(i)
6924         x(3)=omeg(i)
6925
6926         if (x(2).gt.pi-delta) then
6927           xtemp(1)=x(1)
6928           xtemp(2)=pi-delta
6929           xtemp(3)=x(3)
6930           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6931           xtemp(2)=pi
6932           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6933           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6934      &        escloci,dersc(2))
6935           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6936      &        ddersc0(1),dersc(1))
6937           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6938      &        ddersc0(3),dersc(3))
6939           xtemp(2)=pi-delta
6940           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6941           xtemp(2)=pi
6942           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6943           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6944      &            dersc0(2),esclocbi,dersc02)
6945           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6946      &            dersc12,dersc01)
6947           call splinthet(x(2),0.5d0*delta,ss,ssd)
6948           dersc0(1)=dersc01
6949           dersc0(2)=dersc02
6950           dersc0(3)=0.0d0
6951           do k=1,3
6952             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6953           enddo
6954           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6955 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6956 c    &             esclocbi,ss,ssd
6957           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6958 c         escloci=esclocbi
6959 c         write (iout,*) escloci
6960         else if (x(2).lt.delta) then
6961           xtemp(1)=x(1)
6962           xtemp(2)=delta
6963           xtemp(3)=x(3)
6964           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6965           xtemp(2)=0.0d0
6966           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6967           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6968      &        escloci,dersc(2))
6969           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6970      &        ddersc0(1),dersc(1))
6971           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6972      &        ddersc0(3),dersc(3))
6973           xtemp(2)=delta
6974           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6975           xtemp(2)=0.0d0
6976           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6977           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6978      &            dersc0(2),esclocbi,dersc02)
6979           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6980      &            dersc12,dersc01)
6981           dersc0(1)=dersc01
6982           dersc0(2)=dersc02
6983           dersc0(3)=0.0d0
6984           call splinthet(x(2),0.5d0*delta,ss,ssd)
6985           do k=1,3
6986             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6987           enddo
6988           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6989 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6990 c    &             esclocbi,ss,ssd
6991           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6992 c         write (iout,*) escloci
6993         else
6994           call enesc(x,escloci,dersc,ddummy,.false.)
6995         endif
6996
6997         escloc=escloc+escloci
6998         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6999      &     'escloc',i,escloci
7000 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
7001
7002         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
7003      &   wscloc*dersc(1)
7004         gloc(ialph(i,1),icg)=wscloc*dersc(2)
7005         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
7006     1   continue
7007       enddo
7008       return
7009       end
7010 C---------------------------------------------------------------------------
7011       subroutine enesc(x,escloci,dersc,ddersc,mixed)
7012       implicit real*8 (a-h,o-z)
7013       include 'DIMENSIONS'
7014       include 'COMMON.GEO'
7015       include 'COMMON.LOCAL'
7016       include 'COMMON.IOUNITS'
7017       common /sccalc/ time11,time12,time112,theti,it,nlobit
7018       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7019       double precision contr(maxlob,-1:1)
7020       logical mixed
7021 c       write (iout,*) 'it=',it,' nlobit=',nlobit
7022         escloc_i=0.0D0
7023         do j=1,3
7024           dersc(j)=0.0D0
7025           if (mixed) ddersc(j)=0.0d0
7026         enddo
7027         x3=x(3)
7028
7029 C Because of periodicity of the dependence of the SC energy in omega we have
7030 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7031 C To avoid underflows, first compute & store the exponents.
7032
7033         do iii=-1,1
7034
7035           x(3)=x3+iii*dwapi
7036
7037           do j=1,nlobit
7038             do k=1,3
7039               z(k)=x(k)-censc(k,j,it)
7040             enddo
7041             do k=1,3
7042               Axk=0.0D0
7043               do l=1,3
7044                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7045               enddo
7046               Ax(k,j,iii)=Axk
7047             enddo
7048             expfac=0.0D0
7049             do k=1,3
7050               expfac=expfac+Ax(k,j,iii)*z(k)
7051             enddo
7052             contr(j,iii)=expfac
7053           enddo ! j
7054
7055         enddo ! iii
7056
7057         x(3)=x3
7058 C As in the case of ebend, we want to avoid underflows in exponentiation and
7059 C subsequent NaNs and INFs in energy calculation.
7060 C Find the largest exponent
7061         emin=contr(1,-1)
7062         do iii=-1,1
7063           do j=1,nlobit
7064             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7065           enddo
7066         enddo
7067         emin=0.5D0*emin
7068 cd      print *,'it=',it,' emin=',emin
7069
7070 C Compute the contribution to SC energy and derivatives
7071         do iii=-1,1
7072
7073           do j=1,nlobit
7074 #ifdef OSF
7075             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7076             if(adexp.ne.adexp) adexp=1.0
7077             expfac=dexp(adexp)
7078 #else
7079             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7080 #endif
7081 cd          print *,'j=',j,' expfac=',expfac
7082             escloc_i=escloc_i+expfac
7083             do k=1,3
7084               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7085             enddo
7086             if (mixed) then
7087               do k=1,3,2
7088                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7089      &            +gaussc(k,2,j,it))*expfac
7090               enddo
7091             endif
7092           enddo
7093
7094         enddo ! iii
7095
7096         dersc(1)=dersc(1)/cos(theti)**2
7097         ddersc(1)=ddersc(1)/cos(theti)**2
7098         ddersc(3)=ddersc(3)
7099
7100         escloci=-(dlog(escloc_i)-emin)
7101         do j=1,3
7102           dersc(j)=dersc(j)/escloc_i
7103         enddo
7104         if (mixed) then
7105           do j=1,3,2
7106             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7107           enddo
7108         endif
7109       return
7110       end
7111 C------------------------------------------------------------------------------
7112       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7113       implicit real*8 (a-h,o-z)
7114       include 'DIMENSIONS'
7115       include 'COMMON.GEO'
7116       include 'COMMON.LOCAL'
7117       include 'COMMON.IOUNITS'
7118       common /sccalc/ time11,time12,time112,theti,it,nlobit
7119       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7120       double precision contr(maxlob)
7121       logical mixed
7122
7123       escloc_i=0.0D0
7124
7125       do j=1,3
7126         dersc(j)=0.0D0
7127       enddo
7128
7129       do j=1,nlobit
7130         do k=1,2
7131           z(k)=x(k)-censc(k,j,it)
7132         enddo
7133         z(3)=dwapi
7134         do k=1,3
7135           Axk=0.0D0
7136           do l=1,3
7137             Axk=Axk+gaussc(l,k,j,it)*z(l)
7138           enddo
7139           Ax(k,j)=Axk
7140         enddo
7141         expfac=0.0D0
7142         do k=1,3
7143           expfac=expfac+Ax(k,j)*z(k)
7144         enddo
7145         contr(j)=expfac
7146       enddo ! j
7147
7148 C As in the case of ebend, we want to avoid underflows in exponentiation and
7149 C subsequent NaNs and INFs in energy calculation.
7150 C Find the largest exponent
7151       emin=contr(1)
7152       do j=1,nlobit
7153         if (emin.gt.contr(j)) emin=contr(j)
7154       enddo
7155       emin=0.5D0*emin
7156
7157 C Compute the contribution to SC energy and derivatives
7158
7159       dersc12=0.0d0
7160       do j=1,nlobit
7161         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7162         escloc_i=escloc_i+expfac
7163         do k=1,2
7164           dersc(k)=dersc(k)+Ax(k,j)*expfac
7165         enddo
7166         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7167      &            +gaussc(1,2,j,it))*expfac
7168         dersc(3)=0.0d0
7169       enddo
7170
7171       dersc(1)=dersc(1)/cos(theti)**2
7172       dersc12=dersc12/cos(theti)**2
7173       escloci=-(dlog(escloc_i)-emin)
7174       do j=1,2
7175         dersc(j)=dersc(j)/escloc_i
7176       enddo
7177       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7178       return
7179       end
7180 #else
7181 c----------------------------------------------------------------------------------
7182       subroutine esc(escloc)
7183 C Calculate the local energy of a side chain and its derivatives in the
7184 C corresponding virtual-bond valence angles THETA and the spherical angles
7185 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7186 C added by Urszula Kozlowska. 07/11/2007
7187 C
7188       implicit real*8 (a-h,o-z)
7189       include 'DIMENSIONS'
7190       include 'COMMON.GEO'
7191       include 'COMMON.LOCAL'
7192       include 'COMMON.VAR'
7193       include 'COMMON.SCROT'
7194       include 'COMMON.INTERACT'
7195       include 'COMMON.DERIV'
7196       include 'COMMON.CHAIN'
7197       include 'COMMON.IOUNITS'
7198       include 'COMMON.NAMES'
7199       include 'COMMON.FFIELD'
7200       include 'COMMON.CONTROL'
7201       include 'COMMON.VECTORS'
7202       double precision x_prime(3),y_prime(3),z_prime(3)
7203      &    , sumene,dsc_i,dp2_i,x(65),
7204      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7205      &    de_dxx,de_dyy,de_dzz,de_dt
7206       double precision s1_t,s1_6_t,s2_t,s2_6_t
7207       double precision
7208      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7209      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7210      & dt_dCi(3),dt_dCi1(3)
7211       common /sccalc/ time11,time12,time112,theti,it,nlobit
7212       delta=0.02d0*pi
7213       escloc=0.0D0
7214       do i=loc_start,loc_end
7215         if (itype(i).eq.ntyp1) cycle
7216         costtab(i+1) =dcos(theta(i+1))
7217         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7218         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7219         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7220         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7221         cosfac=dsqrt(cosfac2)
7222         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7223         sinfac=dsqrt(sinfac2)
7224         it=iabs(itype(i))
7225         if (it.eq.10) goto 1
7226 c
7227 C  Compute the axes of tghe local cartesian coordinates system; store in
7228 c   x_prime, y_prime and z_prime
7229 c
7230         do j=1,3
7231           x_prime(j) = 0.00
7232           y_prime(j) = 0.00
7233           z_prime(j) = 0.00
7234         enddo
7235 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7236 C     &   dc_norm(3,i+nres)
7237         do j = 1,3
7238           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7239           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7240         enddo
7241         do j = 1,3
7242           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7243         enddo
7244 c       write (2,*) "i",i
7245 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7246 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7247 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7248 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7249 c      & " xy",scalar(x_prime(1),y_prime(1)),
7250 c      & " xz",scalar(x_prime(1),z_prime(1)),
7251 c      & " yy",scalar(y_prime(1),y_prime(1)),
7252 c      & " yz",scalar(y_prime(1),z_prime(1)),
7253 c      & " zz",scalar(z_prime(1),z_prime(1))
7254 c
7255 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7256 C to local coordinate system. Store in xx, yy, zz.
7257 c
7258         xx=0.0d0
7259         yy=0.0d0
7260         zz=0.0d0
7261         do j = 1,3
7262           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7263           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7264           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7265         enddo
7266
7267         xxtab(i)=xx
7268         yytab(i)=yy
7269         zztab(i)=zz
7270 C
7271 C Compute the energy of the ith side cbain
7272 C
7273 c        write (2,*) "xx",xx," yy",yy," zz",zz
7274         it=iabs(itype(i))
7275         do j = 1,65
7276           x(j) = sc_parmin(j,it)
7277         enddo
7278 #ifdef CHECK_COORD
7279 Cc diagnostics - remove later
7280         xx1 = dcos(alph(2))
7281         yy1 = dsin(alph(2))*dcos(omeg(2))
7282         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7283         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7284      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7285      &    xx1,yy1,zz1
7286 C,"  --- ", xx_w,yy_w,zz_w
7287 c end diagnostics
7288 #endif
7289         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7290      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7291      &   + x(10)*yy*zz
7292         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7293      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7294      & + x(20)*yy*zz
7295         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7296      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7297      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7298      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7299      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7300      &  +x(40)*xx*yy*zz
7301         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7302      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7303      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7304      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7305      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7306      &  +x(60)*xx*yy*zz
7307         dsc_i   = 0.743d0+x(61)
7308         dp2_i   = 1.9d0+x(62)
7309         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7310      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7311         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7312      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7313         s1=(1+x(63))/(0.1d0 + dscp1)
7314         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7315         s2=(1+x(65))/(0.1d0 + dscp2)
7316         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7317         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7318      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7319 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7320 c     &   sumene4,
7321 c     &   dscp1,dscp2,sumene
7322 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7323         escloc = escloc + sumene
7324         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7325      &   " escloc",sumene,escloc,it,itype(i)
7326 c     & ,zz,xx,yy
7327 c#define DEBUG
7328 #ifdef DEBUG
7329 C
7330 C This section to check the numerical derivatives of the energy of ith side
7331 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7332 C #define DEBUG in the code to turn it on.
7333 C
7334         write (2,*) "sumene               =",sumene
7335         aincr=1.0d-7
7336         xxsave=xx
7337         xx=xx+aincr
7338         write (2,*) xx,yy,zz
7339         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7340         de_dxx_num=(sumenep-sumene)/aincr
7341         xx=xxsave
7342         write (2,*) "xx+ sumene from enesc=",sumenep
7343         yysave=yy
7344         yy=yy+aincr
7345         write (2,*) xx,yy,zz
7346         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7347         de_dyy_num=(sumenep-sumene)/aincr
7348         yy=yysave
7349         write (2,*) "yy+ sumene from enesc=",sumenep
7350         zzsave=zz
7351         zz=zz+aincr
7352         write (2,*) xx,yy,zz
7353         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7354         de_dzz_num=(sumenep-sumene)/aincr
7355         zz=zzsave
7356         write (2,*) "zz+ sumene from enesc=",sumenep
7357         costsave=cost2tab(i+1)
7358         sintsave=sint2tab(i+1)
7359         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7360         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7361         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7362         de_dt_num=(sumenep-sumene)/aincr
7363         write (2,*) " t+ sumene from enesc=",sumenep
7364         cost2tab(i+1)=costsave
7365         sint2tab(i+1)=sintsave
7366 C End of diagnostics section.
7367 #endif
7368 C
7369 C Compute the gradient of esc
7370 C
7371 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7372         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7373         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7374         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7375         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7376         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7377         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7378         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7379         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7380         pom1=(sumene3*sint2tab(i+1)+sumene1)
7381      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7382         pom2=(sumene4*cost2tab(i+1)+sumene2)
7383      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7384         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7385         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7386      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7387      &  +x(40)*yy*zz
7388         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7389         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7390      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7391      &  +x(60)*yy*zz
7392         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7393      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7394      &        +(pom1+pom2)*pom_dx
7395 #ifdef DEBUG
7396         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7397 #endif
7398 C
7399         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7400         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7401      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7402      &  +x(40)*xx*zz
7403         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7404         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7405      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7406      &  +x(59)*zz**2 +x(60)*xx*zz
7407         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7408      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7409      &        +(pom1-pom2)*pom_dy
7410 #ifdef DEBUG
7411         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7412 #endif
7413 C
7414         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7415      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7416      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7417      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7418      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7419      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7420      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7421      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7422 #ifdef DEBUG
7423         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7424 #endif
7425 C
7426         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7427      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7428      &  +pom1*pom_dt1+pom2*pom_dt2
7429 #ifdef DEBUG
7430         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7431 #endif
7432 c#undef DEBUG
7433 c
7434 C
7435        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7436        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7437        cosfac2xx=cosfac2*xx
7438        sinfac2yy=sinfac2*yy
7439        do k = 1,3
7440          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7441      &      vbld_inv(i+1)
7442          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7443      &      vbld_inv(i)
7444          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7445          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7446 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7447 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7448 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7449 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7450          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7451          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7452          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7453          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7454          dZZ_Ci1(k)=0.0d0
7455          dZZ_Ci(k)=0.0d0
7456          do j=1,3
7457            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7458      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7459            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7460      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7461          enddo
7462
7463          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7464          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7465          dZZ_XYZ(k)=vbld_inv(i+nres)*
7466      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7467 c
7468          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7469          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7470        enddo
7471
7472        do k=1,3
7473          dXX_Ctab(k,i)=dXX_Ci(k)
7474          dXX_C1tab(k,i)=dXX_Ci1(k)
7475          dYY_Ctab(k,i)=dYY_Ci(k)
7476          dYY_C1tab(k,i)=dYY_Ci1(k)
7477          dZZ_Ctab(k,i)=dZZ_Ci(k)
7478          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7479          dXX_XYZtab(k,i)=dXX_XYZ(k)
7480          dYY_XYZtab(k,i)=dYY_XYZ(k)
7481          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7482        enddo
7483
7484        do k = 1,3
7485 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7486 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7487 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7488 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7489 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7490 c     &    dt_dci(k)
7491 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7492 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7493          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7494      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7495          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7496      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7497          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7498      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7499        enddo
7500 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7501 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7502
7503 C to check gradient call subroutine check_grad
7504
7505     1 continue
7506       enddo
7507       return
7508       end
7509 c------------------------------------------------------------------------------
7510       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7511       implicit none
7512       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7513      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7514       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7515      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7516      &   + x(10)*yy*zz
7517       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7518      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7519      & + x(20)*yy*zz
7520       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7521      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7522      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7523      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7524      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7525      &  +x(40)*xx*yy*zz
7526       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7527      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7528      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7529      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7530      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7531      &  +x(60)*xx*yy*zz
7532       dsc_i   = 0.743d0+x(61)
7533       dp2_i   = 1.9d0+x(62)
7534       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7535      &          *(xx*cost2+yy*sint2))
7536       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7537      &          *(xx*cost2-yy*sint2))
7538       s1=(1+x(63))/(0.1d0 + dscp1)
7539       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7540       s2=(1+x(65))/(0.1d0 + dscp2)
7541       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7542       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7543      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7544       enesc=sumene
7545       return
7546       end
7547 #endif
7548 c------------------------------------------------------------------------------
7549       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7550 C
7551 C This procedure calculates two-body contact function g(rij) and its derivative:
7552 C
7553 C           eps0ij                                     !       x < -1
7554 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7555 C            0                                         !       x > 1
7556 C
7557 C where x=(rij-r0ij)/delta
7558 C
7559 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7560 C
7561       implicit none
7562       double precision rij,r0ij,eps0ij,fcont,fprimcont
7563       double precision x,x2,x4,delta
7564 c     delta=0.02D0*r0ij
7565 c      delta=0.2D0*r0ij
7566       x=(rij-r0ij)/delta
7567       if (x.lt.-1.0D0) then
7568         fcont=eps0ij
7569         fprimcont=0.0D0
7570       else if (x.le.1.0D0) then
7571         x2=x*x
7572         x4=x2*x2
7573         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7574         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7575       else
7576         fcont=0.0D0
7577         fprimcont=0.0D0
7578       endif
7579       return
7580       end
7581 c------------------------------------------------------------------------------
7582       subroutine splinthet(theti,delta,ss,ssder)
7583       implicit real*8 (a-h,o-z)
7584       include 'DIMENSIONS'
7585       include 'COMMON.VAR'
7586       include 'COMMON.GEO'
7587       thetup=pi-delta
7588       thetlow=delta
7589       if (theti.gt.pipol) then
7590         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7591       else
7592         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7593         ssder=-ssder
7594       endif
7595       return
7596       end
7597 c------------------------------------------------------------------------------
7598       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7599       implicit none
7600       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7601       double precision ksi,ksi2,ksi3,a1,a2,a3
7602       a1=fprim0*delta/(f1-f0)
7603       a2=3.0d0-2.0d0*a1
7604       a3=a1-2.0d0
7605       ksi=(x-x0)/delta
7606       ksi2=ksi*ksi
7607       ksi3=ksi2*ksi
7608       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7609       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7610       return
7611       end
7612 c------------------------------------------------------------------------------
7613       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7614       implicit none
7615       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7616       double precision ksi,ksi2,ksi3,a1,a2,a3
7617       ksi=(x-x0)/delta
7618       ksi2=ksi*ksi
7619       ksi3=ksi2*ksi
7620       a1=fprim0x*delta
7621       a2=3*(f1x-f0x)-2*fprim0x*delta
7622       a3=fprim0x*delta-2*(f1x-f0x)
7623       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7624       return
7625       end
7626 C-----------------------------------------------------------------------------
7627 #ifdef CRYST_TOR
7628 C-----------------------------------------------------------------------------
7629       subroutine etor(etors)
7630       implicit real*8 (a-h,o-z)
7631       include 'DIMENSIONS'
7632       include 'COMMON.VAR'
7633       include 'COMMON.GEO'
7634       include 'COMMON.LOCAL'
7635       include 'COMMON.TORSION'
7636       include 'COMMON.INTERACT'
7637       include 'COMMON.DERIV'
7638       include 'COMMON.CHAIN'
7639       include 'COMMON.NAMES'
7640       include 'COMMON.IOUNITS'
7641       include 'COMMON.FFIELD'
7642       include 'COMMON.TORCNSTR'
7643       include 'COMMON.CONTROL'
7644       logical lprn
7645 C Set lprn=.true. for debugging
7646       lprn=.false.
7647 c      lprn=.true.
7648       etors=0.0D0
7649       do i=iphi_start,iphi_end
7650       etors_ii=0.0D0
7651         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7652      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7653         itori=itortyp(itype(i-2))
7654         itori1=itortyp(itype(i-1))
7655         phii=phi(i)
7656         gloci=0.0D0
7657 C Proline-Proline pair is a special case...
7658         if (itori.eq.3 .and. itori1.eq.3) then
7659           if (phii.gt.-dwapi3) then
7660             cosphi=dcos(3*phii)
7661             fac=1.0D0/(1.0D0-cosphi)
7662             etorsi=v1(1,3,3)*fac
7663             etorsi=etorsi+etorsi
7664             etors=etors+etorsi-v1(1,3,3)
7665             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7666             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7667           endif
7668           do j=1,3
7669             v1ij=v1(j+1,itori,itori1)
7670             v2ij=v2(j+1,itori,itori1)
7671             cosphi=dcos(j*phii)
7672             sinphi=dsin(j*phii)
7673             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7674             if (energy_dec) etors_ii=etors_ii+
7675      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7676             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7677           enddo
7678         else
7679           do j=1,nterm_old
7680             v1ij=v1(j,itori,itori1)
7681             v2ij=v2(j,itori,itori1)
7682             cosphi=dcos(j*phii)
7683             sinphi=dsin(j*phii)
7684             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7685             if (energy_dec) etors_ii=etors_ii+
7686      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7687             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7688           enddo
7689         endif
7690         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7691              'etor',i,etors_ii
7692         if (lprn)
7693      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7694      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7695      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7696         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7697 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7698       enddo
7699       return
7700       end
7701 c------------------------------------------------------------------------------
7702       subroutine etor_d(etors_d)
7703       etors_d=0.0d0
7704       return
7705       end
7706 c----------------------------------------------------------------------------
7707 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7708       subroutine e_modeller(ehomology_constr)
7709       ehomology_constr=0.0d0
7710       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7711       return
7712       end
7713 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7714
7715 c------------------------------------------------------------------------------
7716       subroutine etor_d(etors_d)
7717       etors_d=0.0d0
7718       return
7719       end
7720 c----------------------------------------------------------------------------
7721 #else
7722       subroutine etor(etors)
7723       implicit real*8 (a-h,o-z)
7724       include 'DIMENSIONS'
7725       include 'COMMON.VAR'
7726       include 'COMMON.GEO'
7727       include 'COMMON.LOCAL'
7728       include 'COMMON.TORSION'
7729       include 'COMMON.INTERACT'
7730       include 'COMMON.DERIV'
7731       include 'COMMON.CHAIN'
7732       include 'COMMON.NAMES'
7733       include 'COMMON.IOUNITS'
7734       include 'COMMON.FFIELD'
7735       include 'COMMON.TORCNSTR'
7736       include 'COMMON.CONTROL'
7737       logical lprn
7738 C Set lprn=.true. for debugging
7739       lprn=.false.
7740 c     lprn=.true.
7741       etors=0.0D0
7742       do i=iphi_start,iphi_end
7743 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7744 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7745 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7746 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7747         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7748      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7749 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7750 C For introducing the NH3+ and COO- group please check the etor_d for reference
7751 C and guidance
7752         etors_ii=0.0D0
7753          if (iabs(itype(i)).eq.20) then
7754          iblock=2
7755          else
7756          iblock=1
7757          endif
7758         itori=itortyp(itype(i-2))
7759         itori1=itortyp(itype(i-1))
7760         phii=phi(i)
7761         gloci=0.0D0
7762 C Regular cosine and sine terms
7763         do j=1,nterm(itori,itori1,iblock)
7764           v1ij=v1(j,itori,itori1,iblock)
7765           v2ij=v2(j,itori,itori1,iblock)
7766           cosphi=dcos(j*phii)
7767           sinphi=dsin(j*phii)
7768           etors=etors+v1ij*cosphi+v2ij*sinphi
7769           if (energy_dec) etors_ii=etors_ii+
7770      &                v1ij*cosphi+v2ij*sinphi
7771           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7772         enddo
7773 C Lorentz terms
7774 C                         v1
7775 C  E = SUM ----------------------------------- - v1
7776 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7777 C
7778         cosphi=dcos(0.5d0*phii)
7779         sinphi=dsin(0.5d0*phii)
7780         do j=1,nlor(itori,itori1,iblock)
7781           vl1ij=vlor1(j,itori,itori1)
7782           vl2ij=vlor2(j,itori,itori1)
7783           vl3ij=vlor3(j,itori,itori1)
7784           pom=vl2ij*cosphi+vl3ij*sinphi
7785           pom1=1.0d0/(pom*pom+1.0d0)
7786           etors=etors+vl1ij*pom1
7787           if (energy_dec) etors_ii=etors_ii+
7788      &                vl1ij*pom1
7789           pom=-pom*pom1*pom1
7790           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7791         enddo
7792 C Subtract the constant term
7793         etors=etors-v0(itori,itori1,iblock)
7794           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7795      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7796         if (lprn)
7797      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7798      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7799      &  (v1(j,itori,itori1,iblock),j=1,6),
7800      &  (v2(j,itori,itori1,iblock),j=1,6)
7801         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7802 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7803       enddo
7804       return
7805       end
7806 c----------------------------------------------------------------------------
7807       subroutine etor_d(etors_d)
7808 C 6/23/01 Compute double torsional energy
7809       implicit real*8 (a-h,o-z)
7810       include 'DIMENSIONS'
7811       include 'COMMON.VAR'
7812       include 'COMMON.GEO'
7813       include 'COMMON.LOCAL'
7814       include 'COMMON.TORSION'
7815       include 'COMMON.INTERACT'
7816       include 'COMMON.DERIV'
7817       include 'COMMON.CHAIN'
7818       include 'COMMON.NAMES'
7819       include 'COMMON.IOUNITS'
7820       include 'COMMON.FFIELD'
7821       include 'COMMON.TORCNSTR'
7822       logical lprn
7823 C Set lprn=.true. for debugging
7824       lprn=.false.
7825 c     lprn=.true.
7826       etors_d=0.0D0
7827 c      write(iout,*) "a tu??"
7828       do i=iphid_start,iphid_end
7829 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7830 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7831 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7832 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7833 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7834          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7835      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7836      &  (itype(i+1).eq.ntyp1)) cycle
7837 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7838         itori=itortyp(itype(i-2))
7839         itori1=itortyp(itype(i-1))
7840         itori2=itortyp(itype(i))
7841         phii=phi(i)
7842         phii1=phi(i+1)
7843         gloci1=0.0D0
7844         gloci2=0.0D0
7845         iblock=1
7846         if (iabs(itype(i+1)).eq.20) iblock=2
7847 C Iblock=2 Proline type
7848 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7849 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7850 C        if (itype(i+1).eq.ntyp1) iblock=3
7851 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7852 C IS or IS NOT need for this
7853 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7854 C        is (itype(i-3).eq.ntyp1) ntblock=2
7855 C        ntblock is N-terminal blocking group
7856
7857 C Regular cosine and sine terms
7858         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7859 C Example of changes for NH3+ blocking group
7860 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7861 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7862           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7863           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7864           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7865           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7866           cosphi1=dcos(j*phii)
7867           sinphi1=dsin(j*phii)
7868           cosphi2=dcos(j*phii1)
7869           sinphi2=dsin(j*phii1)
7870           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7871      &     v2cij*cosphi2+v2sij*sinphi2
7872           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7873           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7874         enddo
7875         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7876           do l=1,k-1
7877             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7878             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7879             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7880             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7881             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7882             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7883             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7884             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7885             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7886      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7887             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7888      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7889             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7890      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7891           enddo
7892         enddo
7893         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7894         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7895       enddo
7896       return
7897       end
7898 #endif
7899 C----------------------------------------------------------------------------------
7900 C The rigorous attempt to derive energy function
7901       subroutine etor_kcc(etors)
7902       implicit real*8 (a-h,o-z)
7903       include 'DIMENSIONS'
7904       include 'COMMON.VAR'
7905       include 'COMMON.GEO'
7906       include 'COMMON.LOCAL'
7907       include 'COMMON.TORSION'
7908       include 'COMMON.INTERACT'
7909       include 'COMMON.DERIV'
7910       include 'COMMON.CHAIN'
7911       include 'COMMON.NAMES'
7912       include 'COMMON.IOUNITS'
7913       include 'COMMON.FFIELD'
7914       include 'COMMON.TORCNSTR'
7915       include 'COMMON.CONTROL'
7916       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7917       logical lprn
7918 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7919 C Set lprn=.true. for debugging
7920       lprn=energy_dec
7921 c     lprn=.true.
7922 C      print *,"wchodze kcc"
7923       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7924       etors=0.0D0
7925       do i=iphi_start,iphi_end
7926 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7927 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7928 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7929 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7930         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7931      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7932         itori=itortyp(itype(i-2))
7933         itori1=itortyp(itype(i-1))
7934         phii=phi(i)
7935         glocig=0.0D0
7936         glocit1=0.0d0
7937         glocit2=0.0d0
7938 C to avoid multiple devision by 2
7939 c        theti22=0.5d0*theta(i)
7940 C theta 12 is the theta_1 /2
7941 C theta 22 is theta_2 /2
7942 c        theti12=0.5d0*theta(i-1)
7943 C and appropriate sinus function
7944         sinthet1=dsin(theta(i-1))
7945         sinthet2=dsin(theta(i))
7946         costhet1=dcos(theta(i-1))
7947         costhet2=dcos(theta(i))
7948 C to speed up lets store its mutliplication
7949         sint1t2=sinthet2*sinthet1
7950         sint1t2n=1.0d0
7951 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7952 C +d_n*sin(n*gamma)) *
7953 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7954 C we have two sum 1) Non-Chebyshev which is with n and gamma
7955         nval=nterm_kcc_Tb(itori,itori1)
7956         c1(0)=0.0d0
7957         c2(0)=0.0d0
7958         c1(1)=1.0d0
7959         c2(1)=1.0d0
7960         do j=2,nval
7961           c1(j)=c1(j-1)*costhet1
7962           c2(j)=c2(j-1)*costhet2
7963         enddo
7964         etori=0.0d0
7965         do j=1,nterm_kcc(itori,itori1)
7966           cosphi=dcos(j*phii)
7967           sinphi=dsin(j*phii)
7968           sint1t2n1=sint1t2n
7969           sint1t2n=sint1t2n*sint1t2
7970           sumvalc=0.0d0
7971           gradvalct1=0.0d0
7972           gradvalct2=0.0d0
7973           do k=1,nval
7974             do l=1,nval
7975               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7976               gradvalct1=gradvalct1+
7977      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7978               gradvalct2=gradvalct2+
7979      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7980             enddo
7981           enddo
7982           gradvalct1=-gradvalct1*sinthet1
7983           gradvalct2=-gradvalct2*sinthet2
7984           sumvals=0.0d0
7985           gradvalst1=0.0d0
7986           gradvalst2=0.0d0
7987           do k=1,nval
7988             do l=1,nval
7989               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7990               gradvalst1=gradvalst1+
7991      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7992               gradvalst2=gradvalst2+
7993      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7994             enddo
7995           enddo
7996           gradvalst1=-gradvalst1*sinthet1
7997           gradvalst2=-gradvalst2*sinthet2
7998           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7999           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
8000 C glocig is the gradient local i site in gamma
8001           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
8002 C now gradient over theta_1
8003           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
8004      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
8005           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
8006      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
8007         enddo ! j
8008         etors=etors+etori
8009 C derivative over gamma
8010         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8011 C derivative over theta1
8012         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8013 C now derivative over theta2
8014         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8015         if (lprn) then
8016           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8017      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8018           write (iout,*) "c1",(c1(k),k=0,nval),
8019      &    " c2",(c2(k),k=0,nval)
8020         endif
8021       enddo
8022       return
8023       end
8024 c---------------------------------------------------------------------------------------------
8025       subroutine etor_constr(edihcnstr)
8026       implicit real*8 (a-h,o-z)
8027       include 'DIMENSIONS'
8028       include 'COMMON.VAR'
8029       include 'COMMON.GEO'
8030       include 'COMMON.LOCAL'
8031       include 'COMMON.TORSION'
8032       include 'COMMON.INTERACT'
8033       include 'COMMON.DERIV'
8034       include 'COMMON.CHAIN'
8035       include 'COMMON.NAMES'
8036       include 'COMMON.IOUNITS'
8037       include 'COMMON.FFIELD'
8038       include 'COMMON.TORCNSTR'
8039       include 'COMMON.BOUNDS'
8040       include 'COMMON.CONTROL'
8041 ! 6/20/98 - dihedral angle constraints
8042       edihcnstr=0.0d0
8043 c      do i=1,ndih_constr
8044       if (raw_psipred) then
8045         do i=idihconstr_start,idihconstr_end
8046           itori=idih_constr(i)
8047           phii=phi(itori)
8048           gaudih_i=vpsipred(1,i)
8049           gauder_i=0.0d0
8050           do j=1,2
8051             s = sdihed(j,i)
8052             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
8053             dexpcos_i=dexp(-cos_i*cos_i)
8054             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
8055             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
8056      &            *cos_i*dexpcos_i/s**2
8057           enddo
8058           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
8059           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
8060           if (energy_dec)
8061      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
8062      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
8063      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
8064      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
8065      &     -wdihc*dlog(gaudih_i)
8066         enddo
8067       else
8068
8069       do i=idihconstr_start,idihconstr_end
8070         itori=idih_constr(i)
8071         phii=phi(itori)
8072         difi=pinorm(phii-phi0(i))
8073         if (difi.gt.drange(i)) then
8074           difi=difi-drange(i)
8075           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8076           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8077         else if (difi.lt.-drange(i)) then
8078           difi=difi+drange(i)
8079           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8080           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8081         else
8082           difi=0.0
8083         endif
8084       enddo
8085
8086       endif
8087
8088       return
8089       end
8090 c----------------------------------------------------------------------------
8091 c MODELLER restraint function
8092       subroutine e_modeller(ehomology_constr)
8093       implicit none
8094       include 'DIMENSIONS'
8095
8096       double precision ehomology_constr
8097       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8098       integer katy, odleglosci, test7
8099       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8100       real*8 Eval,Erot
8101       real*8 distance(max_template),distancek(max_template),
8102      &    min_odl,godl(max_template),dih_diff(max_template)
8103
8104 c
8105 c     FP - 30/10/2014 Temporary specifications for homology restraints
8106 c
8107       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8108      &                 sgtheta
8109       double precision, dimension (maxres) :: guscdiff,usc_diff
8110       double precision, dimension (max_template) ::
8111      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8112      &           theta_diff
8113       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8114      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8115      & betai,sum_sgodl,dij
8116       double precision dist,pinorm
8117 c
8118       include 'COMMON.SBRIDGE'
8119       include 'COMMON.CHAIN'
8120       include 'COMMON.GEO'
8121       include 'COMMON.DERIV'
8122       include 'COMMON.LOCAL'
8123       include 'COMMON.INTERACT'
8124       include 'COMMON.VAR'
8125       include 'COMMON.IOUNITS'
8126 c      include 'COMMON.MD'
8127       include 'COMMON.CONTROL'
8128       include 'COMMON.HOMOLOGY'
8129       include 'COMMON.QRESTR'
8130 c
8131 c     From subroutine Econstr_back
8132 c
8133       include 'COMMON.NAMES'
8134       include 'COMMON.TIME1'
8135 c
8136
8137
8138       do i=1,max_template
8139         distancek(i)=9999999.9
8140       enddo
8141
8142
8143       odleg=0.0d0
8144
8145 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8146 c function)
8147 C AL 5/2/14 - Introduce list of restraints
8148 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8149 #ifdef DEBUG
8150       write(iout,*) "------- dist restrs start -------"
8151 #endif
8152       do ii = link_start_homo,link_end_homo
8153          i = ires_homo(ii)
8154          j = jres_homo(ii)
8155          dij=dist(i,j)
8156 c        write (iout,*) "dij(",i,j,") =",dij
8157          nexl=0
8158          do k=1,constr_homology
8159 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8160            if(.not.l_homo(k,ii)) then
8161              nexl=nexl+1
8162              cycle
8163            endif
8164            distance(k)=odl(k,ii)-dij
8165 c          write (iout,*) "distance(",k,") =",distance(k)
8166 c
8167 c          For Gaussian-type Urestr
8168 c
8169            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8170 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8171 c          write (iout,*) "distancek(",k,") =",distancek(k)
8172 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8173 c
8174 c          For Lorentzian-type Urestr
8175 c
8176            if (waga_dist.lt.0.0d0) then
8177               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8178               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8179      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8180            endif
8181          enddo
8182
8183 c         min_odl=minval(distancek)
8184          do kk=1,constr_homology
8185           if(l_homo(kk,ii)) then
8186             min_odl=distancek(kk)
8187             exit
8188           endif
8189          enddo
8190          do kk=1,constr_homology
8191           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8192      &              min_odl=distancek(kk)
8193          enddo
8194
8195 c        write (iout,* )"min_odl",min_odl
8196 #ifdef DEBUG
8197          write (iout,*) "ij dij",i,j,dij
8198          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8199          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8200          write (iout,* )"min_odl",min_odl
8201 #endif
8202 #ifdef OLDRESTR
8203          odleg2=0.0d0
8204 #else
8205          if (waga_dist.ge.0.0d0) then
8206            odleg2=nexl
8207          else
8208            odleg2=0.0d0
8209          endif
8210 #endif
8211          do k=1,constr_homology
8212 c Nie wiem po co to liczycie jeszcze raz!
8213 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8214 c     &              (2*(sigma_odl(i,j,k))**2))
8215            if(.not.l_homo(k,ii)) cycle
8216            if (waga_dist.ge.0.0d0) then
8217 c
8218 c          For Gaussian-type Urestr
8219 c
8220             godl(k)=dexp(-distancek(k)+min_odl)
8221             odleg2=odleg2+godl(k)
8222 c
8223 c          For Lorentzian-type Urestr
8224 c
8225            else
8226             odleg2=odleg2+distancek(k)
8227            endif
8228
8229 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8230 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8231 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8232 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8233
8234          enddo
8235 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8236 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8237 #ifdef DEBUG
8238          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8239          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8240 #endif
8241            if (waga_dist.ge.0.0d0) then
8242 c
8243 c          For Gaussian-type Urestr
8244 c
8245               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8246 c
8247 c          For Lorentzian-type Urestr
8248 c
8249            else
8250               odleg=odleg+odleg2/constr_homology
8251            endif
8252 c
8253 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8254 c Gradient
8255 c
8256 c          For Gaussian-type Urestr
8257 c
8258          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8259          sum_sgodl=0.0d0
8260          do k=1,constr_homology
8261 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8262 c     &           *waga_dist)+min_odl
8263 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8264 c
8265          if(.not.l_homo(k,ii)) cycle
8266          if (waga_dist.ge.0.0d0) then
8267 c          For Gaussian-type Urestr
8268 c
8269            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8270 c
8271 c          For Lorentzian-type Urestr
8272 c
8273          else
8274            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8275      &           sigma_odlir(k,ii)**2)**2)
8276          endif
8277            sum_sgodl=sum_sgodl+sgodl
8278
8279 c            sgodl2=sgodl2+sgodl
8280 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8281 c      write(iout,*) "constr_homology=",constr_homology
8282 c      write(iout,*) i, j, k, "TEST K"
8283          enddo
8284          if (waga_dist.ge.0.0d0) then
8285 c
8286 c          For Gaussian-type Urestr
8287 c
8288             grad_odl3=waga_homology(iset)*waga_dist
8289      &                *sum_sgodl/(sum_godl*dij)
8290 c
8291 c          For Lorentzian-type Urestr
8292 c
8293          else
8294 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8295 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8296             grad_odl3=-waga_homology(iset)*waga_dist*
8297      &                sum_sgodl/(constr_homology*dij)
8298          endif
8299 c
8300 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8301
8302
8303 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8304 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8305 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8306
8307 ccc      write(iout,*) godl, sgodl, grad_odl3
8308
8309 c          grad_odl=grad_odl+grad_odl3
8310
8311          do jik=1,3
8312             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8313 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8314 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8315 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8316             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8317             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8318 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8319 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8320 c         if (i.eq.25.and.j.eq.27) then
8321 c         write(iout,*) "jik",jik,"i",i,"j",j
8322 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8323 c         write(iout,*) "grad_odl3",grad_odl3
8324 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8325 c         write(iout,*) "ggodl",ggodl
8326 c         write(iout,*) "ghpbc(",jik,i,")",
8327 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8328 c     &                 ghpbc(jik,j)
8329 c         endif
8330          enddo
8331 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8332 ccc     & dLOG(odleg2),"-odleg=", -odleg
8333
8334       enddo ! ii-loop for dist
8335 #ifdef DEBUG
8336       write(iout,*) "------- dist restrs end -------"
8337 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8338 c    &     waga_d.eq.1.0d0) call sum_gradient
8339 #endif
8340 c Pseudo-energy and gradient from dihedral-angle restraints from
8341 c homology templates
8342 c      write (iout,*) "End of distance loop"
8343 c      call flush(iout)
8344       kat=0.0d0
8345 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8346 #ifdef DEBUG
8347       write(iout,*) "------- dih restrs start -------"
8348       do i=idihconstr_start_homo,idihconstr_end_homo
8349         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8350       enddo
8351 #endif
8352       do i=idihconstr_start_homo,idihconstr_end_homo
8353         kat2=0.0d0
8354 c        betai=beta(i,i+1,i+2,i+3)
8355         betai = phi(i)
8356 c       write (iout,*) "betai =",betai
8357         do k=1,constr_homology
8358           dih_diff(k)=pinorm(dih(k,i)-betai)
8359 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8360 cd     &                  ,sigma_dih(k,i)
8361 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8362 c     &                                   -(6.28318-dih_diff(i,k))
8363 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8364 c     &                                   6.28318+dih_diff(i,k)
8365 #ifdef OLD_DIHED
8366           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8367 #else
8368           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8369 #endif
8370 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8371           gdih(k)=dexp(kat3)
8372           kat2=kat2+gdih(k)
8373 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8374 c          write(*,*)""
8375         enddo
8376 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8377 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8378 #ifdef DEBUG
8379         write (iout,*) "i",i," betai",betai," kat2",kat2
8380         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8381 #endif
8382         if (kat2.le.1.0d-14) cycle
8383         kat=kat-dLOG(kat2/constr_homology)
8384 c       write (iout,*) "kat",kat ! sum of -ln-s
8385
8386 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8387 ccc     & dLOG(kat2), "-kat=", -kat
8388
8389 c ----------------------------------------------------------------------
8390 c Gradient
8391 c ----------------------------------------------------------------------
8392
8393         sum_gdih=kat2
8394         sum_sgdih=0.0d0
8395         do k=1,constr_homology
8396 #ifdef OLD_DIHED
8397           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8398 #else
8399           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8400 #endif
8401 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8402           sum_sgdih=sum_sgdih+sgdih
8403         enddo
8404 c       grad_dih3=sum_sgdih/sum_gdih
8405         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8406
8407 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8408 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8409 ccc     & gloc(nphi+i-3,icg)
8410         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8411 c        if (i.eq.25) then
8412 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8413 c        endif
8414 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8415 ccc     & gloc(nphi+i-3,icg)
8416
8417       enddo ! i-loop for dih
8418 #ifdef DEBUG
8419       write(iout,*) "------- dih restrs end -------"
8420 #endif
8421
8422 c Pseudo-energy and gradient for theta angle restraints from
8423 c homology templates
8424 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8425 c adapted
8426
8427 c
8428 c     For constr_homology reference structures (FP)
8429 c
8430 c     Uconst_back_tot=0.0d0
8431       Eval=0.0d0
8432       Erot=0.0d0
8433 c     Econstr_back legacy
8434       do i=1,nres
8435 c     do i=ithet_start,ithet_end
8436        dutheta(i)=0.0d0
8437 c     enddo
8438 c     do i=loc_start,loc_end
8439         do j=1,3
8440           duscdiff(j,i)=0.0d0
8441           duscdiffx(j,i)=0.0d0
8442         enddo
8443       enddo
8444 c
8445 c     do iref=1,nref
8446 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8447 c     write (iout,*) "waga_theta",waga_theta
8448       if (waga_theta.gt.0.0d0) then
8449 #ifdef DEBUG
8450       write (iout,*) "usampl",usampl
8451       write(iout,*) "------- theta restrs start -------"
8452 c     do i=ithet_start,ithet_end
8453 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8454 c     enddo
8455 #endif
8456 c     write (iout,*) "maxres",maxres,"nres",nres
8457
8458       do i=ithet_start,ithet_end
8459 c
8460 c     do i=1,nfrag_back
8461 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8462 c
8463 c Deviation of theta angles wrt constr_homology ref structures
8464 c
8465         utheta_i=0.0d0 ! argument of Gaussian for single k
8466         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8467 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8468 c       over residues in a fragment
8469 c       write (iout,*) "theta(",i,")=",theta(i)
8470         do k=1,constr_homology
8471 c
8472 c         dtheta_i=theta(j)-thetaref(j,iref)
8473 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8474           theta_diff(k)=thetatpl(k,i)-theta(i)
8475 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8476 cd     &                  ,sigma_theta(k,i)
8477
8478 c
8479           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8480 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8481           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8482           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8483 c         Gradient for single Gaussian restraint in subr Econstr_back
8484 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8485 c
8486         enddo
8487 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8488 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8489
8490 c
8491 c         Gradient for multiple Gaussian restraint
8492         sum_gtheta=gutheta_i
8493         sum_sgtheta=0.0d0
8494         do k=1,constr_homology
8495 c        New generalized expr for multiple Gaussian from Econstr_back
8496          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8497 c
8498 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8499           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8500         enddo
8501 c       Final value of gradient using same var as in Econstr_back
8502         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8503      &      +sum_sgtheta/sum_gtheta*waga_theta
8504      &               *waga_homology(iset)
8505 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8506 c     &               *waga_homology(iset)
8507 c       dutheta(i)=sum_sgtheta/sum_gtheta
8508 c
8509 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8510         Eval=Eval-dLOG(gutheta_i/constr_homology)
8511 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8512 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8513 c       Uconst_back=Uconst_back+utheta(i)
8514       enddo ! (i-loop for theta)
8515 #ifdef DEBUG
8516       write(iout,*) "------- theta restrs end -------"
8517 #endif
8518       endif
8519 c
8520 c Deviation of local SC geometry
8521 c
8522 c Separation of two i-loops (instructed by AL - 11/3/2014)
8523 c
8524 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8525 c     write (iout,*) "waga_d",waga_d
8526
8527 #ifdef DEBUG
8528       write(iout,*) "------- SC restrs start -------"
8529       write (iout,*) "Initial duscdiff,duscdiffx"
8530       do i=loc_start,loc_end
8531         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8532      &                 (duscdiffx(jik,i),jik=1,3)
8533       enddo
8534 #endif
8535       do i=loc_start,loc_end
8536         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8537         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8538 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8539 c       write(iout,*) "xxtab, yytab, zztab"
8540 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8541         do k=1,constr_homology
8542 c
8543           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8544 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8545           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8546           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8547 c         write(iout,*) "dxx, dyy, dzz"
8548 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8549 c
8550           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8551 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8552 c         uscdiffk(k)=usc_diff(i)
8553           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8554 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8555 c     &       " guscdiff2",guscdiff2(k)
8556           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8557 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8558 c     &      xxref(j),yyref(j),zzref(j)
8559         enddo
8560 c
8561 c       Gradient
8562 c
8563 c       Generalized expression for multiple Gaussian acc to that for a single
8564 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8565 c
8566 c       Original implementation
8567 c       sum_guscdiff=guscdiff(i)
8568 c
8569 c       sum_sguscdiff=0.0d0
8570 c       do k=1,constr_homology
8571 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8572 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8573 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8574 c       enddo
8575 c
8576 c       Implementation of new expressions for gradient (Jan. 2015)
8577 c
8578 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8579         do k=1,constr_homology
8580 c
8581 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8582 c       before. Now the drivatives should be correct
8583 c
8584           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8585 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8586           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8587           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8588 c
8589 c         New implementation
8590 c
8591           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8592      &                 sigma_d(k,i) ! for the grad wrt r'
8593 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8594 c
8595 c
8596 c        New implementation
8597          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8598          do jik=1,3
8599             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8600      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8601      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8602             duscdiff(jik,i)=duscdiff(jik,i)+
8603      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8604      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8605             duscdiffx(jik,i)=duscdiffx(jik,i)+
8606      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8607      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8608 c
8609 #ifdef DEBUG
8610              write(iout,*) "jik",jik,"i",i
8611              write(iout,*) "dxx, dyy, dzz"
8612              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8613              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8614 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8615 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8616 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8617 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8618 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8619 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8620 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8621 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8622 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8623 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8624 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8625 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8626 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8627 c            endif
8628 #endif
8629          enddo
8630         enddo
8631 c
8632 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8633 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8634 c
8635 c        write (iout,*) i," uscdiff",uscdiff(i)
8636 c
8637 c Put together deviations from local geometry
8638
8639 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8640 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8641         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8642 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8643 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8644 c       Uconst_back=Uconst_back+usc_diff(i)
8645 c
8646 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8647 c
8648 c     New implment: multiplied by sum_sguscdiff
8649 c
8650
8651       enddo ! (i-loop for dscdiff)
8652
8653 c      endif
8654
8655 #ifdef DEBUG
8656       write(iout,*) "------- SC restrs end -------"
8657         write (iout,*) "------ After SC loop in e_modeller ------"
8658         do i=loc_start,loc_end
8659          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8660          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8661         enddo
8662       if (waga_theta.eq.1.0d0) then
8663       write (iout,*) "in e_modeller after SC restr end: dutheta"
8664       do i=ithet_start,ithet_end
8665         write (iout,*) i,dutheta(i)
8666       enddo
8667       endif
8668       if (waga_d.eq.1.0d0) then
8669       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8670       do i=1,nres
8671         write (iout,*) i,(duscdiff(j,i),j=1,3)
8672         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8673       enddo
8674       endif
8675 #endif
8676
8677 c Total energy from homology restraints
8678 #ifdef DEBUG
8679       write (iout,*) "odleg",odleg," kat",kat
8680 #endif
8681 c
8682 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8683 c
8684 c     ehomology_constr=odleg+kat
8685 c
8686 c     For Lorentzian-type Urestr
8687 c
8688
8689       if (waga_dist.ge.0.0d0) then
8690 c
8691 c          For Gaussian-type Urestr
8692 c
8693         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8694      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8695 c     write (iout,*) "ehomology_constr=",ehomology_constr
8696       else
8697 c
8698 c          For Lorentzian-type Urestr
8699 c
8700         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8701      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8702 c     write (iout,*) "ehomology_constr=",ehomology_constr
8703       endif
8704 #ifdef DEBUG
8705       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8706      & "Eval",waga_theta,eval,
8707      &   "Erot",waga_d,Erot
8708       write (iout,*) "ehomology_constr",ehomology_constr
8709 #endif
8710       return
8711 c
8712 c FP 01/15 end
8713 c
8714   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8715   747 format(a12,i4,i4,i4,f8.3,f8.3)
8716   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8717   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8718   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8719      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8720       end
8721 c----------------------------------------------------------------------------
8722 C The rigorous attempt to derive energy function
8723       subroutine ebend_kcc(etheta)
8724
8725       implicit real*8 (a-h,o-z)
8726       include 'DIMENSIONS'
8727       include 'COMMON.VAR'
8728       include 'COMMON.GEO'
8729       include 'COMMON.LOCAL'
8730       include 'COMMON.TORSION'
8731       include 'COMMON.INTERACT'
8732       include 'COMMON.DERIV'
8733       include 'COMMON.CHAIN'
8734       include 'COMMON.NAMES'
8735       include 'COMMON.IOUNITS'
8736       include 'COMMON.FFIELD'
8737       include 'COMMON.TORCNSTR'
8738       include 'COMMON.CONTROL'
8739       logical lprn
8740       double precision thybt1(maxang_kcc)
8741 C Set lprn=.true. for debugging
8742       lprn=energy_dec
8743 c     lprn=.true.
8744 C      print *,"wchodze kcc"
8745       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8746       etheta=0.0D0
8747       do i=ithet_start,ithet_end
8748 c        print *,i,itype(i-1),itype(i),itype(i-2)
8749         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8750      &  .or.itype(i).eq.ntyp1) cycle
8751         iti=iabs(itortyp(itype(i-1)))
8752         sinthet=dsin(theta(i))
8753         costhet=dcos(theta(i))
8754         do j=1,nbend_kcc_Tb(iti)
8755           thybt1(j)=v1bend_chyb(j,iti)
8756         enddo
8757         sumth1thyb=v1bend_chyb(0,iti)+
8758      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8759         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8760      &    sumth1thyb
8761         ihelp=nbend_kcc_Tb(iti)-1
8762         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8763         etheta=etheta+sumth1thyb
8764 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8765         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8766       enddo
8767       return
8768       end
8769 c-------------------------------------------------------------------------------------
8770       subroutine etheta_constr(ethetacnstr)
8771
8772       implicit real*8 (a-h,o-z)
8773       include 'DIMENSIONS'
8774       include 'COMMON.VAR'
8775       include 'COMMON.GEO'
8776       include 'COMMON.LOCAL'
8777       include 'COMMON.TORSION'
8778       include 'COMMON.INTERACT'
8779       include 'COMMON.DERIV'
8780       include 'COMMON.CHAIN'
8781       include 'COMMON.NAMES'
8782       include 'COMMON.IOUNITS'
8783       include 'COMMON.FFIELD'
8784       include 'COMMON.TORCNSTR'
8785       include 'COMMON.CONTROL'
8786       ethetacnstr=0.0d0
8787 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8788       do i=ithetaconstr_start,ithetaconstr_end
8789         itheta=itheta_constr(i)
8790         thetiii=theta(itheta)
8791         difi=pinorm(thetiii-theta_constr0(i))
8792         if (difi.gt.theta_drange(i)) then
8793           difi=difi-theta_drange(i)
8794           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8795           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8796      &    +for_thet_constr(i)*difi**3
8797         else if (difi.lt.-drange(i)) then
8798           difi=difi+drange(i)
8799           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8800           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8801      &    +for_thet_constr(i)*difi**3
8802         else
8803           difi=0.0
8804         endif
8805        if (energy_dec) then
8806         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8807      &    i,itheta,rad2deg*thetiii,
8808      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8809      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8810      &    gloc(itheta+nphi-2,icg)
8811         endif
8812       enddo
8813       return
8814       end
8815 c------------------------------------------------------------------------------
8816       subroutine eback_sc_corr(esccor)
8817 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8818 c        conformational states; temporarily implemented as differences
8819 c        between UNRES torsional potentials (dependent on three types of
8820 c        residues) and the torsional potentials dependent on all 20 types
8821 c        of residues computed from AM1  energy surfaces of terminally-blocked
8822 c        amino-acid residues.
8823       implicit real*8 (a-h,o-z)
8824       include 'DIMENSIONS'
8825       include 'COMMON.VAR'
8826       include 'COMMON.GEO'
8827       include 'COMMON.LOCAL'
8828       include 'COMMON.TORSION'
8829       include 'COMMON.SCCOR'
8830       include 'COMMON.INTERACT'
8831       include 'COMMON.DERIV'
8832       include 'COMMON.CHAIN'
8833       include 'COMMON.NAMES'
8834       include 'COMMON.IOUNITS'
8835       include 'COMMON.FFIELD'
8836       include 'COMMON.CONTROL'
8837       logical lprn
8838 C Set lprn=.true. for debugging
8839       lprn=.false.
8840 c      lprn=.true.
8841 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8842       esccor=0.0D0
8843       do i=itau_start,itau_end
8844         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8845         esccor_ii=0.0D0
8846         isccori=isccortyp(itype(i-2))
8847         isccori1=isccortyp(itype(i-1))
8848 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8849         phii=phi(i)
8850         do intertyp=1,3 !intertyp
8851 cc Added 09 May 2012 (Adasko)
8852 cc  Intertyp means interaction type of backbone mainchain correlation:
8853 c   1 = SC...Ca...Ca...Ca
8854 c   2 = Ca...Ca...Ca...SC
8855 c   3 = SC...Ca...Ca...SCi
8856         gloci=0.0D0
8857         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8858      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8859      &      (itype(i-1).eq.ntyp1)))
8860      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8861      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8862      &     .or.(itype(i).eq.ntyp1)))
8863      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8864      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8865      &      (itype(i-3).eq.ntyp1)))) cycle
8866         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8867         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8868      & cycle
8869        do j=1,nterm_sccor(isccori,isccori1)
8870           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8871           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8872           cosphi=dcos(j*tauangle(intertyp,i))
8873           sinphi=dsin(j*tauangle(intertyp,i))
8874           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8875           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8876         enddo
8877 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8878         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8879         if (lprn)
8880      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8881      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8882      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8883      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8884         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8885        enddo !intertyp
8886       enddo
8887
8888       return
8889       end
8890 #ifdef FOURBODY
8891 c----------------------------------------------------------------------------
8892       subroutine multibody(ecorr)
8893 C This subroutine calculates multi-body contributions to energy following
8894 C the idea of Skolnick et al. If side chains I and J make a contact and
8895 C at the same time side chains I+1 and J+1 make a contact, an extra
8896 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8897       implicit real*8 (a-h,o-z)
8898       include 'DIMENSIONS'
8899       include 'COMMON.IOUNITS'
8900       include 'COMMON.DERIV'
8901       include 'COMMON.INTERACT'
8902       include 'COMMON.CONTACTS'
8903       include 'COMMON.CONTMAT'
8904       include 'COMMON.CORRMAT'
8905       double precision gx(3),gx1(3)
8906       logical lprn
8907
8908 C Set lprn=.true. for debugging
8909       lprn=.false.
8910
8911       if (lprn) then
8912         write (iout,'(a)') 'Contact function values:'
8913         do i=nnt,nct-2
8914           write (iout,'(i2,20(1x,i2,f10.5))')
8915      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8916         enddo
8917       endif
8918       ecorr=0.0D0
8919       do i=nnt,nct
8920         do j=1,3
8921           gradcorr(j,i)=0.0D0
8922           gradxorr(j,i)=0.0D0
8923         enddo
8924       enddo
8925       do i=nnt,nct-2
8926
8927         DO ISHIFT = 3,4
8928
8929         i1=i+ishift
8930         num_conti=num_cont(i)
8931         num_conti1=num_cont(i1)
8932         do jj=1,num_conti
8933           j=jcont(jj,i)
8934           do kk=1,num_conti1
8935             j1=jcont(kk,i1)
8936             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8937 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8938 cd   &                   ' ishift=',ishift
8939 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8940 C The system gains extra energy.
8941               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8942             endif   ! j1==j+-ishift
8943           enddo     ! kk
8944         enddo       ! jj
8945
8946         ENDDO ! ISHIFT
8947
8948       enddo         ! i
8949       return
8950       end
8951 c------------------------------------------------------------------------------
8952       double precision function esccorr(i,j,k,l,jj,kk)
8953       implicit real*8 (a-h,o-z)
8954       include 'DIMENSIONS'
8955       include 'COMMON.IOUNITS'
8956       include 'COMMON.DERIV'
8957       include 'COMMON.INTERACT'
8958       include 'COMMON.CONTACTS'
8959       include 'COMMON.CONTMAT'
8960       include 'COMMON.CORRMAT'
8961       include 'COMMON.SHIELD'
8962       double precision gx(3),gx1(3)
8963       logical lprn
8964       lprn=.false.
8965       eij=facont(jj,i)
8966       ekl=facont(kk,k)
8967 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8968 C Calculate the multi-body contribution to energy.
8969 C Calculate multi-body contributions to the gradient.
8970 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8971 cd   & k,l,(gacont(m,kk,k),m=1,3)
8972       do m=1,3
8973         gx(m) =ekl*gacont(m,jj,i)
8974         gx1(m)=eij*gacont(m,kk,k)
8975         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8976         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8977         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8978         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8979       enddo
8980       do m=i,j-1
8981         do ll=1,3
8982           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8983         enddo
8984       enddo
8985       do m=k,l-1
8986         do ll=1,3
8987           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8988         enddo
8989       enddo
8990       esccorr=-eij*ekl
8991       return
8992       end
8993 c------------------------------------------------------------------------------
8994       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8995 C This subroutine calculates multi-body contributions to hydrogen-bonding
8996       implicit real*8 (a-h,o-z)
8997       include 'DIMENSIONS'
8998       include 'COMMON.IOUNITS'
8999 #ifdef MPI
9000       include "mpif.h"
9001       parameter (max_cont=maxconts)
9002       parameter (max_dim=26)
9003       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9004       double precision zapas(max_dim,maxconts,max_fg_procs),
9005      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9006       common /przechowalnia/ zapas
9007       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9008      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9009 #endif
9010       include 'COMMON.SETUP'
9011       include 'COMMON.FFIELD'
9012       include 'COMMON.DERIV'
9013       include 'COMMON.INTERACT'
9014       include 'COMMON.CONTACTS'
9015       include 'COMMON.CONTMAT'
9016       include 'COMMON.CORRMAT'
9017       include 'COMMON.CONTROL'
9018       include 'COMMON.LOCAL'
9019       double precision gx(3),gx1(3),time00
9020       logical lprn,ldone
9021
9022 C Set lprn=.true. for debugging
9023       lprn=.false.
9024 #ifdef MPI
9025       n_corr=0
9026       n_corr1=0
9027       if (nfgtasks.le.1) goto 30
9028       if (lprn) then
9029         write (iout,'(a)') 'Contact function values before RECEIVE:'
9030         do i=nnt,nct-2
9031           write (iout,'(2i3,50(1x,i2,f5.2))')
9032      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9033      &    j=1,num_cont_hb(i))
9034         enddo
9035         call flush(iout)
9036       endif
9037       do i=1,ntask_cont_from
9038         ncont_recv(i)=0
9039       enddo
9040       do i=1,ntask_cont_to
9041         ncont_sent(i)=0
9042       enddo
9043 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9044 c     & ntask_cont_to
9045 C Make the list of contacts to send to send to other procesors
9046 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
9047 c      call flush(iout)
9048       do i=iturn3_start,iturn3_end
9049 c        write (iout,*) "make contact list turn3",i," num_cont",
9050 c     &    num_cont_hb(i)
9051         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
9052       enddo
9053       do i=iturn4_start,iturn4_end
9054 c        write (iout,*) "make contact list turn4",i," num_cont",
9055 c     &   num_cont_hb(i)
9056         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
9057       enddo
9058       do ii=1,nat_sent
9059         i=iat_sent(ii)
9060 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9061 c     &    num_cont_hb(i)
9062         do j=1,num_cont_hb(i)
9063         do k=1,4
9064           jjc=jcont_hb(j,i)
9065           iproc=iint_sent_local(k,jjc,ii)
9066 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9067           if (iproc.gt.0) then
9068             ncont_sent(iproc)=ncont_sent(iproc)+1
9069             nn=ncont_sent(iproc)
9070             zapas(1,nn,iproc)=i
9071             zapas(2,nn,iproc)=jjc
9072             zapas(3,nn,iproc)=facont_hb(j,i)
9073             zapas(4,nn,iproc)=ees0p(j,i)
9074             zapas(5,nn,iproc)=ees0m(j,i)
9075             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
9076             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
9077             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
9078             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
9079             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
9080             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
9081             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
9082             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
9083             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
9084             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
9085             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
9086             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
9087             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
9088             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
9089             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
9090             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
9091             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
9092             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
9093             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
9094             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
9095             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
9096           endif
9097         enddo
9098         enddo
9099       enddo
9100       if (lprn) then
9101       write (iout,*)
9102      &  "Numbers of contacts to be sent to other processors",
9103      &  (ncont_sent(i),i=1,ntask_cont_to)
9104       write (iout,*) "Contacts sent"
9105       do ii=1,ntask_cont_to
9106         nn=ncont_sent(ii)
9107         iproc=itask_cont_to(ii)
9108         write (iout,*) nn," contacts to processor",iproc,
9109      &   " of CONT_TO_COMM group"
9110         do i=1,nn
9111           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9112         enddo
9113       enddo
9114       call flush(iout)
9115       endif
9116       CorrelType=477
9117       CorrelID=fg_rank+1
9118       CorrelType1=478
9119       CorrelID1=nfgtasks+fg_rank+1
9120       ireq=0
9121 C Receive the numbers of needed contacts from other processors
9122       do ii=1,ntask_cont_from
9123         iproc=itask_cont_from(ii)
9124         ireq=ireq+1
9125         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9126      &    FG_COMM,req(ireq),IERR)
9127       enddo
9128 c      write (iout,*) "IRECV ended"
9129 c      call flush(iout)
9130 C Send the number of contacts needed by other processors
9131       do ii=1,ntask_cont_to
9132         iproc=itask_cont_to(ii)
9133         ireq=ireq+1
9134         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9135      &    FG_COMM,req(ireq),IERR)
9136       enddo
9137 c      write (iout,*) "ISEND ended"
9138 c      write (iout,*) "number of requests (nn)",ireq
9139 c      call flush(iout)
9140       if (ireq.gt.0)
9141      &  call MPI_Waitall(ireq,req,status_array,ierr)
9142 c      write (iout,*)
9143 c     &  "Numbers of contacts to be received from other processors",
9144 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9145 c      call flush(iout)
9146 C Receive contacts
9147       ireq=0
9148       do ii=1,ntask_cont_from
9149         iproc=itask_cont_from(ii)
9150         nn=ncont_recv(ii)
9151 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9152 c     &   " of CONT_TO_COMM group"
9153 c        call flush(iout)
9154         if (nn.gt.0) then
9155           ireq=ireq+1
9156           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9157      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9158 c          write (iout,*) "ireq,req",ireq,req(ireq)
9159         endif
9160       enddo
9161 C Send the contacts to processors that need them
9162       do ii=1,ntask_cont_to
9163         iproc=itask_cont_to(ii)
9164         nn=ncont_sent(ii)
9165 c        write (iout,*) nn," contacts to processor",iproc,
9166 c     &   " of CONT_TO_COMM group"
9167         if (nn.gt.0) then
9168           ireq=ireq+1
9169           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9170      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9171 c          write (iout,*) "ireq,req",ireq,req(ireq)
9172 c          do i=1,nn
9173 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9174 c          enddo
9175         endif
9176       enddo
9177 c      write (iout,*) "number of requests (contacts)",ireq
9178 c      write (iout,*) "req",(req(i),i=1,4)
9179 c      call flush(iout)
9180       if (ireq.gt.0)
9181      & call MPI_Waitall(ireq,req,status_array,ierr)
9182       do iii=1,ntask_cont_from
9183         iproc=itask_cont_from(iii)
9184         nn=ncont_recv(iii)
9185         if (lprn) then
9186         write (iout,*) "Received",nn," contacts from processor",iproc,
9187      &   " of CONT_FROM_COMM group"
9188         call flush(iout)
9189         do i=1,nn
9190           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9191         enddo
9192         call flush(iout)
9193         endif
9194         do i=1,nn
9195           ii=zapas_recv(1,i,iii)
9196 c Flag the received contacts to prevent double-counting
9197           jj=-zapas_recv(2,i,iii)
9198 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9199 c          call flush(iout)
9200           nnn=num_cont_hb(ii)+1
9201           num_cont_hb(ii)=nnn
9202           jcont_hb(nnn,ii)=jj
9203           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9204           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9205           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9206           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9207           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9208           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9209           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9210           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9211           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9212           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9213           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9214           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9215           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9216           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9217           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9218           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9219           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9220           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9221           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9222           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9223           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9224           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9225           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9226           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9227         enddo
9228       enddo
9229       if (lprn) then
9230         write (iout,'(a)') 'Contact function values after receive:'
9231         do i=nnt,nct-2
9232           write (iout,'(2i3,50(1x,i3,f5.2))')
9233      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9234      &    j=1,num_cont_hb(i))
9235         enddo
9236         call flush(iout)
9237       endif
9238    30 continue
9239 #endif
9240       if (lprn) then
9241         write (iout,'(a)') 'Contact function values:'
9242         do i=nnt,nct-2
9243           write (iout,'(2i3,50(1x,i3,f5.2))')
9244      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9245      &    j=1,num_cont_hb(i))
9246         enddo
9247         call flush(iout)
9248       endif
9249       ecorr=0.0D0
9250 C Remove the loop below after debugging !!!
9251       do i=nnt,nct
9252         do j=1,3
9253           gradcorr(j,i)=0.0D0
9254           gradxorr(j,i)=0.0D0
9255         enddo
9256       enddo
9257 C Calculate the local-electrostatic correlation terms
9258       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9259         i1=i+1
9260         num_conti=num_cont_hb(i)
9261         num_conti1=num_cont_hb(i+1)
9262         do jj=1,num_conti
9263           j=jcont_hb(jj,i)
9264           jp=iabs(j)
9265           do kk=1,num_conti1
9266             j1=jcont_hb(kk,i1)
9267             jp1=iabs(j1)
9268 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9269 c     &         ' jj=',jj,' kk=',kk
9270 c            call flush(iout)
9271             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9272      &          .or. j.lt.0 .and. j1.gt.0) .and.
9273      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9274 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9275 C The system gains extra energy.
9276               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9277               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9278      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9279               n_corr=n_corr+1
9280             else if (j1.eq.j) then
9281 C Contacts I-J and I-(J+1) occur simultaneously.
9282 C The system loses extra energy.
9283 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9284             endif
9285           enddo ! kk
9286           do kk=1,num_conti
9287             j1=jcont_hb(kk,i)
9288 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9289 c    &         ' jj=',jj,' kk=',kk
9290             if (j1.eq.j+1) then
9291 C Contacts I-J and (I+1)-J occur simultaneously.
9292 C The system loses extra energy.
9293 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9294             endif ! j1==j+1
9295           enddo ! kk
9296         enddo ! jj
9297       enddo ! i
9298       return
9299       end
9300 c------------------------------------------------------------------------------
9301       subroutine add_hb_contact(ii,jj,itask)
9302       implicit real*8 (a-h,o-z)
9303       include "DIMENSIONS"
9304       include "COMMON.IOUNITS"
9305       integer max_cont
9306       integer max_dim
9307       parameter (max_cont=maxconts)
9308       parameter (max_dim=26)
9309       include "COMMON.CONTACTS"
9310       include 'COMMON.CONTMAT'
9311       include 'COMMON.CORRMAT'
9312       double precision zapas(max_dim,maxconts,max_fg_procs),
9313      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9314       common /przechowalnia/ zapas
9315       integer i,j,ii,jj,iproc,itask(4),nn
9316 c      write (iout,*) "itask",itask
9317       do i=1,2
9318         iproc=itask(i)
9319         if (iproc.gt.0) then
9320           do j=1,num_cont_hb(ii)
9321             jjc=jcont_hb(j,ii)
9322 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9323             if (jjc.eq.jj) then
9324               ncont_sent(iproc)=ncont_sent(iproc)+1
9325               nn=ncont_sent(iproc)
9326               zapas(1,nn,iproc)=ii
9327               zapas(2,nn,iproc)=jjc
9328               zapas(3,nn,iproc)=facont_hb(j,ii)
9329               zapas(4,nn,iproc)=ees0p(j,ii)
9330               zapas(5,nn,iproc)=ees0m(j,ii)
9331               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9332               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9333               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9334               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9335               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9336               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9337               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9338               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9339               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9340               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9341               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9342               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9343               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9344               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9345               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9346               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9347               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9348               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9349               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9350               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9351               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9352               exit
9353             endif
9354           enddo
9355         endif
9356       enddo
9357       return
9358       end
9359 c------------------------------------------------------------------------------
9360       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9361      &  n_corr1)
9362 C This subroutine calculates multi-body contributions to hydrogen-bonding
9363       implicit real*8 (a-h,o-z)
9364       include 'DIMENSIONS'
9365       include 'COMMON.IOUNITS'
9366 #ifdef MPI
9367       include "mpif.h"
9368       parameter (max_cont=maxconts)
9369       parameter (max_dim=70)
9370       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9371       double precision zapas(max_dim,maxconts,max_fg_procs),
9372      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9373       common /przechowalnia/ zapas
9374       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9375      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9376 #endif
9377       include 'COMMON.SETUP'
9378       include 'COMMON.FFIELD'
9379       include 'COMMON.DERIV'
9380       include 'COMMON.LOCAL'
9381       include 'COMMON.INTERACT'
9382       include 'COMMON.CONTACTS'
9383       include 'COMMON.CONTMAT'
9384       include 'COMMON.CORRMAT'
9385       include 'COMMON.CHAIN'
9386       include 'COMMON.CONTROL'
9387       include 'COMMON.SHIELD'
9388       double precision gx(3),gx1(3)
9389       integer num_cont_hb_old(maxres)
9390       logical lprn,ldone
9391       double precision eello4,eello5,eelo6,eello_turn6
9392       external eello4,eello5,eello6,eello_turn6
9393 C Set lprn=.true. for debugging
9394       lprn=.false.
9395       eturn6=0.0d0
9396 #ifdef MPI
9397       do i=1,nres
9398         num_cont_hb_old(i)=num_cont_hb(i)
9399       enddo
9400       n_corr=0
9401       n_corr1=0
9402       if (nfgtasks.le.1) goto 30
9403       if (lprn) then
9404         write (iout,'(a)') 'Contact function values before RECEIVE:'
9405         do i=nnt,nct-2
9406           write (iout,'(2i3,50(1x,i2,f5.2))')
9407      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9408      &    j=1,num_cont_hb(i))
9409         enddo
9410       endif
9411       do i=1,ntask_cont_from
9412         ncont_recv(i)=0
9413       enddo
9414       do i=1,ntask_cont_to
9415         ncont_sent(i)=0
9416       enddo
9417 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9418 c     & ntask_cont_to
9419 C Make the list of contacts to send to send to other procesors
9420       do i=iturn3_start,iturn3_end
9421 c        write (iout,*) "make contact list turn3",i," num_cont",
9422 c     &    num_cont_hb(i)
9423         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9424       enddo
9425       do i=iturn4_start,iturn4_end
9426 c        write (iout,*) "make contact list turn4",i," num_cont",
9427 c     &   num_cont_hb(i)
9428         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9429       enddo
9430       do ii=1,nat_sent
9431         i=iat_sent(ii)
9432 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9433 c     &    num_cont_hb(i)
9434         do j=1,num_cont_hb(i)
9435         do k=1,4
9436           jjc=jcont_hb(j,i)
9437           iproc=iint_sent_local(k,jjc,ii)
9438 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9439           if (iproc.ne.0) then
9440             ncont_sent(iproc)=ncont_sent(iproc)+1
9441             nn=ncont_sent(iproc)
9442             zapas(1,nn,iproc)=i
9443             zapas(2,nn,iproc)=jjc
9444             zapas(3,nn,iproc)=d_cont(j,i)
9445             ind=3
9446             do kk=1,3
9447               ind=ind+1
9448               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9449             enddo
9450             do kk=1,2
9451               do ll=1,2
9452                 ind=ind+1
9453                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9454               enddo
9455             enddo
9456             do jj=1,5
9457               do kk=1,3
9458                 do ll=1,2
9459                   do mm=1,2
9460                     ind=ind+1
9461                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9462                   enddo
9463                 enddo
9464               enddo
9465             enddo
9466           endif
9467         enddo
9468         enddo
9469       enddo
9470       if (lprn) then
9471       write (iout,*)
9472      &  "Numbers of contacts to be sent to other processors",
9473      &  (ncont_sent(i),i=1,ntask_cont_to)
9474       write (iout,*) "Contacts sent"
9475       do ii=1,ntask_cont_to
9476         nn=ncont_sent(ii)
9477         iproc=itask_cont_to(ii)
9478         write (iout,*) nn," contacts to processor",iproc,
9479      &   " of CONT_TO_COMM group"
9480         do i=1,nn
9481           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9482         enddo
9483       enddo
9484       call flush(iout)
9485       endif
9486       CorrelType=477
9487       CorrelID=fg_rank+1
9488       CorrelType1=478
9489       CorrelID1=nfgtasks+fg_rank+1
9490       ireq=0
9491 C Receive the numbers of needed contacts from other processors
9492       do ii=1,ntask_cont_from
9493         iproc=itask_cont_from(ii)
9494         ireq=ireq+1
9495         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9496      &    FG_COMM,req(ireq),IERR)
9497       enddo
9498 c      write (iout,*) "IRECV ended"
9499 c      call flush(iout)
9500 C Send the number of contacts needed by other processors
9501       do ii=1,ntask_cont_to
9502         iproc=itask_cont_to(ii)
9503         ireq=ireq+1
9504         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9505      &    FG_COMM,req(ireq),IERR)
9506       enddo
9507 c      write (iout,*) "ISEND ended"
9508 c      write (iout,*) "number of requests (nn)",ireq
9509 c      call flush(iout)
9510       if (ireq.gt.0)
9511      &  call MPI_Waitall(ireq,req,status_array,ierr)
9512 c      write (iout,*)
9513 c     &  "Numbers of contacts to be received from other processors",
9514 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9515 c      call flush(iout)
9516 C Receive contacts
9517       ireq=0
9518       do ii=1,ntask_cont_from
9519         iproc=itask_cont_from(ii)
9520         nn=ncont_recv(ii)
9521 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9522 c     &   " of CONT_TO_COMM group"
9523 c        call flush(iout)
9524         if (nn.gt.0) then
9525           ireq=ireq+1
9526           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9527      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9528 c          write (iout,*) "ireq,req",ireq,req(ireq)
9529         endif
9530       enddo
9531 C Send the contacts to processors that need them
9532       do ii=1,ntask_cont_to
9533         iproc=itask_cont_to(ii)
9534         nn=ncont_sent(ii)
9535 c        write (iout,*) nn," contacts to processor",iproc,
9536 c     &   " of CONT_TO_COMM group"
9537         if (nn.gt.0) then
9538           ireq=ireq+1
9539           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9540      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9541 c          write (iout,*) "ireq,req",ireq,req(ireq)
9542 c          do i=1,nn
9543 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9544 c          enddo
9545         endif
9546       enddo
9547 c      write (iout,*) "number of requests (contacts)",ireq
9548 c      write (iout,*) "req",(req(i),i=1,4)
9549 c      call flush(iout)
9550       if (ireq.gt.0)
9551      & call MPI_Waitall(ireq,req,status_array,ierr)
9552       do iii=1,ntask_cont_from
9553         iproc=itask_cont_from(iii)
9554         nn=ncont_recv(iii)
9555         if (lprn) then
9556         write (iout,*) "Received",nn," contacts from processor",iproc,
9557      &   " of CONT_FROM_COMM group"
9558         call flush(iout)
9559         do i=1,nn
9560           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9561         enddo
9562         call flush(iout)
9563         endif
9564         do i=1,nn
9565           ii=zapas_recv(1,i,iii)
9566 c Flag the received contacts to prevent double-counting
9567           jj=-zapas_recv(2,i,iii)
9568 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9569 c          call flush(iout)
9570           nnn=num_cont_hb(ii)+1
9571           num_cont_hb(ii)=nnn
9572           jcont_hb(nnn,ii)=jj
9573           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9574           ind=3
9575           do kk=1,3
9576             ind=ind+1
9577             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9578           enddo
9579           do kk=1,2
9580             do ll=1,2
9581               ind=ind+1
9582               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9583             enddo
9584           enddo
9585           do jj=1,5
9586             do kk=1,3
9587               do ll=1,2
9588                 do mm=1,2
9589                   ind=ind+1
9590                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9591                 enddo
9592               enddo
9593             enddo
9594           enddo
9595         enddo
9596       enddo
9597       if (lprn) then
9598         write (iout,'(a)') 'Contact function values after receive:'
9599         do i=nnt,nct-2
9600           write (iout,'(2i3,50(1x,i3,5f6.3))')
9601      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9602      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9603         enddo
9604         call flush(iout)
9605       endif
9606    30 continue
9607 #endif
9608       if (lprn) then
9609         write (iout,'(a)') 'Contact function values:'
9610         do i=nnt,nct-2
9611           write (iout,'(2i3,50(1x,i2,5f6.3))')
9612      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9613      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9614         enddo
9615       endif
9616       ecorr=0.0D0
9617       ecorr5=0.0d0
9618       ecorr6=0.0d0
9619 C Remove the loop below after debugging !!!
9620       do i=nnt,nct
9621         do j=1,3
9622           gradcorr(j,i)=0.0D0
9623           gradxorr(j,i)=0.0D0
9624         enddo
9625       enddo
9626 C Calculate the dipole-dipole interaction energies
9627       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9628       do i=iatel_s,iatel_e+1
9629         num_conti=num_cont_hb(i)
9630         do jj=1,num_conti
9631           j=jcont_hb(jj,i)
9632 #ifdef MOMENT
9633           call dipole(i,j,jj)
9634 #endif
9635         enddo
9636       enddo
9637       endif
9638 C Calculate the local-electrostatic correlation terms
9639 c                write (iout,*) "gradcorr5 in eello5 before loop"
9640 c                do iii=1,nres
9641 c                  write (iout,'(i5,3f10.5)')
9642 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9643 c                enddo
9644       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9645 c        write (iout,*) "corr loop i",i
9646         i1=i+1
9647         num_conti=num_cont_hb(i)
9648         num_conti1=num_cont_hb(i+1)
9649         do jj=1,num_conti
9650           j=jcont_hb(jj,i)
9651           jp=iabs(j)
9652           do kk=1,num_conti1
9653             j1=jcont_hb(kk,i1)
9654             jp1=iabs(j1)
9655 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9656 c     &         ' jj=',jj,' kk=',kk
9657 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9658             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9659      &          .or. j.lt.0 .and. j1.gt.0) .and.
9660      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9661 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9662 C The system gains extra energy.
9663               n_corr=n_corr+1
9664               sqd1=dsqrt(d_cont(jj,i))
9665               sqd2=dsqrt(d_cont(kk,i1))
9666               sred_geom = sqd1*sqd2
9667               IF (sred_geom.lt.cutoff_corr) THEN
9668                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9669      &            ekont,fprimcont)
9670 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9671 cd     &         ' jj=',jj,' kk=',kk
9672                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9673                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9674                 do l=1,3
9675                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9676                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9677                 enddo
9678                 n_corr1=n_corr1+1
9679 cd               write (iout,*) 'sred_geom=',sred_geom,
9680 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9681 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9682 cd               write (iout,*) "g_contij",g_contij
9683 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9684 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9685                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9686                 if (wcorr4.gt.0.0d0)
9687      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9688 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9689                   if (energy_dec.and.wcorr4.gt.0.0d0)
9690      1                 write (iout,'(a6,4i5,0pf7.3)')
9691      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9692 c                write (iout,*) "gradcorr5 before eello5"
9693 c                do iii=1,nres
9694 c                  write (iout,'(i5,3f10.5)')
9695 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9696 c                enddo
9697                 if (wcorr5.gt.0.0d0)
9698      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9699 c                write (iout,*) "gradcorr5 after eello5"
9700 c                do iii=1,nres
9701 c                  write (iout,'(i5,3f10.5)')
9702 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9703 c                enddo
9704                   if (energy_dec.and.wcorr5.gt.0.0d0)
9705      1                 write (iout,'(a6,4i5,0pf7.3)')
9706      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9707 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9708 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9709                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9710      &               .or. wturn6.eq.0.0d0))then
9711 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9712                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9713                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9714      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9715 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9716 cd     &            'ecorr6=',ecorr6
9717 cd                write (iout,'(4e15.5)') sred_geom,
9718 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9719 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9720 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9721                 else if (wturn6.gt.0.0d0
9722      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9723 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9724                   eturn6=eturn6+eello_turn6(i,jj,kk)
9725                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9726      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9727 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9728                 endif
9729               ENDIF
9730 1111          continue
9731             endif
9732           enddo ! kk
9733         enddo ! jj
9734       enddo ! i
9735       do i=1,nres
9736         num_cont_hb(i)=num_cont_hb_old(i)
9737       enddo
9738 c                write (iout,*) "gradcorr5 in eello5"
9739 c                do iii=1,nres
9740 c                  write (iout,'(i5,3f10.5)')
9741 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9742 c                enddo
9743       return
9744       end
9745 c------------------------------------------------------------------------------
9746       subroutine add_hb_contact_eello(ii,jj,itask)
9747       implicit real*8 (a-h,o-z)
9748       include "DIMENSIONS"
9749       include "COMMON.IOUNITS"
9750       integer max_cont
9751       integer max_dim
9752       parameter (max_cont=maxconts)
9753       parameter (max_dim=70)
9754       include "COMMON.CONTACTS"
9755       include 'COMMON.CONTMAT'
9756       include 'COMMON.CORRMAT'
9757       double precision zapas(max_dim,maxconts,max_fg_procs),
9758      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9759       common /przechowalnia/ zapas
9760       integer i,j,ii,jj,iproc,itask(4),nn
9761 c      write (iout,*) "itask",itask
9762       do i=1,2
9763         iproc=itask(i)
9764         if (iproc.gt.0) then
9765           do j=1,num_cont_hb(ii)
9766             jjc=jcont_hb(j,ii)
9767 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9768             if (jjc.eq.jj) then
9769               ncont_sent(iproc)=ncont_sent(iproc)+1
9770               nn=ncont_sent(iproc)
9771               zapas(1,nn,iproc)=ii
9772               zapas(2,nn,iproc)=jjc
9773               zapas(3,nn,iproc)=d_cont(j,ii)
9774               ind=3
9775               do kk=1,3
9776                 ind=ind+1
9777                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9778               enddo
9779               do kk=1,2
9780                 do ll=1,2
9781                   ind=ind+1
9782                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9783                 enddo
9784               enddo
9785               do jj=1,5
9786                 do kk=1,3
9787                   do ll=1,2
9788                     do mm=1,2
9789                       ind=ind+1
9790                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9791                     enddo
9792                   enddo
9793                 enddo
9794               enddo
9795               exit
9796             endif
9797           enddo
9798         endif
9799       enddo
9800       return
9801       end
9802 c------------------------------------------------------------------------------
9803       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9804       implicit real*8 (a-h,o-z)
9805       include 'DIMENSIONS'
9806       include 'COMMON.IOUNITS'
9807       include 'COMMON.DERIV'
9808       include 'COMMON.INTERACT'
9809       include 'COMMON.CONTACTS'
9810       include 'COMMON.CONTMAT'
9811       include 'COMMON.CORRMAT'
9812       include 'COMMON.SHIELD'
9813       include 'COMMON.CONTROL'
9814       double precision gx(3),gx1(3)
9815       logical lprn
9816       lprn=.false.
9817 C      print *,"wchodze",fac_shield(i),shield_mode
9818       eij=facont_hb(jj,i)
9819       ekl=facont_hb(kk,k)
9820       ees0pij=ees0p(jj,i)
9821       ees0pkl=ees0p(kk,k)
9822       ees0mij=ees0m(jj,i)
9823       ees0mkl=ees0m(kk,k)
9824       ekont=eij*ekl
9825       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9826 C*
9827 C     & fac_shield(i)**2*fac_shield(j)**2
9828 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9829 C Following 4 lines for diagnostics.
9830 cd    ees0pkl=0.0D0
9831 cd    ees0pij=1.0D0
9832 cd    ees0mkl=0.0D0
9833 cd    ees0mij=1.0D0
9834 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9835 c     & 'Contacts ',i,j,
9836 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9837 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9838 c     & 'gradcorr_long'
9839 C Calculate the multi-body contribution to energy.
9840 C      ecorr=ecorr+ekont*ees
9841 C Calculate multi-body contributions to the gradient.
9842       coeffpees0pij=coeffp*ees0pij
9843       coeffmees0mij=coeffm*ees0mij
9844       coeffpees0pkl=coeffp*ees0pkl
9845       coeffmees0mkl=coeffm*ees0mkl
9846       do ll=1,3
9847 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9848         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9849      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9850      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9851         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9852      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9853      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9854 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9855         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9856      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9857      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9858         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9859      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9860      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9861         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9862      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9863      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9864         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9865         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9866         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9867      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9868      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9869         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9870         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9871 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9872       enddo
9873 c      write (iout,*)
9874 cgrad      do m=i+1,j-1
9875 cgrad        do ll=1,3
9876 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9877 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9878 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9879 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9880 cgrad        enddo
9881 cgrad      enddo
9882 cgrad      do m=k+1,l-1
9883 cgrad        do ll=1,3
9884 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9885 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9886 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9887 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9888 cgrad        enddo
9889 cgrad      enddo
9890 c      write (iout,*) "ehbcorr",ekont*ees
9891 C      print *,ekont,ees,i,k
9892       ehbcorr=ekont*ees
9893 C now gradient over shielding
9894 C      return
9895       if (shield_mode.gt.0) then
9896        j=ees0plist(jj,i)
9897        l=ees0plist(kk,k)
9898 C        print *,i,j,fac_shield(i),fac_shield(j),
9899 C     &fac_shield(k),fac_shield(l)
9900         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9901      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9902           do ilist=1,ishield_list(i)
9903            iresshield=shield_list(ilist,i)
9904            do m=1,3
9905            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9906 C     &      *2.0
9907            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9908      &              rlocshield
9909      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9910             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9911      &+rlocshield
9912            enddo
9913           enddo
9914           do ilist=1,ishield_list(j)
9915            iresshield=shield_list(ilist,j)
9916            do m=1,3
9917            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9918 C     &     *2.0
9919            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9920      &              rlocshield
9921      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9922            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9923      &     +rlocshield
9924            enddo
9925           enddo
9926
9927           do ilist=1,ishield_list(k)
9928            iresshield=shield_list(ilist,k)
9929            do m=1,3
9930            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9931 C     &     *2.0
9932            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9933      &              rlocshield
9934      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9935            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9936      &     +rlocshield
9937            enddo
9938           enddo
9939           do ilist=1,ishield_list(l)
9940            iresshield=shield_list(ilist,l)
9941            do m=1,3
9942            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9943 C     &     *2.0
9944            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9945      &              rlocshield
9946      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9947            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9948      &     +rlocshield
9949            enddo
9950           enddo
9951 C          print *,gshieldx(m,iresshield)
9952           do m=1,3
9953             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9954      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9955             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9956      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9957             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9958      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9959             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9960      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9961
9962             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9963      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9964             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9965      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9966             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9967      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9968             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9969      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9970
9971            enddo
9972       endif
9973       endif
9974       return
9975       end
9976 #ifdef MOMENT
9977 C---------------------------------------------------------------------------
9978       subroutine dipole(i,j,jj)
9979       implicit real*8 (a-h,o-z)
9980       include 'DIMENSIONS'
9981       include 'COMMON.IOUNITS'
9982       include 'COMMON.CHAIN'
9983       include 'COMMON.FFIELD'
9984       include 'COMMON.DERIV'
9985       include 'COMMON.INTERACT'
9986       include 'COMMON.CONTACTS'
9987       include 'COMMON.CONTMAT'
9988       include 'COMMON.CORRMAT'
9989       include 'COMMON.TORSION'
9990       include 'COMMON.VAR'
9991       include 'COMMON.GEO'
9992       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9993      &  auxmat(2,2)
9994       iti1 = itortyp(itype(i+1))
9995       if (j.lt.nres-1) then
9996         itj1 = itype2loc(itype(j+1))
9997       else
9998         itj1=nloctyp
9999       endif
10000       do iii=1,2
10001         dipi(iii,1)=Ub2(iii,i)
10002         dipderi(iii)=Ub2der(iii,i)
10003         dipi(iii,2)=b1(iii,i+1)
10004         dipj(iii,1)=Ub2(iii,j)
10005         dipderj(iii)=Ub2der(iii,j)
10006         dipj(iii,2)=b1(iii,j+1)
10007       enddo
10008       kkk=0
10009       do iii=1,2
10010         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
10011         do jjj=1,2
10012           kkk=kkk+1
10013           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
10014         enddo
10015       enddo
10016       do kkk=1,5
10017         do lll=1,3
10018           mmm=0
10019           do iii=1,2
10020             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
10021      &        auxvec(1))
10022             do jjj=1,2
10023               mmm=mmm+1
10024               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
10025             enddo
10026           enddo
10027         enddo
10028       enddo
10029       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
10030       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
10031       do iii=1,2
10032         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
10033       enddo
10034       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
10035       do iii=1,2
10036         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
10037       enddo
10038       return
10039       end
10040 #endif
10041 C---------------------------------------------------------------------------
10042       subroutine calc_eello(i,j,k,l,jj,kk)
10043 C
10044 C This subroutine computes matrices and vectors needed to calculate
10045 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
10046 C
10047       implicit real*8 (a-h,o-z)
10048       include 'DIMENSIONS'
10049       include 'COMMON.IOUNITS'
10050       include 'COMMON.CHAIN'
10051       include 'COMMON.DERIV'
10052       include 'COMMON.INTERACT'
10053       include 'COMMON.CONTACTS'
10054       include 'COMMON.CONTMAT'
10055       include 'COMMON.CORRMAT'
10056       include 'COMMON.TORSION'
10057       include 'COMMON.VAR'
10058       include 'COMMON.GEO'
10059       include 'COMMON.FFIELD'
10060       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
10061      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
10062       logical lprn
10063       common /kutas/ lprn
10064 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
10065 cd     & ' jj=',jj,' kk=',kk
10066 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
10067 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
10068 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
10069       do iii=1,2
10070         do jjj=1,2
10071           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
10072           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
10073         enddo
10074       enddo
10075       call transpose2(aa1(1,1),aa1t(1,1))
10076       call transpose2(aa2(1,1),aa2t(1,1))
10077       do kkk=1,5
10078         do lll=1,3
10079           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
10080      &      aa1tder(1,1,lll,kkk))
10081           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
10082      &      aa2tder(1,1,lll,kkk))
10083         enddo
10084       enddo
10085       if (l.eq.j+1) then
10086 C parallel orientation of the two CA-CA-CA frames.
10087         if (i.gt.1) then
10088           iti=itype2loc(itype(i))
10089         else
10090           iti=nloctyp
10091         endif
10092         itk1=itype2loc(itype(k+1))
10093         itj=itype2loc(itype(j))
10094         if (l.lt.nres-1) then
10095           itl1=itype2loc(itype(l+1))
10096         else
10097           itl1=nloctyp
10098         endif
10099 C A1 kernel(j+1) A2T
10100 cd        do iii=1,2
10101 cd          write (iout,'(3f10.5,5x,3f10.5)')
10102 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10103 cd        enddo
10104         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10105      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10106      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10107 C Following matrices are needed only for 6-th order cumulants
10108         IF (wcorr6.gt.0.0d0) THEN
10109         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10110      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10111      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10112         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10113      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10114      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10115      &   ADtEAderx(1,1,1,1,1,1))
10116         lprn=.false.
10117         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10118      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10119      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10120      &   ADtEA1derx(1,1,1,1,1,1))
10121         ENDIF
10122 C End 6-th order cumulants
10123 cd        lprn=.false.
10124 cd        if (lprn) then
10125 cd        write (2,*) 'In calc_eello6'
10126 cd        do iii=1,2
10127 cd          write (2,*) 'iii=',iii
10128 cd          do kkk=1,5
10129 cd            write (2,*) 'kkk=',kkk
10130 cd            do jjj=1,2
10131 cd              write (2,'(3(2f10.5),5x)')
10132 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10133 cd            enddo
10134 cd          enddo
10135 cd        enddo
10136 cd        endif
10137         call transpose2(EUgder(1,1,k),auxmat(1,1))
10138         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10139         call transpose2(EUg(1,1,k),auxmat(1,1))
10140         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10141         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10142 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10143 c    in theta; to be sriten later.
10144 c#ifdef NEWCORR
10145 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
10146 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10147 c        call transpose2(EUg(1,1,k),auxmat(1,1))
10148 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10149 c#endif
10150         do iii=1,2
10151           do kkk=1,5
10152             do lll=1,3
10153               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10154      &          EAEAderx(1,1,lll,kkk,iii,1))
10155             enddo
10156           enddo
10157         enddo
10158 C A1T kernel(i+1) A2
10159         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10160      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10161      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10162 C Following matrices are needed only for 6-th order cumulants
10163         IF (wcorr6.gt.0.0d0) THEN
10164         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10165      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10166      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10167         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10168      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10169      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10170      &   ADtEAderx(1,1,1,1,1,2))
10171         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10172      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10173      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10174      &   ADtEA1derx(1,1,1,1,1,2))
10175         ENDIF
10176 C End 6-th order cumulants
10177         call transpose2(EUgder(1,1,l),auxmat(1,1))
10178         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10179         call transpose2(EUg(1,1,l),auxmat(1,1))
10180         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10181         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10182         do iii=1,2
10183           do kkk=1,5
10184             do lll=1,3
10185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10186      &          EAEAderx(1,1,lll,kkk,iii,2))
10187             enddo
10188           enddo
10189         enddo
10190 C AEAb1 and AEAb2
10191 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10192 C They are needed only when the fifth- or the sixth-order cumulants are
10193 C indluded.
10194         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10195         call transpose2(AEA(1,1,1),auxmat(1,1))
10196         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10197         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10198         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10199         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10200         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10201         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10202         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10203         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10204         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10205         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10206         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10207         call transpose2(AEA(1,1,2),auxmat(1,1))
10208         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10209         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10210         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10211         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10212         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10213         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10214         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10215         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10216         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10217         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10218         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10219 C Calculate the Cartesian derivatives of the vectors.
10220         do iii=1,2
10221           do kkk=1,5
10222             do lll=1,3
10223               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10224               call matvec2(auxmat(1,1),b1(1,i),
10225      &          AEAb1derx(1,lll,kkk,iii,1,1))
10226               call matvec2(auxmat(1,1),Ub2(1,i),
10227      &          AEAb2derx(1,lll,kkk,iii,1,1))
10228               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10229      &          AEAb1derx(1,lll,kkk,iii,2,1))
10230               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10231      &          AEAb2derx(1,lll,kkk,iii,2,1))
10232               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10233               call matvec2(auxmat(1,1),b1(1,j),
10234      &          AEAb1derx(1,lll,kkk,iii,1,2))
10235               call matvec2(auxmat(1,1),Ub2(1,j),
10236      &          AEAb2derx(1,lll,kkk,iii,1,2))
10237               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10238      &          AEAb1derx(1,lll,kkk,iii,2,2))
10239               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10240      &          AEAb2derx(1,lll,kkk,iii,2,2))
10241             enddo
10242           enddo
10243         enddo
10244         ENDIF
10245 C End vectors
10246       else
10247 C Antiparallel orientation of the two CA-CA-CA frames.
10248         if (i.gt.1) then
10249           iti=itype2loc(itype(i))
10250         else
10251           iti=nloctyp
10252         endif
10253         itk1=itype2loc(itype(k+1))
10254         itl=itype2loc(itype(l))
10255         itj=itype2loc(itype(j))
10256         if (j.lt.nres-1) then
10257           itj1=itype2loc(itype(j+1))
10258         else
10259           itj1=nloctyp
10260         endif
10261 C A2 kernel(j-1)T A1T
10262         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10263      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10264      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10265 C Following matrices are needed only for 6-th order cumulants
10266         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10267      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10268         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10269      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10270      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10271         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10272      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10273      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10274      &   ADtEAderx(1,1,1,1,1,1))
10275         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10276      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10277      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10278      &   ADtEA1derx(1,1,1,1,1,1))
10279         ENDIF
10280 C End 6-th order cumulants
10281         call transpose2(EUgder(1,1,k),auxmat(1,1))
10282         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10283         call transpose2(EUg(1,1,k),auxmat(1,1))
10284         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10285         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10286         do iii=1,2
10287           do kkk=1,5
10288             do lll=1,3
10289               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10290      &          EAEAderx(1,1,lll,kkk,iii,1))
10291             enddo
10292           enddo
10293         enddo
10294 C A2T kernel(i+1)T A1
10295         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10296      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10297      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10298 C Following matrices are needed only for 6-th order cumulants
10299         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10300      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10301         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10302      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10303      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10304         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10305      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10306      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10307      &   ADtEAderx(1,1,1,1,1,2))
10308         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10309      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10310      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10311      &   ADtEA1derx(1,1,1,1,1,2))
10312         ENDIF
10313 C End 6-th order cumulants
10314         call transpose2(EUgder(1,1,j),auxmat(1,1))
10315         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10316         call transpose2(EUg(1,1,j),auxmat(1,1))
10317         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10318         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10319         do iii=1,2
10320           do kkk=1,5
10321             do lll=1,3
10322               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10323      &          EAEAderx(1,1,lll,kkk,iii,2))
10324             enddo
10325           enddo
10326         enddo
10327 C AEAb1 and AEAb2
10328 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10329 C They are needed only when the fifth- or the sixth-order cumulants are
10330 C indluded.
10331         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10332      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10333         call transpose2(AEA(1,1,1),auxmat(1,1))
10334         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10335         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10336         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10337         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10338         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10339         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10340         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10341         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10342         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10343         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10344         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10345         call transpose2(AEA(1,1,2),auxmat(1,1))
10346         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10347         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10348         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10349         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10350         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10351         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10352         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10353         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10354         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10355         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10356         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10357 C Calculate the Cartesian derivatives of the vectors.
10358         do iii=1,2
10359           do kkk=1,5
10360             do lll=1,3
10361               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10362               call matvec2(auxmat(1,1),b1(1,i),
10363      &          AEAb1derx(1,lll,kkk,iii,1,1))
10364               call matvec2(auxmat(1,1),Ub2(1,i),
10365      &          AEAb2derx(1,lll,kkk,iii,1,1))
10366               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10367      &          AEAb1derx(1,lll,kkk,iii,2,1))
10368               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10369      &          AEAb2derx(1,lll,kkk,iii,2,1))
10370               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10371               call matvec2(auxmat(1,1),b1(1,l),
10372      &          AEAb1derx(1,lll,kkk,iii,1,2))
10373               call matvec2(auxmat(1,1),Ub2(1,l),
10374      &          AEAb2derx(1,lll,kkk,iii,1,2))
10375               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10376      &          AEAb1derx(1,lll,kkk,iii,2,2))
10377               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10378      &          AEAb2derx(1,lll,kkk,iii,2,2))
10379             enddo
10380           enddo
10381         enddo
10382         ENDIF
10383 C End vectors
10384       endif
10385       return
10386       end
10387 C---------------------------------------------------------------------------
10388       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10389      &  KK,KKderg,AKA,AKAderg,AKAderx)
10390       implicit none
10391       integer nderg
10392       logical transp
10393       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10394      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10395      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10396       integer iii,kkk,lll
10397       integer jjj,mmm
10398       logical lprn
10399       common /kutas/ lprn
10400       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10401       do iii=1,nderg
10402         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10403      &    AKAderg(1,1,iii))
10404       enddo
10405 cd      if (lprn) write (2,*) 'In kernel'
10406       do kkk=1,5
10407 cd        if (lprn) write (2,*) 'kkk=',kkk
10408         do lll=1,3
10409           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10410      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10411 cd          if (lprn) then
10412 cd            write (2,*) 'lll=',lll
10413 cd            write (2,*) 'iii=1'
10414 cd            do jjj=1,2
10415 cd              write (2,'(3(2f10.5),5x)')
10416 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10417 cd            enddo
10418 cd          endif
10419           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10420      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10421 cd          if (lprn) then
10422 cd            write (2,*) 'lll=',lll
10423 cd            write (2,*) 'iii=2'
10424 cd            do jjj=1,2
10425 cd              write (2,'(3(2f10.5),5x)')
10426 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10427 cd            enddo
10428 cd          endif
10429         enddo
10430       enddo
10431       return
10432       end
10433 C---------------------------------------------------------------------------
10434       double precision function eello4(i,j,k,l,jj,kk)
10435       implicit real*8 (a-h,o-z)
10436       include 'DIMENSIONS'
10437       include 'COMMON.IOUNITS'
10438       include 'COMMON.CHAIN'
10439       include 'COMMON.DERIV'
10440       include 'COMMON.INTERACT'
10441       include 'COMMON.CONTACTS'
10442       include 'COMMON.CONTMAT'
10443       include 'COMMON.CORRMAT'
10444       include 'COMMON.TORSION'
10445       include 'COMMON.VAR'
10446       include 'COMMON.GEO'
10447       double precision pizda(2,2),ggg1(3),ggg2(3)
10448 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10449 cd        eello4=0.0d0
10450 cd        return
10451 cd      endif
10452 cd      print *,'eello4:',i,j,k,l,jj,kk
10453 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10454 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10455 cold      eij=facont_hb(jj,i)
10456 cold      ekl=facont_hb(kk,k)
10457 cold      ekont=eij*ekl
10458       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10459 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10460       gcorr_loc(k-1)=gcorr_loc(k-1)
10461      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10462       if (l.eq.j+1) then
10463         gcorr_loc(l-1)=gcorr_loc(l-1)
10464      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10465 C Al 4/16/16: Derivatives in theta, to be added later.
10466 c#ifdef NEWCORR
10467 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10468 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10469 c#endif
10470       else
10471         gcorr_loc(j-1)=gcorr_loc(j-1)
10472      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10473 c#ifdef NEWCORR
10474 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10475 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10476 c#endif
10477       endif
10478       do iii=1,2
10479         do kkk=1,5
10480           do lll=1,3
10481             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10482      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10483 cd            derx(lll,kkk,iii)=0.0d0
10484           enddo
10485         enddo
10486       enddo
10487 cd      gcorr_loc(l-1)=0.0d0
10488 cd      gcorr_loc(j-1)=0.0d0
10489 cd      gcorr_loc(k-1)=0.0d0
10490 cd      eel4=1.0d0
10491 cd      write (iout,*)'Contacts have occurred for peptide groups',
10492 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10493 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10494       if (j.lt.nres-1) then
10495         j1=j+1
10496         j2=j-1
10497       else
10498         j1=j-1
10499         j2=j-2
10500       endif
10501       if (l.lt.nres-1) then
10502         l1=l+1
10503         l2=l-1
10504       else
10505         l1=l-1
10506         l2=l-2
10507       endif
10508       do ll=1,3
10509 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10510 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10511         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10512         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10513 cgrad        ghalf=0.5d0*ggg1(ll)
10514         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10515         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10516         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10517         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10518         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10519         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10520 cgrad        ghalf=0.5d0*ggg2(ll)
10521         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10522         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10523         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10524         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10525         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10526         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10527       enddo
10528 cgrad      do m=i+1,j-1
10529 cgrad        do ll=1,3
10530 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10531 cgrad        enddo
10532 cgrad      enddo
10533 cgrad      do m=k+1,l-1
10534 cgrad        do ll=1,3
10535 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10536 cgrad        enddo
10537 cgrad      enddo
10538 cgrad      do m=i+2,j2
10539 cgrad        do ll=1,3
10540 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10541 cgrad        enddo
10542 cgrad      enddo
10543 cgrad      do m=k+2,l2
10544 cgrad        do ll=1,3
10545 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10546 cgrad        enddo
10547 cgrad      enddo
10548 cd      do iii=1,nres-3
10549 cd        write (2,*) iii,gcorr_loc(iii)
10550 cd      enddo
10551       eello4=ekont*eel4
10552 cd      write (2,*) 'ekont',ekont
10553 cd      write (iout,*) 'eello4',ekont*eel4
10554       return
10555       end
10556 C---------------------------------------------------------------------------
10557       double precision function eello5(i,j,k,l,jj,kk)
10558       implicit real*8 (a-h,o-z)
10559       include 'DIMENSIONS'
10560       include 'COMMON.IOUNITS'
10561       include 'COMMON.CHAIN'
10562       include 'COMMON.DERIV'
10563       include 'COMMON.INTERACT'
10564       include 'COMMON.CONTACTS'
10565       include 'COMMON.CONTMAT'
10566       include 'COMMON.CORRMAT'
10567       include 'COMMON.TORSION'
10568       include 'COMMON.VAR'
10569       include 'COMMON.GEO'
10570       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10571       double precision ggg1(3),ggg2(3)
10572 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10573 C                                                                              C
10574 C                            Parallel chains                                   C
10575 C                                                                              C
10576 C          o             o                   o             o                   C
10577 C         /l\           / \             \   / \           / \   /              C
10578 C        /   \         /   \             \ /   \         /   \ /               C
10579 C       j| o |l1       | o |              o| o |         | o |o                C
10580 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10581 C      \i/   \         /   \ /             /   \         /   \                 C
10582 C       o    k1             o                                                  C
10583 C         (I)          (II)                (III)          (IV)                 C
10584 C                                                                              C
10585 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10586 C                                                                              C
10587 C                            Antiparallel chains                               C
10588 C                                                                              C
10589 C          o             o                   o             o                   C
10590 C         /j\           / \             \   / \           / \   /              C
10591 C        /   \         /   \             \ /   \         /   \ /               C
10592 C      j1| o |l        | o |              o| o |         | o |o                C
10593 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10594 C      \i/   \         /   \ /             /   \         /   \                 C
10595 C       o     k1            o                                                  C
10596 C         (I)          (II)                (III)          (IV)                 C
10597 C                                                                              C
10598 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10599 C                                                                              C
10600 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10601 C                                                                              C
10602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10603 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10604 cd        eello5=0.0d0
10605 cd        return
10606 cd      endif
10607 cd      write (iout,*)
10608 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10609 cd     &   ' and',k,l
10610       itk=itype2loc(itype(k))
10611       itl=itype2loc(itype(l))
10612       itj=itype2loc(itype(j))
10613       eello5_1=0.0d0
10614       eello5_2=0.0d0
10615       eello5_3=0.0d0
10616       eello5_4=0.0d0
10617 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10618 cd     &   eel5_3_num,eel5_4_num)
10619       do iii=1,2
10620         do kkk=1,5
10621           do lll=1,3
10622             derx(lll,kkk,iii)=0.0d0
10623           enddo
10624         enddo
10625       enddo
10626 cd      eij=facont_hb(jj,i)
10627 cd      ekl=facont_hb(kk,k)
10628 cd      ekont=eij*ekl
10629 cd      write (iout,*)'Contacts have occurred for peptide groups',
10630 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10631 cd      goto 1111
10632 C Contribution from the graph I.
10633 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10634 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10635       call transpose2(EUg(1,1,k),auxmat(1,1))
10636       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10637       vv(1)=pizda(1,1)-pizda(2,2)
10638       vv(2)=pizda(1,2)+pizda(2,1)
10639       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10640      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10641 C Explicit gradient in virtual-dihedral angles.
10642       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10643      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10644      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10645       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10646       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10647       vv(1)=pizda(1,1)-pizda(2,2)
10648       vv(2)=pizda(1,2)+pizda(2,1)
10649       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10650      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10651      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10652       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10653       vv(1)=pizda(1,1)-pizda(2,2)
10654       vv(2)=pizda(1,2)+pizda(2,1)
10655       if (l.eq.j+1) then
10656         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10657      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10658      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10659       else
10660         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10661      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10662      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10663       endif
10664 C Cartesian gradient
10665       do iii=1,2
10666         do kkk=1,5
10667           do lll=1,3
10668             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10669      &        pizda(1,1))
10670             vv(1)=pizda(1,1)-pizda(2,2)
10671             vv(2)=pizda(1,2)+pizda(2,1)
10672             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10673      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10674      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10675           enddo
10676         enddo
10677       enddo
10678 c      goto 1112
10679 c1111  continue
10680 C Contribution from graph II
10681       call transpose2(EE(1,1,k),auxmat(1,1))
10682       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10683       vv(1)=pizda(1,1)+pizda(2,2)
10684       vv(2)=pizda(2,1)-pizda(1,2)
10685       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10686      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10687 C Explicit gradient in virtual-dihedral angles.
10688       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10689      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10690       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10691       vv(1)=pizda(1,1)+pizda(2,2)
10692       vv(2)=pizda(2,1)-pizda(1,2)
10693       if (l.eq.j+1) then
10694         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10695      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10696      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10697       else
10698         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10699      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10700      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10701       endif
10702 C Cartesian gradient
10703       do iii=1,2
10704         do kkk=1,5
10705           do lll=1,3
10706             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10707      &        pizda(1,1))
10708             vv(1)=pizda(1,1)+pizda(2,2)
10709             vv(2)=pizda(2,1)-pizda(1,2)
10710             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10711      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10712      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10713           enddo
10714         enddo
10715       enddo
10716 cd      goto 1112
10717 cd1111  continue
10718       if (l.eq.j+1) then
10719 cd        goto 1110
10720 C Parallel orientation
10721 C Contribution from graph III
10722         call transpose2(EUg(1,1,l),auxmat(1,1))
10723         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10724         vv(1)=pizda(1,1)-pizda(2,2)
10725         vv(2)=pizda(1,2)+pizda(2,1)
10726         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10727      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10728 C Explicit gradient in virtual-dihedral angles.
10729         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10730      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10731      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10732         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10733         vv(1)=pizda(1,1)-pizda(2,2)
10734         vv(2)=pizda(1,2)+pizda(2,1)
10735         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10736      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10737      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10738         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10739         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10740         vv(1)=pizda(1,1)-pizda(2,2)
10741         vv(2)=pizda(1,2)+pizda(2,1)
10742         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10743      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10744      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10745 C Cartesian gradient
10746         do iii=1,2
10747           do kkk=1,5
10748             do lll=1,3
10749               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10750      &          pizda(1,1))
10751               vv(1)=pizda(1,1)-pizda(2,2)
10752               vv(2)=pizda(1,2)+pizda(2,1)
10753               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10754      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10755      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10756             enddo
10757           enddo
10758         enddo
10759 cd        goto 1112
10760 C Contribution from graph IV
10761 cd1110    continue
10762         call transpose2(EE(1,1,l),auxmat(1,1))
10763         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10764         vv(1)=pizda(1,1)+pizda(2,2)
10765         vv(2)=pizda(2,1)-pizda(1,2)
10766         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10767      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10768 C Explicit gradient in virtual-dihedral angles.
10769         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10770      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10771         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10772         vv(1)=pizda(1,1)+pizda(2,2)
10773         vv(2)=pizda(2,1)-pizda(1,2)
10774         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10775      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10776      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10777 C Cartesian gradient
10778         do iii=1,2
10779           do kkk=1,5
10780             do lll=1,3
10781               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10782      &          pizda(1,1))
10783               vv(1)=pizda(1,1)+pizda(2,2)
10784               vv(2)=pizda(2,1)-pizda(1,2)
10785               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10786      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10787      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10788             enddo
10789           enddo
10790         enddo
10791       else
10792 C Antiparallel orientation
10793 C Contribution from graph III
10794 c        goto 1110
10795         call transpose2(EUg(1,1,j),auxmat(1,1))
10796         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10797         vv(1)=pizda(1,1)-pizda(2,2)
10798         vv(2)=pizda(1,2)+pizda(2,1)
10799         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10800      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10801 C Explicit gradient in virtual-dihedral angles.
10802         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10803      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10804      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10805         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10806         vv(1)=pizda(1,1)-pizda(2,2)
10807         vv(2)=pizda(1,2)+pizda(2,1)
10808         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10809      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10810      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10811         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10812         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10813         vv(1)=pizda(1,1)-pizda(2,2)
10814         vv(2)=pizda(1,2)+pizda(2,1)
10815         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10816      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10817      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10818 C Cartesian gradient
10819         do iii=1,2
10820           do kkk=1,5
10821             do lll=1,3
10822               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10823      &          pizda(1,1))
10824               vv(1)=pizda(1,1)-pizda(2,2)
10825               vv(2)=pizda(1,2)+pizda(2,1)
10826               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10827      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10828      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10829             enddo
10830           enddo
10831         enddo
10832 cd        goto 1112
10833 C Contribution from graph IV
10834 1110    continue
10835         call transpose2(EE(1,1,j),auxmat(1,1))
10836         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10837         vv(1)=pizda(1,1)+pizda(2,2)
10838         vv(2)=pizda(2,1)-pizda(1,2)
10839         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10840      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10841 C Explicit gradient in virtual-dihedral angles.
10842         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10843      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10844         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10845         vv(1)=pizda(1,1)+pizda(2,2)
10846         vv(2)=pizda(2,1)-pizda(1,2)
10847         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10848      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10849      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10850 C Cartesian gradient
10851         do iii=1,2
10852           do kkk=1,5
10853             do lll=1,3
10854               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10855      &          pizda(1,1))
10856               vv(1)=pizda(1,1)+pizda(2,2)
10857               vv(2)=pizda(2,1)-pizda(1,2)
10858               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10859      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10860      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10861             enddo
10862           enddo
10863         enddo
10864       endif
10865 1112  continue
10866       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10867 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10868 cd        write (2,*) 'ijkl',i,j,k,l
10869 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10870 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10871 cd      endif
10872 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10873 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10874 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10875 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10876       if (j.lt.nres-1) then
10877         j1=j+1
10878         j2=j-1
10879       else
10880         j1=j-1
10881         j2=j-2
10882       endif
10883       if (l.lt.nres-1) then
10884         l1=l+1
10885         l2=l-1
10886       else
10887         l1=l-1
10888         l2=l-2
10889       endif
10890 cd      eij=1.0d0
10891 cd      ekl=1.0d0
10892 cd      ekont=1.0d0
10893 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10894 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10895 C        summed up outside the subrouine as for the other subroutines
10896 C        handling long-range interactions. The old code is commented out
10897 C        with "cgrad" to keep track of changes.
10898       do ll=1,3
10899 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10900 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10901         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10902         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10903 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10904 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10905 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10906 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10907 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10908 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10909 c     &   gradcorr5ij,
10910 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10911 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10912 cgrad        ghalf=0.5d0*ggg1(ll)
10913 cd        ghalf=0.0d0
10914         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10915         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10916         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10917         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10918         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10919         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10920 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10921 cgrad        ghalf=0.5d0*ggg2(ll)
10922 cd        ghalf=0.0d0
10923         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10924         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10925         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10926         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10927         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10928         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10929       enddo
10930 cd      goto 1112
10931 cgrad      do m=i+1,j-1
10932 cgrad        do ll=1,3
10933 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10934 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10935 cgrad        enddo
10936 cgrad      enddo
10937 cgrad      do m=k+1,l-1
10938 cgrad        do ll=1,3
10939 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10940 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10941 cgrad        enddo
10942 cgrad      enddo
10943 c1112  continue
10944 cgrad      do m=i+2,j2
10945 cgrad        do ll=1,3
10946 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10947 cgrad        enddo
10948 cgrad      enddo
10949 cgrad      do m=k+2,l2
10950 cgrad        do ll=1,3
10951 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10952 cgrad        enddo
10953 cgrad      enddo
10954 cd      do iii=1,nres-3
10955 cd        write (2,*) iii,g_corr5_loc(iii)
10956 cd      enddo
10957       eello5=ekont*eel5
10958 cd      write (2,*) 'ekont',ekont
10959 cd      write (iout,*) 'eello5',ekont*eel5
10960       return
10961       end
10962 c--------------------------------------------------------------------------
10963       double precision function eello6(i,j,k,l,jj,kk)
10964       implicit real*8 (a-h,o-z)
10965       include 'DIMENSIONS'
10966       include 'COMMON.IOUNITS'
10967       include 'COMMON.CHAIN'
10968       include 'COMMON.DERIV'
10969       include 'COMMON.INTERACT'
10970       include 'COMMON.CONTACTS'
10971       include 'COMMON.CONTMAT'
10972       include 'COMMON.CORRMAT'
10973       include 'COMMON.TORSION'
10974       include 'COMMON.VAR'
10975       include 'COMMON.GEO'
10976       include 'COMMON.FFIELD'
10977       double precision ggg1(3),ggg2(3)
10978 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10979 cd        eello6=0.0d0
10980 cd        return
10981 cd      endif
10982 cd      write (iout,*)
10983 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10984 cd     &   ' and',k,l
10985       eello6_1=0.0d0
10986       eello6_2=0.0d0
10987       eello6_3=0.0d0
10988       eello6_4=0.0d0
10989       eello6_5=0.0d0
10990       eello6_6=0.0d0
10991 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10992 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10993       do iii=1,2
10994         do kkk=1,5
10995           do lll=1,3
10996             derx(lll,kkk,iii)=0.0d0
10997           enddo
10998         enddo
10999       enddo
11000 cd      eij=facont_hb(jj,i)
11001 cd      ekl=facont_hb(kk,k)
11002 cd      ekont=eij*ekl
11003 cd      eij=1.0d0
11004 cd      ekl=1.0d0
11005 cd      ekont=1.0d0
11006       if (l.eq.j+1) then
11007         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
11008         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
11009         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
11010         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
11011         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
11012         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
11013       else
11014         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
11015         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
11016         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
11017         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
11018         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
11019           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11020         else
11021           eello6_5=0.0d0
11022         endif
11023         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
11024       endif
11025 C If turn contributions are considered, they will be handled separately.
11026       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
11027 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
11028 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
11029 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
11030 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
11031 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
11032 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
11033 cd      goto 1112
11034       if (j.lt.nres-1) then
11035         j1=j+1
11036         j2=j-1
11037       else
11038         j1=j-1
11039         j2=j-2
11040       endif
11041       if (l.lt.nres-1) then
11042         l1=l+1
11043         l2=l-1
11044       else
11045         l1=l-1
11046         l2=l-2
11047       endif
11048       do ll=1,3
11049 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
11050 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
11051 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
11052 cgrad        ghalf=0.5d0*ggg1(ll)
11053 cd        ghalf=0.0d0
11054         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
11055         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
11056         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
11057         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
11058         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
11059         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
11060         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
11061         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
11062 cgrad        ghalf=0.5d0*ggg2(ll)
11063 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
11064 cd        ghalf=0.0d0
11065         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
11066         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
11067         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
11068         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
11069         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
11070         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
11071       enddo
11072 cd      goto 1112
11073 cgrad      do m=i+1,j-1
11074 cgrad        do ll=1,3
11075 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
11076 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
11077 cgrad        enddo
11078 cgrad      enddo
11079 cgrad      do m=k+1,l-1
11080 cgrad        do ll=1,3
11081 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
11082 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
11083 cgrad        enddo
11084 cgrad      enddo
11085 cgrad1112  continue
11086 cgrad      do m=i+2,j2
11087 cgrad        do ll=1,3
11088 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
11089 cgrad        enddo
11090 cgrad      enddo
11091 cgrad      do m=k+2,l2
11092 cgrad        do ll=1,3
11093 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
11094 cgrad        enddo
11095 cgrad      enddo
11096 cd      do iii=1,nres-3
11097 cd        write (2,*) iii,g_corr6_loc(iii)
11098 cd      enddo
11099       eello6=ekont*eel6
11100 cd      write (2,*) 'ekont',ekont
11101 cd      write (iout,*) 'eello6',ekont*eel6
11102       return
11103       end
11104 c--------------------------------------------------------------------------
11105       double precision function eello6_graph1(i,j,k,l,imat,swap)
11106       implicit real*8 (a-h,o-z)
11107       include 'DIMENSIONS'
11108       include 'COMMON.IOUNITS'
11109       include 'COMMON.CHAIN'
11110       include 'COMMON.DERIV'
11111       include 'COMMON.INTERACT'
11112       include 'COMMON.CONTACTS'
11113       include 'COMMON.CONTMAT'
11114       include 'COMMON.CORRMAT'
11115       include 'COMMON.TORSION'
11116       include 'COMMON.VAR'
11117       include 'COMMON.GEO'
11118       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11119       logical swap
11120       logical lprn
11121       common /kutas/ lprn
11122 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11123 C                                                                              C
11124 C      Parallel       Antiparallel                                             C
11125 C                                                                              C
11126 C          o             o                                                     C
11127 C         /l\           /j\                                                    C
11128 C        /   \         /   \                                                   C
11129 C       /| o |         | o |\                                                  C
11130 C     \ j|/k\|  /   \  |/k\|l /                                                C
11131 C      \ /   \ /     \ /   \ /                                                 C
11132 C       o     o       o     o                                                  C
11133 C       i             i                                                        C
11134 C                                                                              C
11135 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11136       itk=itype2loc(itype(k))
11137       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11138       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11139       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11140       call transpose2(EUgC(1,1,k),auxmat(1,1))
11141       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11142       vv1(1)=pizda1(1,1)-pizda1(2,2)
11143       vv1(2)=pizda1(1,2)+pizda1(2,1)
11144       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11145       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11146       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11147       s5=scalar2(vv(1),Dtobr2(1,i))
11148 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11149       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11150       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11151      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11152      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11153      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11154      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11155      & +scalar2(vv(1),Dtobr2der(1,i)))
11156       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11157       vv1(1)=pizda1(1,1)-pizda1(2,2)
11158       vv1(2)=pizda1(1,2)+pizda1(2,1)
11159       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11160       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11161       if (l.eq.j+1) then
11162         g_corr6_loc(l-1)=g_corr6_loc(l-1)
11163      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11164      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11165      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11166      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11167       else
11168         g_corr6_loc(j-1)=g_corr6_loc(j-1)
11169      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11170      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11171      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11172      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11173       endif
11174       call transpose2(EUgCder(1,1,k),auxmat(1,1))
11175       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11176       vv1(1)=pizda1(1,1)-pizda1(2,2)
11177       vv1(2)=pizda1(1,2)+pizda1(2,1)
11178       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11179      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11180      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11181      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11182       do iii=1,2
11183         if (swap) then
11184           ind=3-iii
11185         else
11186           ind=iii
11187         endif
11188         do kkk=1,5
11189           do lll=1,3
11190             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11191             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11192             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11193             call transpose2(EUgC(1,1,k),auxmat(1,1))
11194             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11195      &        pizda1(1,1))
11196             vv1(1)=pizda1(1,1)-pizda1(2,2)
11197             vv1(2)=pizda1(1,2)+pizda1(2,1)
11198             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11199             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11200      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11201             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11202      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11203             s5=scalar2(vv(1),Dtobr2(1,i))
11204             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11205           enddo
11206         enddo
11207       enddo
11208       return
11209       end
11210 c----------------------------------------------------------------------------
11211       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11212       implicit real*8 (a-h,o-z)
11213       include 'DIMENSIONS'
11214       include 'COMMON.IOUNITS'
11215       include 'COMMON.CHAIN'
11216       include 'COMMON.DERIV'
11217       include 'COMMON.INTERACT'
11218       include 'COMMON.CONTACTS'
11219       include 'COMMON.CONTMAT'
11220       include 'COMMON.CORRMAT'
11221       include 'COMMON.TORSION'
11222       include 'COMMON.VAR'
11223       include 'COMMON.GEO'
11224       logical swap
11225       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11226      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11227       logical lprn
11228       common /kutas/ lprn
11229 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11230 C                                                                              C
11231 C      Parallel       Antiparallel                                             C
11232 C                                                                              C
11233 C          o             o                                                     C
11234 C     \   /l\           /j\   /                                                C
11235 C      \ /   \         /   \ /                                                 C
11236 C       o| o |         | o |o                                                  C
11237 C     \ j|/k\|      \  |/k\|l                                                  C
11238 C      \ /   \       \ /   \                                                   C
11239 C       o             o                                                        C
11240 C       i             i                                                        C
11241 C                                                                              C
11242 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11243 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11244 C AL 7/4/01 s1 would occur in the sixth-order moment,
11245 C           but not in a cluster cumulant
11246 #ifdef MOMENT
11247       s1=dip(1,jj,i)*dip(1,kk,k)
11248 #endif
11249       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11250       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11251       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11252       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11253       call transpose2(EUg(1,1,k),auxmat(1,1))
11254       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11255       vv(1)=pizda(1,1)-pizda(2,2)
11256       vv(2)=pizda(1,2)+pizda(2,1)
11257       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11258 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11259 #ifdef MOMENT
11260       eello6_graph2=-(s1+s2+s3+s4)
11261 #else
11262       eello6_graph2=-(s2+s3+s4)
11263 #endif
11264 c      eello6_graph2=-s3
11265 C Derivatives in gamma(i-1)
11266       if (i.gt.1) then
11267 #ifdef MOMENT
11268         s1=dipderg(1,jj,i)*dip(1,kk,k)
11269 #endif
11270         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11271         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11272         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11273         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11274 #ifdef MOMENT
11275         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11276 #else
11277         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11278 #endif
11279 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11280       endif
11281 C Derivatives in gamma(k-1)
11282 #ifdef MOMENT
11283       s1=dip(1,jj,i)*dipderg(1,kk,k)
11284 #endif
11285       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11286       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11287       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11288       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11289       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11290       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11291       vv(1)=pizda(1,1)-pizda(2,2)
11292       vv(2)=pizda(1,2)+pizda(2,1)
11293       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11294 #ifdef MOMENT
11295       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11296 #else
11297       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11298 #endif
11299 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11300 C Derivatives in gamma(j-1) or gamma(l-1)
11301       if (j.gt.1) then
11302 #ifdef MOMENT
11303         s1=dipderg(3,jj,i)*dip(1,kk,k)
11304 #endif
11305         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11306         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11307         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11308         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11309         vv(1)=pizda(1,1)-pizda(2,2)
11310         vv(2)=pizda(1,2)+pizda(2,1)
11311         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11312 #ifdef MOMENT
11313         if (swap) then
11314           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11315         else
11316           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11317         endif
11318 #endif
11319         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11320 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11321       endif
11322 C Derivatives in gamma(l-1) or gamma(j-1)
11323       if (l.gt.1) then
11324 #ifdef MOMENT
11325         s1=dip(1,jj,i)*dipderg(3,kk,k)
11326 #endif
11327         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11328         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11329         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11330         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11331         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11332         vv(1)=pizda(1,1)-pizda(2,2)
11333         vv(2)=pizda(1,2)+pizda(2,1)
11334         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11335 #ifdef MOMENT
11336         if (swap) then
11337           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11338         else
11339           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11340         endif
11341 #endif
11342         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11343 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11344       endif
11345 C Cartesian derivatives.
11346       if (lprn) then
11347         write (2,*) 'In eello6_graph2'
11348         do iii=1,2
11349           write (2,*) 'iii=',iii
11350           do kkk=1,5
11351             write (2,*) 'kkk=',kkk
11352             do jjj=1,2
11353               write (2,'(3(2f10.5),5x)')
11354      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11355             enddo
11356           enddo
11357         enddo
11358       endif
11359       do iii=1,2
11360         do kkk=1,5
11361           do lll=1,3
11362 #ifdef MOMENT
11363             if (iii.eq.1) then
11364               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11365             else
11366               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11367             endif
11368 #endif
11369             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11370      &        auxvec(1))
11371             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11372             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11373      &        auxvec(1))
11374             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11375             call transpose2(EUg(1,1,k),auxmat(1,1))
11376             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11377      &        pizda(1,1))
11378             vv(1)=pizda(1,1)-pizda(2,2)
11379             vv(2)=pizda(1,2)+pizda(2,1)
11380             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11381 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11382 #ifdef MOMENT
11383             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11384 #else
11385             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11386 #endif
11387             if (swap) then
11388               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11389             else
11390               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11391             endif
11392           enddo
11393         enddo
11394       enddo
11395       return
11396       end
11397 c----------------------------------------------------------------------------
11398       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11399       implicit real*8 (a-h,o-z)
11400       include 'DIMENSIONS'
11401       include 'COMMON.IOUNITS'
11402       include 'COMMON.CHAIN'
11403       include 'COMMON.DERIV'
11404       include 'COMMON.INTERACT'
11405       include 'COMMON.CONTACTS'
11406       include 'COMMON.CONTMAT'
11407       include 'COMMON.CORRMAT'
11408       include 'COMMON.TORSION'
11409       include 'COMMON.VAR'
11410       include 'COMMON.GEO'
11411       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11412       logical swap
11413 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11414 C                                                                              C
11415 C      Parallel       Antiparallel                                             C
11416 C                                                                              C
11417 C          o             o                                                     C
11418 C         /l\   /   \   /j\                                                    C
11419 C        /   \ /     \ /   \                                                   C
11420 C       /| o |o       o| o |\                                                  C
11421 C       j|/k\|  /      |/k\|l /                                                C
11422 C        /   \ /       /   \ /                                                 C
11423 C       /     o       /     o                                                  C
11424 C       i             i                                                        C
11425 C                                                                              C
11426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11427 C
11428 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11429 C           energy moment and not to the cluster cumulant.
11430       iti=itortyp(itype(i))
11431       if (j.lt.nres-1) then
11432         itj1=itype2loc(itype(j+1))
11433       else
11434         itj1=nloctyp
11435       endif
11436       itk=itype2loc(itype(k))
11437       itk1=itype2loc(itype(k+1))
11438       if (l.lt.nres-1) then
11439         itl1=itype2loc(itype(l+1))
11440       else
11441         itl1=nloctyp
11442       endif
11443 #ifdef MOMENT
11444       s1=dip(4,jj,i)*dip(4,kk,k)
11445 #endif
11446       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11447       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11448       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11449       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11450       call transpose2(EE(1,1,k),auxmat(1,1))
11451       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11452       vv(1)=pizda(1,1)+pizda(2,2)
11453       vv(2)=pizda(2,1)-pizda(1,2)
11454       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11455 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11456 cd     & "sum",-(s2+s3+s4)
11457 #ifdef MOMENT
11458       eello6_graph3=-(s1+s2+s3+s4)
11459 #else
11460       eello6_graph3=-(s2+s3+s4)
11461 #endif
11462 c      eello6_graph3=-s4
11463 C Derivatives in gamma(k-1)
11464       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11465       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11466       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11467       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11468 C Derivatives in gamma(l-1)
11469       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11470       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11471       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11472       vv(1)=pizda(1,1)+pizda(2,2)
11473       vv(2)=pizda(2,1)-pizda(1,2)
11474       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11475       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11476 C Cartesian derivatives.
11477       do iii=1,2
11478         do kkk=1,5
11479           do lll=1,3
11480 #ifdef MOMENT
11481             if (iii.eq.1) then
11482               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11483             else
11484               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11485             endif
11486 #endif
11487             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11488      &        auxvec(1))
11489             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11490             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11491      &        auxvec(1))
11492             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11493             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11494      &        pizda(1,1))
11495             vv(1)=pizda(1,1)+pizda(2,2)
11496             vv(2)=pizda(2,1)-pizda(1,2)
11497             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11498 #ifdef MOMENT
11499             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11500 #else
11501             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11502 #endif
11503             if (swap) then
11504               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11505             else
11506               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11507             endif
11508 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11509           enddo
11510         enddo
11511       enddo
11512       return
11513       end
11514 c----------------------------------------------------------------------------
11515       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11516       implicit real*8 (a-h,o-z)
11517       include 'DIMENSIONS'
11518       include 'COMMON.IOUNITS'
11519       include 'COMMON.CHAIN'
11520       include 'COMMON.DERIV'
11521       include 'COMMON.INTERACT'
11522       include 'COMMON.CONTACTS'
11523       include 'COMMON.CONTMAT'
11524       include 'COMMON.CORRMAT'
11525       include 'COMMON.TORSION'
11526       include 'COMMON.VAR'
11527       include 'COMMON.GEO'
11528       include 'COMMON.FFIELD'
11529       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11530      & auxvec1(2),auxmat1(2,2)
11531       logical swap
11532 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11533 C                                                                              C
11534 C      Parallel       Antiparallel                                             C
11535 C                                                                              C
11536 C          o             o                                                     C
11537 C         /l\   /   \   /j\                                                    C
11538 C        /   \ /     \ /   \                                                   C
11539 C       /| o |o       o| o |\                                                  C
11540 C     \ j|/k\|      \  |/k\|l                                                  C
11541 C      \ /   \       \ /   \                                                   C
11542 C       o     \       o     \                                                  C
11543 C       i             i                                                        C
11544 C                                                                              C
11545 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11546 C
11547 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11548 C           energy moment and not to the cluster cumulant.
11549 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11550       iti=itype2loc(itype(i))
11551       itj=itype2loc(itype(j))
11552       if (j.lt.nres-1) then
11553         itj1=itype2loc(itype(j+1))
11554       else
11555         itj1=nloctyp
11556       endif
11557       itk=itype2loc(itype(k))
11558       if (k.lt.nres-1) then
11559         itk1=itype2loc(itype(k+1))
11560       else
11561         itk1=nloctyp
11562       endif
11563       itl=itype2loc(itype(l))
11564       if (l.lt.nres-1) then
11565         itl1=itype2loc(itype(l+1))
11566       else
11567         itl1=nloctyp
11568       endif
11569 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11570 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11571 cd     & ' itl',itl,' itl1',itl1
11572 #ifdef MOMENT
11573       if (imat.eq.1) then
11574         s1=dip(3,jj,i)*dip(3,kk,k)
11575       else
11576         s1=dip(2,jj,j)*dip(2,kk,l)
11577       endif
11578 #endif
11579       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11580       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11581       if (j.eq.l+1) then
11582         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11583         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11584       else
11585         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11586         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11587       endif
11588       call transpose2(EUg(1,1,k),auxmat(1,1))
11589       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11590       vv(1)=pizda(1,1)-pizda(2,2)
11591       vv(2)=pizda(2,1)+pizda(1,2)
11592       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11593 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11594 #ifdef MOMENT
11595       eello6_graph4=-(s1+s2+s3+s4)
11596 #else
11597       eello6_graph4=-(s2+s3+s4)
11598 #endif
11599 C Derivatives in gamma(i-1)
11600       if (i.gt.1) then
11601 #ifdef MOMENT
11602         if (imat.eq.1) then
11603           s1=dipderg(2,jj,i)*dip(3,kk,k)
11604         else
11605           s1=dipderg(4,jj,j)*dip(2,kk,l)
11606         endif
11607 #endif
11608         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11609         if (j.eq.l+1) then
11610           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11611           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11612         else
11613           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11614           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11615         endif
11616         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11617         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11618 cd          write (2,*) 'turn6 derivatives'
11619 #ifdef MOMENT
11620           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11621 #else
11622           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11623 #endif
11624         else
11625 #ifdef MOMENT
11626           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11627 #else
11628           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11629 #endif
11630         endif
11631       endif
11632 C Derivatives in gamma(k-1)
11633 #ifdef MOMENT
11634       if (imat.eq.1) then
11635         s1=dip(3,jj,i)*dipderg(2,kk,k)
11636       else
11637         s1=dip(2,jj,j)*dipderg(4,kk,l)
11638       endif
11639 #endif
11640       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11641       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11642       if (j.eq.l+1) then
11643         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11644         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11645       else
11646         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11647         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11648       endif
11649       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11650       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11651       vv(1)=pizda(1,1)-pizda(2,2)
11652       vv(2)=pizda(2,1)+pizda(1,2)
11653       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11654       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11655 #ifdef MOMENT
11656         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11657 #else
11658         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11659 #endif
11660       else
11661 #ifdef MOMENT
11662         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11663 #else
11664         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11665 #endif
11666       endif
11667 C Derivatives in gamma(j-1) or gamma(l-1)
11668       if (l.eq.j+1 .and. l.gt.1) then
11669         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11670         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11671         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11672         vv(1)=pizda(1,1)-pizda(2,2)
11673         vv(2)=pizda(2,1)+pizda(1,2)
11674         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11675         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11676       else if (j.gt.1) then
11677         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11678         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11679         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11680         vv(1)=pizda(1,1)-pizda(2,2)
11681         vv(2)=pizda(2,1)+pizda(1,2)
11682         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11683         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11684           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11685         else
11686           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11687         endif
11688       endif
11689 C Cartesian derivatives.
11690       do iii=1,2
11691         do kkk=1,5
11692           do lll=1,3
11693 #ifdef MOMENT
11694             if (iii.eq.1) then
11695               if (imat.eq.1) then
11696                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11697               else
11698                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11699               endif
11700             else
11701               if (imat.eq.1) then
11702                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11703               else
11704                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11705               endif
11706             endif
11707 #endif
11708             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11709      &        auxvec(1))
11710             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11711             if (j.eq.l+1) then
11712               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11713      &          b1(1,j+1),auxvec(1))
11714               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11715             else
11716               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11717      &          b1(1,l+1),auxvec(1))
11718               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11719             endif
11720             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11721      &        pizda(1,1))
11722             vv(1)=pizda(1,1)-pizda(2,2)
11723             vv(2)=pizda(2,1)+pizda(1,2)
11724             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11725             if (swap) then
11726               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11727 #ifdef MOMENT
11728                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11729      &             -(s1+s2+s4)
11730 #else
11731                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11732      &             -(s2+s4)
11733 #endif
11734                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11735               else
11736 #ifdef MOMENT
11737                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11738 #else
11739                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11740 #endif
11741                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11742               endif
11743             else
11744 #ifdef MOMENT
11745               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11746 #else
11747               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11748 #endif
11749               if (l.eq.j+1) then
11750                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11751               else
11752                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11753               endif
11754             endif
11755           enddo
11756         enddo
11757       enddo
11758       return
11759       end
11760 c----------------------------------------------------------------------------
11761       double precision function eello_turn6(i,jj,kk)
11762       implicit real*8 (a-h,o-z)
11763       include 'DIMENSIONS'
11764       include 'COMMON.IOUNITS'
11765       include 'COMMON.CHAIN'
11766       include 'COMMON.DERIV'
11767       include 'COMMON.INTERACT'
11768       include 'COMMON.CONTACTS'
11769       include 'COMMON.CONTMAT'
11770       include 'COMMON.CORRMAT'
11771       include 'COMMON.TORSION'
11772       include 'COMMON.VAR'
11773       include 'COMMON.GEO'
11774       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11775      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11776      &  ggg1(3),ggg2(3)
11777       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11778      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11779 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11780 C           the respective energy moment and not to the cluster cumulant.
11781       s1=0.0d0
11782       s8=0.0d0
11783       s13=0.0d0
11784 c
11785       eello_turn6=0.0d0
11786       j=i+4
11787       k=i+1
11788       l=i+3
11789       iti=itype2loc(itype(i))
11790       itk=itype2loc(itype(k))
11791       itk1=itype2loc(itype(k+1))
11792       itl=itype2loc(itype(l))
11793       itj=itype2loc(itype(j))
11794 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11795 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11796 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11797 cd        eello6=0.0d0
11798 cd        return
11799 cd      endif
11800 cd      write (iout,*)
11801 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11802 cd     &   ' and',k,l
11803 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11804       do iii=1,2
11805         do kkk=1,5
11806           do lll=1,3
11807             derx_turn(lll,kkk,iii)=0.0d0
11808           enddo
11809         enddo
11810       enddo
11811 cd      eij=1.0d0
11812 cd      ekl=1.0d0
11813 cd      ekont=1.0d0
11814       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11815 cd      eello6_5=0.0d0
11816 cd      write (2,*) 'eello6_5',eello6_5
11817 #ifdef MOMENT
11818       call transpose2(AEA(1,1,1),auxmat(1,1))
11819       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11820       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11821       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11822 #endif
11823       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11824       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11825       s2 = scalar2(b1(1,k),vtemp1(1))
11826 #ifdef MOMENT
11827       call transpose2(AEA(1,1,2),atemp(1,1))
11828       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11829       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11830       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11831 #endif
11832       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11833       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11834       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11835 #ifdef MOMENT
11836       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11837       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11838       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11839       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11840       ss13 = scalar2(b1(1,k),vtemp4(1))
11841       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11842 #endif
11843 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11844 c      s1=0.0d0
11845 c      s2=0.0d0
11846 c      s8=0.0d0
11847 c      s12=0.0d0
11848 c      s13=0.0d0
11849       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11850 C Derivatives in gamma(i+2)
11851       s1d =0.0d0
11852       s8d =0.0d0
11853 #ifdef MOMENT
11854       call transpose2(AEA(1,1,1),auxmatd(1,1))
11855       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11856       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11857       call transpose2(AEAderg(1,1,2),atempd(1,1))
11858       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11859       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11860 #endif
11861       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11862       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11863       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11864 c      s1d=0.0d0
11865 c      s2d=0.0d0
11866 c      s8d=0.0d0
11867 c      s12d=0.0d0
11868 c      s13d=0.0d0
11869       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11870 C Derivatives in gamma(i+3)
11871 #ifdef MOMENT
11872       call transpose2(AEA(1,1,1),auxmatd(1,1))
11873       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11874       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11875       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11876 #endif
11877       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11878       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11879       s2d = scalar2(b1(1,k),vtemp1d(1))
11880 #ifdef MOMENT
11881       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11882       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11883 #endif
11884       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11885 #ifdef MOMENT
11886       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11887       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11888       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11889 #endif
11890 c      s1d=0.0d0
11891 c      s2d=0.0d0
11892 c      s8d=0.0d0
11893 c      s12d=0.0d0
11894 c      s13d=0.0d0
11895 #ifdef MOMENT
11896       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11897      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11898 #else
11899       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11900      &               -0.5d0*ekont*(s2d+s12d)
11901 #endif
11902 C Derivatives in gamma(i+4)
11903       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11904       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11905       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11906 #ifdef MOMENT
11907       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11908       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11909       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11910 #endif
11911 c      s1d=0.0d0
11912 c      s2d=0.0d0
11913 c      s8d=0.0d0
11914 C      s12d=0.0d0
11915 c      s13d=0.0d0
11916 #ifdef MOMENT
11917       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11918 #else
11919       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11920 #endif
11921 C Derivatives in gamma(i+5)
11922 #ifdef MOMENT
11923       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11924       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11925       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11926 #endif
11927       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11928       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11929       s2d = scalar2(b1(1,k),vtemp1d(1))
11930 #ifdef MOMENT
11931       call transpose2(AEA(1,1,2),atempd(1,1))
11932       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11933       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11934 #endif
11935       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11936       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11937 #ifdef MOMENT
11938       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11939       ss13d = scalar2(b1(1,k),vtemp4d(1))
11940       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11941 #endif
11942 c      s1d=0.0d0
11943 c      s2d=0.0d0
11944 c      s8d=0.0d0
11945 c      s12d=0.0d0
11946 c      s13d=0.0d0
11947 #ifdef MOMENT
11948       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11949      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11950 #else
11951       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11952      &               -0.5d0*ekont*(s2d+s12d)
11953 #endif
11954 C Cartesian derivatives
11955       do iii=1,2
11956         do kkk=1,5
11957           do lll=1,3
11958 #ifdef MOMENT
11959             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11960             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11961             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11962 #endif
11963             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11964             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11965      &          vtemp1d(1))
11966             s2d = scalar2(b1(1,k),vtemp1d(1))
11967 #ifdef MOMENT
11968             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11969             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11970             s8d = -(atempd(1,1)+atempd(2,2))*
11971      &           scalar2(cc(1,1,l),vtemp2(1))
11972 #endif
11973             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11974      &           auxmatd(1,1))
11975             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11976             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11977 c      s1d=0.0d0
11978 c      s2d=0.0d0
11979 c      s8d=0.0d0
11980 c      s12d=0.0d0
11981 c      s13d=0.0d0
11982 #ifdef MOMENT
11983             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11984      &        - 0.5d0*(s1d+s2d)
11985 #else
11986             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11987      &        - 0.5d0*s2d
11988 #endif
11989 #ifdef MOMENT
11990             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11991      &        - 0.5d0*(s8d+s12d)
11992 #else
11993             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11994      &        - 0.5d0*s12d
11995 #endif
11996           enddo
11997         enddo
11998       enddo
11999 #ifdef MOMENT
12000       do kkk=1,5
12001         do lll=1,3
12002           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
12003      &      achuj_tempd(1,1))
12004           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
12005           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
12006           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
12007           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
12008           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
12009      &      vtemp4d(1))
12010           ss13d = scalar2(b1(1,k),vtemp4d(1))
12011           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
12012           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
12013         enddo
12014       enddo
12015 #endif
12016 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
12017 cd     &  16*eel_turn6_num
12018 cd      goto 1112
12019       if (j.lt.nres-1) then
12020         j1=j+1
12021         j2=j-1
12022       else
12023         j1=j-1
12024         j2=j-2
12025       endif
12026       if (l.lt.nres-1) then
12027         l1=l+1
12028         l2=l-1
12029       else
12030         l1=l-1
12031         l2=l-2
12032       endif
12033       do ll=1,3
12034 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
12035 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
12036 cgrad        ghalf=0.5d0*ggg1(ll)
12037 cd        ghalf=0.0d0
12038         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
12039         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
12040         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
12041      &    +ekont*derx_turn(ll,2,1)
12042         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
12043         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
12044      &    +ekont*derx_turn(ll,4,1)
12045         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
12046         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
12047         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
12048 cgrad        ghalf=0.5d0*ggg2(ll)
12049 cd        ghalf=0.0d0
12050         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
12051      &    +ekont*derx_turn(ll,2,2)
12052         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
12053         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
12054      &    +ekont*derx_turn(ll,4,2)
12055         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
12056         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
12057         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
12058       enddo
12059 cd      goto 1112
12060 cgrad      do m=i+1,j-1
12061 cgrad        do ll=1,3
12062 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
12063 cgrad        enddo
12064 cgrad      enddo
12065 cgrad      do m=k+1,l-1
12066 cgrad        do ll=1,3
12067 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
12068 cgrad        enddo
12069 cgrad      enddo
12070 cgrad1112  continue
12071 cgrad      do m=i+2,j2
12072 cgrad        do ll=1,3
12073 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
12074 cgrad        enddo
12075 cgrad      enddo
12076 cgrad      do m=k+2,l2
12077 cgrad        do ll=1,3
12078 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
12079 cgrad        enddo
12080 cgrad      enddo
12081 cd      do iii=1,nres-3
12082 cd        write (2,*) iii,g_corr6_loc(iii)
12083 cd      enddo
12084       eello_turn6=ekont*eel_turn6
12085 cd      write (2,*) 'ekont',ekont
12086 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
12087       return
12088       end
12089 C-----------------------------------------------------------------------------
12090 #endif
12091       double precision function scalar(u,v)
12092 !DIR$ INLINEALWAYS scalar
12093 #ifndef OSF
12094 cDEC$ ATTRIBUTES FORCEINLINE::scalar
12095 #endif
12096       implicit none
12097       double precision u(3),v(3)
12098 cd      double precision sc
12099 cd      integer i
12100 cd      sc=0.0d0
12101 cd      do i=1,3
12102 cd        sc=sc+u(i)*v(i)
12103 cd      enddo
12104 cd      scalar=sc
12105
12106       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12107       return
12108       end
12109 crc-------------------------------------------------
12110       SUBROUTINE MATVEC2(A1,V1,V2)
12111 !DIR$ INLINEALWAYS MATVEC2
12112 #ifndef OSF
12113 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12114 #endif
12115       implicit real*8 (a-h,o-z)
12116       include 'DIMENSIONS'
12117       DIMENSION A1(2,2),V1(2),V2(2)
12118 c      DO 1 I=1,2
12119 c        VI=0.0
12120 c        DO 3 K=1,2
12121 c    3     VI=VI+A1(I,K)*V1(K)
12122 c        Vaux(I)=VI
12123 c    1 CONTINUE
12124
12125       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12126       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12127
12128       v2(1)=vaux1
12129       v2(2)=vaux2
12130       END
12131 C---------------------------------------
12132       SUBROUTINE MATMAT2(A1,A2,A3)
12133 #ifndef OSF
12134 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12135 #endif
12136       implicit real*8 (a-h,o-z)
12137       include 'DIMENSIONS'
12138       DIMENSION A1(2,2),A2(2,2),A3(2,2)
12139 c      DIMENSION AI3(2,2)
12140 c        DO  J=1,2
12141 c          A3IJ=0.0
12142 c          DO K=1,2
12143 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
12144 c          enddo
12145 c          A3(I,J)=A3IJ
12146 c       enddo
12147 c      enddo
12148
12149       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12150       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12151       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12152       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12153
12154       A3(1,1)=AI3_11
12155       A3(2,1)=AI3_21
12156       A3(1,2)=AI3_12
12157       A3(2,2)=AI3_22
12158       END
12159
12160 c-------------------------------------------------------------------------
12161       double precision function scalar2(u,v)
12162 !DIR$ INLINEALWAYS scalar2
12163       implicit none
12164       double precision u(2),v(2)
12165       double precision sc
12166       integer i
12167       scalar2=u(1)*v(1)+u(2)*v(2)
12168       return
12169       end
12170
12171 C-----------------------------------------------------------------------------
12172
12173       subroutine transpose2(a,at)
12174 !DIR$ INLINEALWAYS transpose2
12175 #ifndef OSF
12176 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12177 #endif
12178       implicit none
12179       double precision a(2,2),at(2,2)
12180       at(1,1)=a(1,1)
12181       at(1,2)=a(2,1)
12182       at(2,1)=a(1,2)
12183       at(2,2)=a(2,2)
12184       return
12185       end
12186 c--------------------------------------------------------------------------
12187       subroutine transpose(n,a,at)
12188       implicit none
12189       integer n,i,j
12190       double precision a(n,n),at(n,n)
12191       do i=1,n
12192         do j=1,n
12193           at(j,i)=a(i,j)
12194         enddo
12195       enddo
12196       return
12197       end
12198 C---------------------------------------------------------------------------
12199       subroutine prodmat3(a1,a2,kk,transp,prod)
12200 !DIR$ INLINEALWAYS prodmat3
12201 #ifndef OSF
12202 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12203 #endif
12204       implicit none
12205       integer i,j
12206       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12207       logical transp
12208 crc      double precision auxmat(2,2),prod_(2,2)
12209
12210       if (transp) then
12211 crc        call transpose2(kk(1,1),auxmat(1,1))
12212 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12213 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12214
12215            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12216      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12217            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12218      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12219            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12220      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12221            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12222      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12223
12224       else
12225 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12226 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12227
12228            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12229      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12230            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12231      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12232            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12233      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12234            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12235      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12236
12237       endif
12238 c      call transpose2(a2(1,1),a2t(1,1))
12239
12240 crc      print *,transp
12241 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12242 crc      print *,((prod(i,j),i=1,2),j=1,2)
12243
12244       return
12245       end
12246 CCC----------------------------------------------
12247       subroutine Eliptransfer(eliptran)
12248       implicit real*8 (a-h,o-z)
12249       include 'DIMENSIONS'
12250       include 'COMMON.GEO'
12251       include 'COMMON.VAR'
12252       include 'COMMON.LOCAL'
12253       include 'COMMON.CHAIN'
12254       include 'COMMON.DERIV'
12255       include 'COMMON.NAMES'
12256       include 'COMMON.INTERACT'
12257       include 'COMMON.IOUNITS'
12258       include 'COMMON.CALC'
12259       include 'COMMON.CONTROL'
12260       include 'COMMON.SPLITELE'
12261       include 'COMMON.SBRIDGE'
12262 C this is done by Adasko
12263 C      print *,"wchodze"
12264 C structure of box:
12265 C      water
12266 C--bordliptop-- buffore starts
12267 C--bufliptop--- here true lipid starts
12268 C      lipid
12269 C--buflipbot--- lipid ends buffore starts
12270 C--bordlipbot--buffore ends
12271       eliptran=0.0
12272       do i=ilip_start,ilip_end
12273 C       do i=1,1
12274         if (itype(i).eq.ntyp1) cycle
12275
12276         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12277         if (positi.le.0.0) positi=positi+boxzsize
12278 C        print *,i
12279 C first for peptide groups
12280 c for each residue check if it is in lipid or lipid water border area
12281        if ((positi.gt.bordlipbot)
12282      &.and.(positi.lt.bordliptop)) then
12283 C the energy transfer exist
12284         if (positi.lt.buflipbot) then
12285 C what fraction I am in
12286          fracinbuf=1.0d0-
12287      &        ((positi-bordlipbot)/lipbufthick)
12288 C lipbufthick is thickenes of lipid buffore
12289          sslip=sscalelip(fracinbuf)
12290          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12291          eliptran=eliptran+sslip*pepliptran
12292          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12293          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12294 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12295
12296 C        print *,"doing sccale for lower part"
12297 C         print *,i,sslip,fracinbuf,ssgradlip
12298         elseif (positi.gt.bufliptop) then
12299          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12300          sslip=sscalelip(fracinbuf)
12301          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12302          eliptran=eliptran+sslip*pepliptran
12303          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12304          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12305 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12306 C          print *, "doing sscalefor top part"
12307 C         print *,i,sslip,fracinbuf,ssgradlip
12308         else
12309          eliptran=eliptran+pepliptran
12310 C         print *,"I am in true lipid"
12311         endif
12312 C       else
12313 C       eliptran=elpitran+0.0 ! I am in water
12314        endif
12315        enddo
12316 C       print *, "nic nie bylo w lipidzie?"
12317 C now multiply all by the peptide group transfer factor
12318 C       eliptran=eliptran*pepliptran
12319 C now the same for side chains
12320 CV       do i=1,1
12321        do i=ilip_start,ilip_end
12322         if (itype(i).eq.ntyp1) cycle
12323         positi=(mod(c(3,i+nres),boxzsize))
12324         if (positi.le.0) positi=positi+boxzsize
12325 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12326 c for each residue check if it is in lipid or lipid water border area
12327 C       respos=mod(c(3,i+nres),boxzsize)
12328 C       print *,positi,bordlipbot,buflipbot
12329        if ((positi.gt.bordlipbot)
12330      & .and.(positi.lt.bordliptop)) then
12331 C the energy transfer exist
12332         if (positi.lt.buflipbot) then
12333          fracinbuf=1.0d0-
12334      &     ((positi-bordlipbot)/lipbufthick)
12335 C lipbufthick is thickenes of lipid buffore
12336          sslip=sscalelip(fracinbuf)
12337          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12338          eliptran=eliptran+sslip*liptranene(itype(i))
12339          gliptranx(3,i)=gliptranx(3,i)
12340      &+ssgradlip*liptranene(itype(i))
12341          gliptranc(3,i-1)= gliptranc(3,i-1)
12342      &+ssgradlip*liptranene(itype(i))
12343 C         print *,"doing sccale for lower part"
12344         elseif (positi.gt.bufliptop) then
12345          fracinbuf=1.0d0-
12346      &((bordliptop-positi)/lipbufthick)
12347          sslip=sscalelip(fracinbuf)
12348          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12349          eliptran=eliptran+sslip*liptranene(itype(i))
12350          gliptranx(3,i)=gliptranx(3,i)
12351      &+ssgradlip*liptranene(itype(i))
12352          gliptranc(3,i-1)= gliptranc(3,i-1)
12353      &+ssgradlip*liptranene(itype(i))
12354 C          print *, "doing sscalefor top part",sslip,fracinbuf
12355         else
12356          eliptran=eliptran+liptranene(itype(i))
12357 C         print *,"I am in true lipid"
12358         endif
12359         endif ! if in lipid or buffor
12360 C       else
12361 C       eliptran=elpitran+0.0 ! I am in water
12362        enddo
12363        return
12364        end
12365 C---------------------------------------------------------
12366 C AFM soubroutine for constant force
12367        subroutine AFMforce(Eafmforce)
12368        implicit real*8 (a-h,o-z)
12369       include 'DIMENSIONS'
12370       include 'COMMON.GEO'
12371       include 'COMMON.VAR'
12372       include 'COMMON.LOCAL'
12373       include 'COMMON.CHAIN'
12374       include 'COMMON.DERIV'
12375       include 'COMMON.NAMES'
12376       include 'COMMON.INTERACT'
12377       include 'COMMON.IOUNITS'
12378       include 'COMMON.CALC'
12379       include 'COMMON.CONTROL'
12380       include 'COMMON.SPLITELE'
12381       include 'COMMON.SBRIDGE'
12382       real*8 diffafm(3)
12383       dist=0.0d0
12384       Eafmforce=0.0d0
12385       do i=1,3
12386       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12387       dist=dist+diffafm(i)**2
12388       enddo
12389       dist=dsqrt(dist)
12390       Eafmforce=-forceAFMconst*(dist-distafminit)
12391       do i=1,3
12392       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12393       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12394       enddo
12395 C      print *,'AFM',Eafmforce
12396       return
12397       end
12398 C---------------------------------------------------------
12399 C AFM subroutine with pseudoconstant velocity
12400        subroutine AFMvel(Eafmforce)
12401        implicit real*8 (a-h,o-z)
12402       include 'DIMENSIONS'
12403       include 'COMMON.GEO'
12404       include 'COMMON.VAR'
12405       include 'COMMON.LOCAL'
12406       include 'COMMON.CHAIN'
12407       include 'COMMON.DERIV'
12408       include 'COMMON.NAMES'
12409       include 'COMMON.INTERACT'
12410       include 'COMMON.IOUNITS'
12411       include 'COMMON.CALC'
12412       include 'COMMON.CONTROL'
12413       include 'COMMON.SPLITELE'
12414       include 'COMMON.SBRIDGE'
12415       real*8 diffafm(3)
12416 C Only for check grad COMMENT if not used for checkgrad
12417 C      totT=3.0d0
12418 C--------------------------------------------------------
12419 C      print *,"wchodze"
12420       dist=0.0d0
12421       Eafmforce=0.0d0
12422       do i=1,3
12423       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12424       dist=dist+diffafm(i)**2
12425       enddo
12426       dist=dsqrt(dist)
12427       Eafmforce=0.5d0*forceAFMconst
12428      & *(distafminit+totTafm*velAFMconst-dist)**2
12429 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12430       do i=1,3
12431       gradafm(i,afmend-1)=-forceAFMconst*
12432      &(distafminit+totTafm*velAFMconst-dist)
12433      &*diffafm(i)/dist
12434       gradafm(i,afmbeg-1)=forceAFMconst*
12435      &(distafminit+totTafm*velAFMconst-dist)
12436      &*diffafm(i)/dist
12437       enddo
12438 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12439       return
12440       end
12441 C-----------------------------------------------------------
12442 C first for shielding is setting of function of side-chains
12443        subroutine set_shield_fac
12444       implicit real*8 (a-h,o-z)
12445       include 'DIMENSIONS'
12446       include 'COMMON.CHAIN'
12447       include 'COMMON.DERIV'
12448       include 'COMMON.IOUNITS'
12449       include 'COMMON.SHIELD'
12450       include 'COMMON.INTERACT'
12451 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12452       double precision div77_81/0.974996043d0/,
12453      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12454
12455 C the vector between center of side_chain and peptide group
12456        double precision pep_side(3),long,side_calf(3),
12457      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12458      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12459 C the line belowe needs to be changed for FGPROC>1
12460       do i=1,nres-1
12461       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12462       ishield_list(i)=0
12463 Cif there two consequtive dummy atoms there is no peptide group between them
12464 C the line below has to be changed for FGPROC>1
12465       VolumeTotal=0.0
12466       do k=1,nres
12467        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12468        dist_pep_side=0.0
12469        dist_side_calf=0.0
12470        do j=1,3
12471 C first lets set vector conecting the ithe side-chain with kth side-chain
12472       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12473 C      pep_side(j)=2.0d0
12474 C and vector conecting the side-chain with its proper calfa
12475       side_calf(j)=c(j,k+nres)-c(j,k)
12476 C      side_calf(j)=2.0d0
12477       pept_group(j)=c(j,i)-c(j,i+1)
12478 C lets have their lenght
12479       dist_pep_side=pep_side(j)**2+dist_pep_side
12480       dist_side_calf=dist_side_calf+side_calf(j)**2
12481       dist_pept_group=dist_pept_group+pept_group(j)**2
12482       enddo
12483        dist_pep_side=dsqrt(dist_pep_side)
12484        dist_pept_group=dsqrt(dist_pept_group)
12485        dist_side_calf=dsqrt(dist_side_calf)
12486       do j=1,3
12487         pep_side_norm(j)=pep_side(j)/dist_pep_side
12488         side_calf_norm(j)=dist_side_calf
12489       enddo
12490 C now sscale fraction
12491        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12492 C       print *,buff_shield,"buff"
12493 C now sscale
12494         if (sh_frac_dist.le.0.0) cycle
12495 C If we reach here it means that this side chain reaches the shielding sphere
12496 C Lets add him to the list for gradient
12497         ishield_list(i)=ishield_list(i)+1
12498 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12499 C this list is essential otherwise problem would be O3
12500         shield_list(ishield_list(i),i)=k
12501 C Lets have the sscale value
12502         if (sh_frac_dist.gt.1.0) then
12503          scale_fac_dist=1.0d0
12504          do j=1,3
12505          sh_frac_dist_grad(j)=0.0d0
12506          enddo
12507         else
12508          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12509      &                   *(2.0*sh_frac_dist-3.0d0)
12510          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12511      &                  /dist_pep_side/buff_shield*0.5
12512 C remember for the final gradient multiply sh_frac_dist_grad(j)
12513 C for side_chain by factor -2 !
12514          do j=1,3
12515          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12516 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12517 C     &                    sh_frac_dist_grad(j)
12518          enddo
12519         endif
12520 C        if ((i.eq.3).and.(k.eq.2)) then
12521 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12522 C     & ,"TU"
12523 C        endif
12524
12525 C this is what is now we have the distance scaling now volume...
12526       short=short_r_sidechain(itype(k))
12527       long=long_r_sidechain(itype(k))
12528       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12529 C now costhet_grad
12530 C       costhet=0.0d0
12531        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12532 C       costhet_fac=0.0d0
12533        do j=1,3
12534          costhet_grad(j)=costhet_fac*pep_side(j)
12535        enddo
12536 C remember for the final gradient multiply costhet_grad(j)
12537 C for side_chain by factor -2 !
12538 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12539 C pep_side0pept_group is vector multiplication
12540       pep_side0pept_group=0.0
12541       do j=1,3
12542       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12543       enddo
12544       cosalfa=(pep_side0pept_group/
12545      & (dist_pep_side*dist_side_calf))
12546       fac_alfa_sin=1.0-cosalfa**2
12547       fac_alfa_sin=dsqrt(fac_alfa_sin)
12548       rkprim=fac_alfa_sin*(long-short)+short
12549 C now costhet_grad
12550        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12551        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12552
12553        do j=1,3
12554          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12555      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12556      &*(long-short)/fac_alfa_sin*cosalfa/
12557      &((dist_pep_side*dist_side_calf))*
12558      &((side_calf(j))-cosalfa*
12559      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12560
12561         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12562      &*(long-short)/fac_alfa_sin*cosalfa
12563      &/((dist_pep_side*dist_side_calf))*
12564      &(pep_side(j)-
12565      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12566        enddo
12567
12568       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12569      &                    /VSolvSphere_div
12570      &                    *wshield
12571 C now the gradient...
12572 C grad_shield is gradient of Calfa for peptide groups
12573 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12574 C     &               costhet,cosphi
12575 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12576 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12577       do j=1,3
12578       grad_shield(j,i)=grad_shield(j,i)
12579 C gradient po skalowaniu
12580      &                +(sh_frac_dist_grad(j)
12581 C  gradient po costhet
12582      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12583      &-scale_fac_dist*(cosphi_grad_long(j))
12584      &/(1.0-cosphi) )*div77_81
12585      &*VofOverlap
12586 C grad_shield_side is Cbeta sidechain gradient
12587       grad_shield_side(j,ishield_list(i),i)=
12588      &        (sh_frac_dist_grad(j)*(-2.0d0)
12589      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12590      &       +scale_fac_dist*(cosphi_grad_long(j))
12591      &        *2.0d0/(1.0-cosphi))
12592      &        *div77_81*VofOverlap
12593
12594        grad_shield_loc(j,ishield_list(i),i)=
12595      &   scale_fac_dist*cosphi_grad_loc(j)
12596      &        *2.0d0/(1.0-cosphi)
12597      &        *div77_81*VofOverlap
12598       enddo
12599       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12600       enddo
12601       fac_shield(i)=VolumeTotal*div77_81+div4_81
12602 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12603       enddo
12604       return
12605       end
12606 C--------------------------------------------------------------------------
12607       double precision function tschebyshev(m,n,x,y)
12608       implicit none
12609       include "DIMENSIONS"
12610       integer i,m,n
12611       double precision x(n),y,yy(0:maxvar),aux
12612 c Tschebyshev polynomial. Note that the first term is omitted
12613 c m=0: the constant term is included
12614 c m=1: the constant term is not included
12615       yy(0)=1.0d0
12616       yy(1)=y
12617       do i=2,n
12618         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12619       enddo
12620       aux=0.0d0
12621       do i=m,n
12622         aux=aux+x(i)*yy(i)
12623       enddo
12624       tschebyshev=aux
12625       return
12626       end
12627 C--------------------------------------------------------------------------
12628       double precision function gradtschebyshev(m,n,x,y)
12629       implicit none
12630       include "DIMENSIONS"
12631       integer i,m,n
12632       double precision x(n+1),y,yy(0:maxvar),aux
12633 c Tschebyshev polynomial. Note that the first term is omitted
12634 c m=0: the constant term is included
12635 c m=1: the constant term is not included
12636       yy(0)=1.0d0
12637       yy(1)=2.0d0*y
12638       do i=2,n
12639         yy(i)=2*y*yy(i-1)-yy(i-2)
12640       enddo
12641       aux=0.0d0
12642       do i=m,n
12643         aux=aux+x(i+1)*yy(i)*(i+1)
12644 C        print *, x(i+1),yy(i),i
12645       enddo
12646       gradtschebyshev=aux
12647       return
12648       end
12649 C------------------------------------------------------------------------
12650 C first for shielding is setting of function of side-chains
12651        subroutine set_shield_fac2
12652       implicit real*8 (a-h,o-z)
12653       include 'DIMENSIONS'
12654       include 'COMMON.CHAIN'
12655       include 'COMMON.DERIV'
12656       include 'COMMON.IOUNITS'
12657       include 'COMMON.SHIELD'
12658       include 'COMMON.INTERACT'
12659 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12660       double precision div77_81/0.974996043d0/,
12661      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12662
12663 C the vector between center of side_chain and peptide group
12664        double precision pep_side(3),long,side_calf(3),
12665      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12666      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12667 C the line belowe needs to be changed for FGPROC>1
12668       do i=1,nres-1
12669       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12670       ishield_list(i)=0
12671 Cif there two consequtive dummy atoms there is no peptide group between them
12672 C the line below has to be changed for FGPROC>1
12673       VolumeTotal=0.0
12674       do k=1,nres
12675        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12676        dist_pep_side=0.0
12677        dist_side_calf=0.0
12678        do j=1,3
12679 C first lets set vector conecting the ithe side-chain with kth side-chain
12680       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12681 C      pep_side(j)=2.0d0
12682 C and vector conecting the side-chain with its proper calfa
12683       side_calf(j)=c(j,k+nres)-c(j,k)
12684 C      side_calf(j)=2.0d0
12685       pept_group(j)=c(j,i)-c(j,i+1)
12686 C lets have their lenght
12687       dist_pep_side=pep_side(j)**2+dist_pep_side
12688       dist_side_calf=dist_side_calf+side_calf(j)**2
12689       dist_pept_group=dist_pept_group+pept_group(j)**2
12690       enddo
12691        dist_pep_side=dsqrt(dist_pep_side)
12692        dist_pept_group=dsqrt(dist_pept_group)
12693        dist_side_calf=dsqrt(dist_side_calf)
12694       do j=1,3
12695         pep_side_norm(j)=pep_side(j)/dist_pep_side
12696         side_calf_norm(j)=dist_side_calf
12697       enddo
12698 C now sscale fraction
12699        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12700 C       print *,buff_shield,"buff"
12701 C now sscale
12702         if (sh_frac_dist.le.0.0) cycle
12703 C If we reach here it means that this side chain reaches the shielding sphere
12704 C Lets add him to the list for gradient
12705         ishield_list(i)=ishield_list(i)+1
12706 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12707 C this list is essential otherwise problem would be O3
12708         shield_list(ishield_list(i),i)=k
12709 C Lets have the sscale value
12710         if (sh_frac_dist.gt.1.0) then
12711          scale_fac_dist=1.0d0
12712          do j=1,3
12713          sh_frac_dist_grad(j)=0.0d0
12714          enddo
12715         else
12716          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12717      &                   *(2.0d0*sh_frac_dist-3.0d0)
12718          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12719      &                  /dist_pep_side/buff_shield*0.5d0
12720 C remember for the final gradient multiply sh_frac_dist_grad(j)
12721 C for side_chain by factor -2 !
12722          do j=1,3
12723          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12724 C         sh_frac_dist_grad(j)=0.0d0
12725 C         scale_fac_dist=1.0d0
12726 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12727 C     &                    sh_frac_dist_grad(j)
12728          enddo
12729         endif
12730 C this is what is now we have the distance scaling now volume...
12731       short=short_r_sidechain(itype(k))
12732       long=long_r_sidechain(itype(k))
12733       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12734       sinthet=short/dist_pep_side*costhet
12735 C now costhet_grad
12736 C       costhet=0.6d0
12737 C       sinthet=0.8
12738        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12739 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12740 C     &             -short/dist_pep_side**2/costhet)
12741 C       costhet_fac=0.0d0
12742        do j=1,3
12743          costhet_grad(j)=costhet_fac*pep_side(j)
12744        enddo
12745 C remember for the final gradient multiply costhet_grad(j)
12746 C for side_chain by factor -2 !
12747 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12748 C pep_side0pept_group is vector multiplication
12749       pep_side0pept_group=0.0d0
12750       do j=1,3
12751       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12752       enddo
12753       cosalfa=(pep_side0pept_group/
12754      & (dist_pep_side*dist_side_calf))
12755       fac_alfa_sin=1.0d0-cosalfa**2
12756       fac_alfa_sin=dsqrt(fac_alfa_sin)
12757       rkprim=fac_alfa_sin*(long-short)+short
12758 C      rkprim=short
12759
12760 C now costhet_grad
12761        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12762 C       cosphi=0.6
12763        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12764        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12765      &      dist_pep_side**2)
12766 C       sinphi=0.8
12767        do j=1,3
12768          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12769      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12770      &*(long-short)/fac_alfa_sin*cosalfa/
12771      &((dist_pep_side*dist_side_calf))*
12772      &((side_calf(j))-cosalfa*
12773      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12774 C       cosphi_grad_long(j)=0.0d0
12775         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12776      &*(long-short)/fac_alfa_sin*cosalfa
12777      &/((dist_pep_side*dist_side_calf))*
12778      &(pep_side(j)-
12779      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12780 C       cosphi_grad_loc(j)=0.0d0
12781        enddo
12782 C      print *,sinphi,sinthet
12783 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12784 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12785       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12786      &                    /VSolvSphere_div
12787 C     &                    *wshield
12788 C now the gradient...
12789       do j=1,3
12790       grad_shield(j,i)=grad_shield(j,i)
12791 C gradient po skalowaniu
12792      &                +(sh_frac_dist_grad(j)*VofOverlap
12793 C  gradient po costhet
12794      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12795      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12796      &       sinphi/sinthet*costhet*costhet_grad(j)
12797      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12798      & )*wshield
12799 C grad_shield_side is Cbeta sidechain gradient
12800       grad_shield_side(j,ishield_list(i),i)=
12801      &        (sh_frac_dist_grad(j)*(-2.0d0)
12802      &        *VofOverlap
12803      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12804      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12805      &       sinphi/sinthet*costhet*costhet_grad(j)
12806      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12807      &       )*wshield
12808
12809        grad_shield_loc(j,ishield_list(i),i)=
12810      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12811      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12812      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12813      &        ))
12814      &        *wshield
12815       enddo
12816 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12817 c     & scale_fac_dist
12818       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12819       enddo
12820       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12821 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12822 c     &  " wshield",wshield
12823 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12824       enddo
12825       return
12826       end
12827 C-----------------------------------------------------------------------
12828 C-----------------------------------------------------------
12829 C This subroutine is to mimic the histone like structure but as well can be
12830 C utilizet to nanostructures (infinit) small modification has to be used to
12831 C make it finite (z gradient at the ends has to be changes as well as the x,y
12832 C gradient has to be modified at the ends
12833 C The energy function is Kihara potential
12834 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12835 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12836 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12837 C simple Kihara potential
12838       subroutine calctube(Etube)
12839        implicit real*8 (a-h,o-z)
12840       include 'DIMENSIONS'
12841       include 'COMMON.GEO'
12842       include 'COMMON.VAR'
12843       include 'COMMON.LOCAL'
12844       include 'COMMON.CHAIN'
12845       include 'COMMON.DERIV'
12846       include 'COMMON.NAMES'
12847       include 'COMMON.INTERACT'
12848       include 'COMMON.IOUNITS'
12849       include 'COMMON.CALC'
12850       include 'COMMON.CONTROL'
12851       include 'COMMON.SPLITELE'
12852       include 'COMMON.SBRIDGE'
12853       double precision tub_r,vectube(3),enetube(maxres*2)
12854       Etube=0.0d0
12855       do i=1,2*nres
12856         enetube(i)=0.0d0
12857       enddo
12858 C first we calculate the distance from tube center
12859 C first sugare-phosphate group for NARES this would be peptide group
12860 C for UNRES
12861       do i=1,nres
12862 C lets ommit dummy atoms for now
12863        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12864 C now calculate distance from center of tube and direction vectors
12865       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12866           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12867       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12868           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12869       vectube(1)=vectube(1)-tubecenter(1)
12870       vectube(2)=vectube(2)-tubecenter(2)
12871
12872 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12873 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12874
12875 C as the tube is infinity we do not calculate the Z-vector use of Z
12876 C as chosen axis
12877       vectube(3)=0.0d0
12878 C now calculte the distance
12879        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12880 C now normalize vector
12881       vectube(1)=vectube(1)/tub_r
12882       vectube(2)=vectube(2)/tub_r
12883 C calculte rdiffrence between r and r0
12884       rdiff=tub_r-tubeR0
12885 C and its 6 power
12886       rdiff6=rdiff**6.0d0
12887 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12888        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12889 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12890 C       print *,rdiff,rdiff6,pep_aa_tube
12891 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12892 C now we calculate gradient
12893        fac=(-12.0d0*pep_aa_tube/rdiff6+
12894      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12895 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12896 C     &rdiff,fac
12897
12898 C now direction of gg_tube vector
12899         do j=1,3
12900         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12901         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12902         enddo
12903         enddo
12904 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12905         do i=1,nres
12906 C Lets not jump over memory as we use many times iti
12907          iti=itype(i)
12908 C lets ommit dummy atoms for now
12909          if ((iti.eq.ntyp1)
12910 C in UNRES uncomment the line below as GLY has no side-chain...
12911 C      .or.(iti.eq.10)
12912      &   ) cycle
12913           vectube(1)=c(1,i+nres)
12914           vectube(1)=mod(vectube(1),boxxsize)
12915           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12916           vectube(2)=c(2,i+nres)
12917           vectube(2)=mod(vectube(2),boxxsize)
12918           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12919
12920       vectube(1)=vectube(1)-tubecenter(1)
12921       vectube(2)=vectube(2)-tubecenter(2)
12922
12923 C as the tube is infinity we do not calculate the Z-vector use of Z
12924 C as chosen axis
12925       vectube(3)=0.0d0
12926 C now calculte the distance
12927        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12928 C now normalize vector
12929       vectube(1)=vectube(1)/tub_r
12930       vectube(2)=vectube(2)/tub_r
12931 C calculte rdiffrence between r and r0
12932       rdiff=tub_r-tubeR0
12933 C and its 6 power
12934       rdiff6=rdiff**6.0d0
12935 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12936        sc_aa_tube=sc_aa_tube_par(iti)
12937        sc_bb_tube=sc_bb_tube_par(iti)
12938        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12939 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12940 C now we calculate gradient
12941        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12942      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12943 C now direction of gg_tube vector
12944          do j=1,3
12945           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12946           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12947          enddo
12948         enddo
12949         do i=1,2*nres
12950           Etube=Etube+enetube(i)
12951         enddo
12952 C        print *,"ETUBE", etube
12953         return
12954         end
12955 C TO DO 1) add to total energy
12956 C       2) add to gradient summation
12957 C       3) add reading parameters (AND of course oppening of PARAM file)
12958 C       4) add reading the center of tube
12959 C       5) add COMMONs
12960 C       6) add to zerograd
12961
12962 C-----------------------------------------------------------------------
12963 C-----------------------------------------------------------
12964 C This subroutine is to mimic the histone like structure but as well can be
12965 C utilizet to nanostructures (infinit) small modification has to be used to
12966 C make it finite (z gradient at the ends has to be changes as well as the x,y
12967 C gradient has to be modified at the ends
12968 C The energy function is Kihara potential
12969 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12970 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12971 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12972 C simple Kihara potential
12973       subroutine calctube2(Etube)
12974        implicit real*8 (a-h,o-z)
12975       include 'DIMENSIONS'
12976       include 'COMMON.GEO'
12977       include 'COMMON.VAR'
12978       include 'COMMON.LOCAL'
12979       include 'COMMON.CHAIN'
12980       include 'COMMON.DERIV'
12981       include 'COMMON.NAMES'
12982       include 'COMMON.INTERACT'
12983       include 'COMMON.IOUNITS'
12984       include 'COMMON.CALC'
12985       include 'COMMON.CONTROL'
12986       include 'COMMON.SPLITELE'
12987       include 'COMMON.SBRIDGE'
12988       double precision tub_r,vectube(3),enetube(maxres*2)
12989       Etube=0.0d0
12990       do i=1,2*nres
12991         enetube(i)=0.0d0
12992       enddo
12993 C first we calculate the distance from tube center
12994 C first sugare-phosphate group for NARES this would be peptide group
12995 C for UNRES
12996       do i=1,nres
12997 C lets ommit dummy atoms for now
12998        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12999 C now calculate distance from center of tube and direction vectors
13000       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
13001           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
13002       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
13003           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
13004       vectube(1)=vectube(1)-tubecenter(1)
13005       vectube(2)=vectube(2)-tubecenter(2)
13006
13007 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
13008 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
13009
13010 C as the tube is infinity we do not calculate the Z-vector use of Z
13011 C as chosen axis
13012       vectube(3)=0.0d0
13013 C now calculte the distance
13014        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13015 C now normalize vector
13016       vectube(1)=vectube(1)/tub_r
13017       vectube(2)=vectube(2)/tub_r
13018 C calculte rdiffrence between r and r0
13019       rdiff=tub_r-tubeR0
13020 C and its 6 power
13021       rdiff6=rdiff**6.0d0
13022 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13023        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
13024 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
13025 C       print *,rdiff,rdiff6,pep_aa_tube
13026 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13027 C now we calculate gradient
13028        fac=(-12.0d0*pep_aa_tube/rdiff6+
13029      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
13030 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
13031 C     &rdiff,fac
13032
13033 C now direction of gg_tube vector
13034         do j=1,3
13035         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
13036         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
13037         enddo
13038         enddo
13039 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
13040         do i=1,nres
13041 C Lets not jump over memory as we use many times iti
13042          iti=itype(i)
13043 C lets ommit dummy atoms for now
13044          if ((iti.eq.ntyp1)
13045 C in UNRES uncomment the line below as GLY has no side-chain...
13046      &      .or.(iti.eq.10)
13047      &   ) cycle
13048           vectube(1)=c(1,i+nres)
13049           vectube(1)=mod(vectube(1),boxxsize)
13050           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
13051           vectube(2)=c(2,i+nres)
13052           vectube(2)=mod(vectube(2),boxxsize)
13053           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
13054
13055       vectube(1)=vectube(1)-tubecenter(1)
13056       vectube(2)=vectube(2)-tubecenter(2)
13057 C THIS FRAGMENT MAKES TUBE FINITE
13058         positi=(mod(c(3,i+nres),boxzsize))
13059         if (positi.le.0) positi=positi+boxzsize
13060 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
13061 c for each residue check if it is in lipid or lipid water border area
13062 C       respos=mod(c(3,i+nres),boxzsize)
13063        print *,positi,bordtubebot,buftubebot,bordtubetop
13064        if ((positi.gt.bordtubebot)
13065      & .and.(positi.lt.bordtubetop)) then
13066 C the energy transfer exist
13067         if (positi.lt.buftubebot) then
13068          fracinbuf=1.0d0-
13069      &     ((positi-bordtubebot)/tubebufthick)
13070 C lipbufthick is thickenes of lipid buffore
13071          sstube=sscalelip(fracinbuf)
13072          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
13073          print *,ssgradtube, sstube,tubetranene(itype(i))
13074          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13075          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13076      &+ssgradtube*tubetranene(itype(i))
13077          gg_tube(3,i-1)= gg_tube(3,i-1)
13078      &+ssgradtube*tubetranene(itype(i))
13079 C         print *,"doing sccale for lower part"
13080         elseif (positi.gt.buftubetop) then
13081          fracinbuf=1.0d0-
13082      &((bordtubetop-positi)/tubebufthick)
13083          sstube=sscalelip(fracinbuf)
13084          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
13085          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13086 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
13087 C     &+ssgradtube*tubetranene(itype(i))
13088 C         gg_tube(3,i-1)= gg_tube(3,i-1)
13089 C     &+ssgradtube*tubetranene(itype(i))
13090 C          print *, "doing sscalefor top part",sslip,fracinbuf
13091         else
13092          sstube=1.0d0
13093          ssgradtube=0.0d0
13094          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13095 C         print *,"I am in true lipid"
13096         endif
13097         else
13098 C          sstube=0.0d0
13099 C          ssgradtube=0.0d0
13100         cycle
13101         endif ! if in lipid or buffor
13102 CEND OF FINITE FRAGMENT
13103 C as the tube is infinity we do not calculate the Z-vector use of Z
13104 C as chosen axis
13105       vectube(3)=0.0d0
13106 C now calculte the distance
13107        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13108 C now normalize vector
13109       vectube(1)=vectube(1)/tub_r
13110       vectube(2)=vectube(2)/tub_r
13111 C calculte rdiffrence between r and r0
13112       rdiff=tub_r-tubeR0
13113 C and its 6 power
13114       rdiff6=rdiff**6.0d0
13115 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13116        sc_aa_tube=sc_aa_tube_par(iti)
13117        sc_bb_tube=sc_bb_tube_par(iti)
13118        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13119      &                 *sstube+enetube(i+nres)
13120 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13121 C now we calculate gradient
13122        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13123      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13124 C now direction of gg_tube vector
13125          do j=1,3
13126           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13127           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13128          enddo
13129          gg_tube_SC(3,i)=gg_tube_SC(3,i)
13130      &+ssgradtube*enetube(i+nres)/sstube
13131          gg_tube(3,i-1)= gg_tube(3,i-1)
13132      &+ssgradtube*enetube(i+nres)/sstube
13133
13134         enddo
13135         do i=1,2*nres
13136           Etube=Etube+enetube(i)
13137         enddo
13138 C        print *,"ETUBE", etube
13139         return
13140         end
13141 C TO DO 1) add to total energy
13142 C       2) add to gradient summation
13143 C       3) add reading parameters (AND of course oppening of PARAM file)
13144 C       4) add reading the center of tube
13145 C       5) add COMMONs
13146 C       6) add to zerograd
13147 c----------------------------------------------------------------------------
13148       subroutine e_saxs(Esaxs_constr)
13149       implicit none
13150       include 'DIMENSIONS'
13151 #ifdef MPI
13152       include "mpif.h"
13153       include "COMMON.SETUP"
13154       integer IERR
13155 #endif
13156       include 'COMMON.SBRIDGE'
13157       include 'COMMON.CHAIN'
13158       include 'COMMON.GEO'
13159       include 'COMMON.DERIV'
13160       include 'COMMON.LOCAL'
13161       include 'COMMON.INTERACT'
13162       include 'COMMON.VAR'
13163       include 'COMMON.IOUNITS'
13164 c      include 'COMMON.MD'
13165 #ifdef LANG0
13166 #ifdef FIVEDIAG
13167       include 'COMMON.LANGEVIN.lang0.5diag'
13168 #else
13169       include 'COMMON.LANGEVIN.lang0'
13170 #endif
13171 #else
13172       include 'COMMON.LANGEVIN'
13173 #endif
13174       include 'COMMON.CONTROL'
13175       include 'COMMON.SAXS'
13176       include 'COMMON.NAMES'
13177       include 'COMMON.TIME1'
13178       include 'COMMON.FFIELD'
13179 c
13180       double precision Esaxs_constr
13181       integer i,iint,j,k,l
13182       double precision PgradC(maxSAXS,3,maxres),
13183      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13184 #ifdef MPI
13185       double precision PgradC_(maxSAXS,3,maxres),
13186      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13187 #endif
13188       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13189      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13190      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13191      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13192       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13193       double precision dist,mygauss,mygaussder
13194       external dist
13195       integer llicz,lllicz
13196       double precision time01
13197 c  SAXS restraint penalty function
13198 #ifdef DEBUG
13199       write(iout,*) "------- SAXS penalty function start -------"
13200       write (iout,*) "nsaxs",nsaxs
13201       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13202       write (iout,*) "Psaxs"
13203       do i=1,nsaxs
13204         write (iout,'(i5,e15.5)') i, Psaxs(i)
13205       enddo
13206 #endif
13207 #ifdef TIMING
13208       time01=MPI_Wtime()
13209 #endif
13210       Esaxs_constr = 0.0d0
13211       do k=1,nsaxs
13212         Pcalc(k)=0.0d0
13213         do j=1,nres
13214           do l=1,3
13215             PgradC(k,l,j)=0.0d0
13216             PgradX(k,l,j)=0.0d0
13217           enddo
13218         enddo
13219       enddo
13220 c      lllicz=0
13221       do i=iatsc_s,iatsc_e
13222        if (itype(i).eq.ntyp1) cycle
13223        do iint=1,nint_gr(i)
13224          do j=istart(i,iint),iend(i,iint)
13225            if (itype(j).eq.ntyp1) cycle
13226 #ifdef ALLSAXS
13227            dijCACA=dist(i,j)
13228            dijCASC=dist(i,j+nres)
13229            dijSCCA=dist(i+nres,j)
13230            dijSCSC=dist(i+nres,j+nres)
13231            sigma2CACA=2.0d0/(pstok**2)
13232            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13233            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13234            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13235            do k=1,nsaxs
13236              dk = distsaxs(k)
13237              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13238              if (itype(j).ne.10) then
13239              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13240              else
13241              endif
13242              expCASC = 0.0d0
13243              if (itype(i).ne.10) then
13244              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13245              else
13246              expSCCA = 0.0d0
13247              endif
13248              if (itype(i).ne.10 .and. itype(j).ne.10) then
13249              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13250              else
13251              expSCSC = 0.0d0
13252              endif
13253              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13254 #ifdef DEBUG
13255              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13256 #endif
13257              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13258              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13259              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13260              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13261              do l=1,3
13262 c CA CA
13263                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13264                PgradC(k,l,i) = PgradC(k,l,i)-aux
13265                PgradC(k,l,j) = PgradC(k,l,j)+aux
13266 c CA SC
13267                if (itype(j).ne.10) then
13268                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13269                PgradC(k,l,i) = PgradC(k,l,i)-aux
13270                PgradC(k,l,j) = PgradC(k,l,j)+aux
13271                PgradX(k,l,j) = PgradX(k,l,j)+aux
13272                endif
13273 c SC CA
13274                if (itype(i).ne.10) then
13275                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13276                PgradX(k,l,i) = PgradX(k,l,i)-aux
13277                PgradC(k,l,i) = PgradC(k,l,i)-aux
13278                PgradC(k,l,j) = PgradC(k,l,j)+aux
13279                endif
13280 c SC SC
13281                if (itype(i).ne.10 .and. itype(j).ne.10) then
13282                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13283                PgradC(k,l,i) = PgradC(k,l,i)-aux
13284                PgradC(k,l,j) = PgradC(k,l,j)+aux
13285                PgradX(k,l,i) = PgradX(k,l,i)-aux
13286                PgradX(k,l,j) = PgradX(k,l,j)+aux
13287                endif
13288              enddo ! l
13289            enddo ! k
13290 #else
13291            dijCACA=dist(i,j)
13292            sigma2CACA=scal_rad**2*0.25d0/
13293      &        (restok(itype(j))**2+restok(itype(i))**2)
13294 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13295 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13296 #ifdef MYGAUSS
13297            sigmaCACA=dsqrt(sigma2CACA)
13298            threesig=3.0d0/sigmaCACA
13299 c           llicz=0
13300            do k=1,nsaxs
13301              dk = distsaxs(k)
13302              if (dabs(dijCACA-dk).ge.threesig) cycle
13303 c             llicz=llicz+1
13304 c             lllicz=lllicz+1
13305              aux = sigmaCACA*(dijCACA-dk)
13306              expCACA = mygauss(aux)
13307 c             if (expcaca.eq.0.0d0) cycle
13308              Pcalc(k) = Pcalc(k)+expCACA
13309              CACAgrad = -sigmaCACA*mygaussder(aux)
13310 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13311              do l=1,3
13312                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13313                PgradC(k,l,i) = PgradC(k,l,i)-aux
13314                PgradC(k,l,j) = PgradC(k,l,j)+aux
13315              enddo ! l
13316            enddo ! k
13317 c           write (iout,*) "i",i," j",j," llicz",llicz
13318 #else
13319            IF (saxs_cutoff.eq.0) THEN
13320            do k=1,nsaxs
13321              dk = distsaxs(k)
13322              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13323              Pcalc(k) = Pcalc(k)+expCACA
13324              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13325              do l=1,3
13326                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13327                PgradC(k,l,i) = PgradC(k,l,i)-aux
13328                PgradC(k,l,j) = PgradC(k,l,j)+aux
13329              enddo ! l
13330            enddo ! k
13331            ELSE
13332            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13333            do k=1,nsaxs
13334              dk = distsaxs(k)
13335 c             write (2,*) "ijk",i,j,k
13336              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13337              if (sss2.eq.0.0d0) cycle
13338              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13339              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13340      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13341      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13342      &           sss2,ssgrad2
13343              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13344              Pcalc(k) = Pcalc(k)+expCACA
13345 #ifdef DEBUG
13346              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13347 #endif
13348              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13349      &             ssgrad2*expCACA/sss2
13350              do l=1,3
13351 c CA CA
13352                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13353                PgradC(k,l,i) = PgradC(k,l,i)+aux
13354                PgradC(k,l,j) = PgradC(k,l,j)-aux
13355              enddo ! l
13356            enddo ! k
13357            ENDIF
13358 #endif
13359 #endif
13360          enddo ! j
13361        enddo ! iint
13362       enddo ! i
13363 c#ifdef TIMING
13364 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13365 c#endif
13366 c      write (iout,*) "lllicz",lllicz
13367 c#ifdef TIMING
13368 c      time01=MPI_Wtime()
13369 c#endif
13370 #ifdef MPI
13371       if (nfgtasks.gt.1) then
13372        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13373      &    MPI_SUM,FG_COMM,IERR)
13374 c        if (fg_rank.eq.king) then
13375           do k=1,nsaxs
13376             Pcalc(k) = Pcalc_(k)
13377           enddo
13378 c        endif
13379 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13380 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13381 c        if (fg_rank.eq.king) then
13382 c          do i=1,nres
13383 c            do l=1,3
13384 c              do k=1,nsaxs
13385 c                PgradC(k,l,i) = PgradC_(k,l,i)
13386 c              enddo
13387 c            enddo
13388 c          enddo
13389 c        endif
13390 #ifdef ALLSAXS
13391 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13392 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13393 c        if (fg_rank.eq.king) then
13394 c          do i=1,nres
13395 c            do l=1,3
13396 c              do k=1,nsaxs
13397 c                PgradX(k,l,i) = PgradX_(k,l,i)
13398 c              enddo
13399 c            enddo
13400 c          enddo
13401 c        endif
13402 #endif
13403       endif
13404 #endif
13405       Cnorm = 0.0d0
13406       do k=1,nsaxs
13407         Cnorm = Cnorm + Pcalc(k)
13408       enddo
13409 #ifdef MPI
13410       if (fg_rank.eq.king) then
13411 #endif
13412       Esaxs_constr = dlog(Cnorm)-wsaxs0
13413       do k=1,nsaxs
13414         if (Pcalc(k).gt.0.0d0)
13415      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13416 #ifdef DEBUG
13417         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13418 #endif
13419       enddo
13420 #ifdef DEBUG
13421       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13422 #endif
13423 #ifdef MPI
13424       endif
13425 #endif
13426       gsaxsC=0.0d0
13427       gsaxsX=0.0d0
13428       do i=nnt,nct
13429         do l=1,3
13430           auxC=0.0d0
13431           auxC1=0.0d0
13432           auxX=0.0d0
13433           auxX1=0.d0
13434           do k=1,nsaxs
13435             if (Pcalc(k).gt.0)
13436      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13437             auxC1 = auxC1+PgradC(k,l,i)
13438 #ifdef ALLSAXS
13439             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13440             auxX1 = auxX1+PgradX(k,l,i)
13441 #endif
13442           enddo
13443           gsaxsC(l,i) = auxC - auxC1/Cnorm
13444 #ifdef ALLSAXS
13445           gsaxsX(l,i) = auxX - auxX1/Cnorm
13446 #endif
13447 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13448 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13449 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13450 c     *     " gradX",wsaxs*gsaxsX(l,i)
13451         enddo
13452       enddo
13453 #ifdef TIMING
13454       time_SAXS=time_SAXS+MPI_Wtime()-time01
13455 #endif
13456 #ifdef DEBUG
13457       write (iout,*) "gsaxsc"
13458       do i=nnt,nct
13459         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13460       enddo
13461 #endif
13462 #ifdef MPI
13463 c      endif
13464 #endif
13465       return
13466       end
13467 c----------------------------------------------------------------------------
13468       subroutine e_saxsC(Esaxs_constr)
13469       implicit none
13470       include 'DIMENSIONS'
13471 #ifdef MPI
13472       include "mpif.h"
13473       include "COMMON.SETUP"
13474       integer IERR
13475 #endif
13476       include 'COMMON.SBRIDGE'
13477       include 'COMMON.CHAIN'
13478       include 'COMMON.GEO'
13479       include 'COMMON.DERIV'
13480       include 'COMMON.LOCAL'
13481       include 'COMMON.INTERACT'
13482       include 'COMMON.VAR'
13483       include 'COMMON.IOUNITS'
13484 c      include 'COMMON.MD'
13485 #ifdef LANG0
13486 #ifdef FIVEDIAG
13487       include 'COMMON.LANGEVIN.lang0.5diag'
13488 #else
13489       include 'COMMON.LANGEVIN.lang0'
13490 #endif
13491 #else
13492       include 'COMMON.LANGEVIN'
13493 #endif
13494       include 'COMMON.CONTROL'
13495       include 'COMMON.SAXS'
13496       include 'COMMON.NAMES'
13497       include 'COMMON.TIME1'
13498       include 'COMMON.FFIELD'
13499 c
13500       double precision Esaxs_constr
13501       integer i,iint,j,k,l
13502       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13503 #ifdef MPI
13504       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13505 #endif
13506       double precision dk,dijCASPH,dijSCSPH,
13507      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13508      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13509      & auxX,auxX1,Cnorm
13510 c  SAXS restraint penalty function
13511 #ifdef DEBUG
13512       write(iout,*) "------- SAXS penalty function start -------"
13513       write (iout,*) "nsaxs",nsaxs
13514
13515       do i=nnt,nct
13516         print *,MyRank,"C",i,(C(j,i),j=1,3)
13517       enddo
13518       do i=nnt,nct
13519         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13520       enddo
13521 #endif
13522       Esaxs_constr = 0.0d0
13523       logPtot=0.0d0
13524       do j=isaxs_start,isaxs_end
13525         Pcalc=0.0d0
13526         do i=1,nres
13527           do l=1,3
13528             PgradC(l,i)=0.0d0
13529             PgradX(l,i)=0.0d0
13530           enddo
13531         enddo
13532         do i=nnt,nct
13533           if (itype(i).eq.ntyp1) cycle
13534           dijCASPH=0.0d0
13535           dijSCSPH=0.0d0
13536           do l=1,3
13537             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13538           enddo
13539           if (itype(i).ne.10) then
13540           do l=1,3
13541             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13542           enddo
13543           endif
13544           sigma2CA=2.0d0/pstok**2
13545           sigma2SC=4.0d0/restok(itype(i))**2
13546           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13547           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13548           Pcalc = Pcalc+expCASPH+expSCSPH
13549 #ifdef DEBUG
13550           write(*,*) "processor i j Pcalc",
13551      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13552 #endif
13553           CASPHgrad = sigma2CA*expCASPH
13554           SCSPHgrad = sigma2SC*expSCSPH
13555           do l=1,3
13556             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13557             PgradX(l,i) = PgradX(l,i) + aux
13558             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13559           enddo ! l
13560         enddo ! i
13561         do i=nnt,nct
13562           do l=1,3
13563             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13564             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13565           enddo
13566         enddo
13567         logPtot = logPtot - dlog(Pcalc)
13568 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13569 c     &    " logPtot",logPtot
13570       enddo ! j
13571 #ifdef MPI
13572       if (nfgtasks.gt.1) then
13573 c        write (iout,*) "logPtot before reduction",logPtot
13574         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13575      &    MPI_SUM,king,FG_COMM,IERR)
13576         logPtot = logPtot_
13577 c        write (iout,*) "logPtot after reduction",logPtot
13578         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13579      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13580         if (fg_rank.eq.king) then
13581           do i=1,nres
13582             do l=1,3
13583               gsaxsC(l,i) = gsaxsC_(l,i)
13584             enddo
13585           enddo
13586         endif
13587         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13588      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13589         if (fg_rank.eq.king) then
13590           do i=1,nres
13591             do l=1,3
13592               gsaxsX(l,i) = gsaxsX_(l,i)
13593             enddo
13594           enddo
13595         endif
13596       endif
13597 #endif
13598       Esaxs_constr = logPtot
13599       return
13600       end
13601 c----------------------------------------------------------------------------
13602       double precision function sscale2(r,r_cut,r0,rlamb)
13603       implicit none
13604       double precision r,gamm,r_cut,r0,rlamb,rr
13605       rr = dabs(r-r0)
13606 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13607 c      write (2,*) "rr",rr
13608       if(rr.lt.r_cut-rlamb) then
13609         sscale2=1.0d0
13610       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13611         gamm=(rr-(r_cut-rlamb))/rlamb
13612         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13613       else
13614         sscale2=0d0
13615       endif
13616       return
13617       end
13618 C-----------------------------------------------------------------------
13619       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13620       implicit none
13621       double precision r,gamm,r_cut,r0,rlamb,rr
13622       rr = dabs(r-r0)
13623       if(rr.lt.r_cut-rlamb) then
13624         sscalgrad2=0.0d0
13625       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13626         gamm=(rr-(r_cut-rlamb))/rlamb
13627         if (r.ge.r0) then
13628           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13629         else
13630           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13631         endif
13632       else
13633         sscalgrad2=0.0d0
13634       endif
13635       return
13636       end