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       double precision time01
  41 #ifdef MPI
  42 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  43 c     & " nfgtasks",nfgtasks
  44       if (nfgtasks.gt.1) then
  45         time00=MPI_Wtime()
  46 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  47         if (fg_rank.eq.0) then
  48           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  49 c          print *,"Processor",myrank," BROADCAST iorder"
  50 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  51 C FG slaves as WEIGHTS array.
  52           weights_(1)=wsc
  53           weights_(2)=wscp
  54           weights_(3)=welec
  55           weights_(4)=wcorr
  56           weights_(5)=wcorr5
  57           weights_(6)=wcorr6
  58           weights_(7)=wel_loc
  59           weights_(8)=wturn3
  60           weights_(9)=wturn4
  61           weights_(10)=wturn6
  62           weights_(11)=wang
  63           weights_(12)=wscloc
  64           weights_(13)=wtor
  65           weights_(14)=wtor_d
  66           weights_(15)=wstrain
  67           weights_(16)=wvdwpp
  68           weights_(17)=wbond
  69           weights_(18)=scal14
  70           weights_(21)=wsccor
  71           weights_(22)=wliptran
  72           weights_(25)=wtube
  73           weights_(26)=wsaxs
  74           weights_(28)=wdfa_dist
  75           weights_(29)=wdfa_tor
  76           weights_(30)=wdfa_nei
  77           weights_(31)=wdfa_beta
  78 C FG Master broadcasts the WEIGHTS_ array
  79           call MPI_Bcast(weights_(1),n_ene,
  80      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  81         else
  82 C FG slaves receive the WEIGHTS array
  83           call MPI_Bcast(weights(1),n_ene,
  84      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  85           wsc=weights(1)
  86           wscp=weights(2)
  87           welec=weights(3)
  88           wcorr=weights(4)
  89           wcorr5=weights(5)
  90           wcorr6=weights(6)
  91           wel_loc=weights(7)
  92           wturn3=weights(8)
  93           wturn4=weights(9)
  94           wturn6=weights(10)
  95           wang=weights(11)
  96           wscloc=weights(12)
  97           wtor=weights(13)
  98           wtor_d=weights(14)
  99           wstrain=weights(15)
 100           wvdwpp=weights(16)
 101           wbond=weights(17)
 102           scal14=weights(18)
 103           wsccor=weights(21)
 104           wliptran=weights(22)
 105           wtube=weights(25)
 106           wsaxs=weights(26)
 107           wdfa_dist=weights(28)
 108           wdfa_tor=weights(29)
 109           wdfa_nei=weights(30)
 110           wdfa_beta=weights(31)
 111         endif
 112         time_Bcast=time_Bcast+MPI_Wtime()-time00
 113         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 114 c        call chainbuild_cart
 115       endif
 116       if (nfgtasks.gt.1) then
 117         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 118       endif
 119 c      write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
 120       if (mod(itime_mat,imatupdate).eq.0) then
 121 #ifdef TIMING_ENE
 122         time01=MPI_Wtime()
 123 #endif
 124         call make_SCp_inter_list
 125 c        write (iout,*) "Finished make_SCp_inter_list"
 126 c        call flush(iout)
 127         call make_SCSC_inter_list
 128 c        write (iout,*) "Finished make_SCSC_inter_list"
 129 c        call flush(iout)
 130         call make_pp_inter_list
 131 c        write (iout,*) "Finished make_pp_inter_list"
 132 c        call flush(iout)
 133 c        call make_pp_vdw_inter_list
 134 c        write (iout,*) "Finished make_pp_vdw_inter_list"
 135 c        call flush(iout)
 136 #ifdef TIMING_ENE
 137         time_list=time_list+MPI_Wtime()-time01
 138 #endif
 139       endif
 140 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 141 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 142 #else
 143 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 144 c        call int_from_cart1(.false.)
 145 c      endif
 146 #endif
 147 #ifdef TIMING
 148       time00=MPI_Wtime()
 149 #endif
 150
 151 #ifndef DFA
 152       edfadis=0.0d0
 153       edfator=0.0d0
 154       edfanei=0.0d0
 155       edfabet=0.0d0
 156 #endif
 157 C
 158 C Compute the side-chain and electrostatic interaction energy
 159 C
 160 C      print *,ipot
 161 #ifdef TIMING_ENE
 162       time01=MPI_Wtime()
 163 #endif
 164       goto (101,102,103,104,105,106) ipot
 165 C Lennard-Jones potential.
 166   101 call elj(evdw)
 167 cd    print '(a)','Exit ELJ'
 168       goto 107
 169 C Lennard-Jones-Kihara potential (shifted).
 170   102 call eljk(evdw)
 171       goto 107
 172 C Berne-Pechukas potential (dilated LJ, angular dependence).
 173   103 call ebp(evdw)
 174       goto 107
 175 C Gay-Berne potential (shifted LJ, angular dependence).
 176   104 call egb(evdw)
 177 C      print *,"bylem w egb"
 178       goto 107
 179 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 180   105 call egbv(evdw)
 181       goto 107
 182 C Soft-sphere potential
 183   106 call e_softsphere(evdw)
 184 C
 185 C Calculate electrostatic (H-bonding) energy of the main chain.
 186 C
 187   107 continue
 188 #ifdef TIMING_ENE
 189       time_evdw=time_evdw+MPI_Wtime()-time01
 190 #endif
 191 #ifdef DFA
 192 C     BARTEK for dfa test!
 193 c      print *,"Processors",MyRank," wdfa",wdfa_dist
 194       if (wdfa_dist.gt.0) then
 195         call edfad(edfadis)
 196 c        print *,"Processors",MyRank," edfadis",edfadis
 197       else
 198         edfadis=0
 199       endif
 200 c      print*, 'edfad is finished!', edfadis
 201       if (wdfa_tor.gt.0) then
 202         call edfat(edfator)
 203       else
 204         edfator=0
 205       endif
 206 c      print*, 'edfat is finished!', edfator
 207       if (wdfa_nei.gt.0) then
 208         call edfan(edfanei)
 209       else
 210         edfanei=0
 211       endif
 212 c      print*, 'edfan is finished!', edfanei
 213       if (wdfa_beta.gt.0) then
 214         call edfab(edfabet)
 215       else
 216         edfabet=0
 217       endif
 218 #endif
 219 cmc
 220 cmc Sep-06: egb takes care of dynamic ss bonds too
 221 cmc
 222 c      if (dyn_ss) call dyn_set_nss
 223
 224 c      print *,"Processor",myrank," computed USCSC"
 225 #ifdef TIMING
 226       time01=MPI_Wtime()
 227 #endif
 228       call vec_and_deriv
 229 #ifdef TIMING
 230       time_vec=time_vec+MPI_Wtime()-time01
 231 #endif
 232 #ifdef TIMING_ENE
 233       time01=MPI_Wtime()
 234 #endif
 235 C Introduction of shielding effect first for each peptide group
 236 C the shielding factor is set this factor is describing how each
 237 C peptide group is shielded by side-chains
 238 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 239 C      write (iout,*) "shield_mode",shield_mode
 240       if (shield_mode.eq.1) then
 241        call set_shield_fac
 242       else if  (shield_mode.eq.2) then
 243        call set_shield_fac2
 244       endif
 245 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 246       if (ipot.lt.6) then
 247 #ifdef SPLITELE
 248          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 249      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 250      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 251      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 252 #else
 253          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 254      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 255      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 256      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 257 #endif
 258             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 259          else
 260             ees=0.0d0
 261             evdw1=0.0d0
 262             eel_loc=0.0d0
 263             eello_turn3=0.0d0
 264             eello_turn4=0.0d0
 265          endif
 266       else
 267         write (iout,*) "Soft-spheer ELEC potential"
 268 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 269 c     &   eello_turn4)
 270       endif
 271 #ifdef TIMING_ENE
 272       time_eelec=time_eelec+MPI_Wtime()-time01
 273 #endif
 274 c#ifdef TIMING
 275 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 276 c#endif
 277 c      print *,"Processor",myrank," computed UELEC"
 278 C
 279 C Calculate excluded-volume interaction energy between peptide groups
 280 C and side chains.
 281 C
 282 #ifdef TIMING_ENE
 283       time01=MPI_Wtime()
 284 #endif
 285       if (ipot.lt.6) then
 286        if(wscp.gt.0d0) then
 287         call escp(evdw2,evdw2_14)
 288        else
 289         evdw2=0
 290         evdw2_14=0
 291        endif
 292       else
 293 c        write (iout,*) "Soft-sphere SCP potential"
 294         call escp_soft_sphere(evdw2,evdw2_14)
 295       endif
 296 #ifdef TIMING_ENE
 297       time_escp=time_escp+MPI_Wtime()-time01
 298 #endif
 299 c
 300 c Calculate the bond-stretching energy
 301 c
 302       call ebond(estr)
 303 C
 304 C Calculate the disulfide-bridge and other energy and the contributions
 305 C from other distance constraints.
 306 cd      write (iout,*) 'Calling EHPB'
 307       call edis(ehpb)
 308 cd    print *,'EHPB exitted succesfully.'
 309 C
 310 C Calculate the virtual-bond-angle energy.
 311 C
 312       if (wang.gt.0d0) then
 313        if (tor_mode.eq.0) then
 314          call ebend(ebe)
 315        else
 316 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 317 C energy function
 318          call ebend_kcc(ebe)
 319        endif
 320       else
 321         ebe=0.0d0
 322       endif
 323       ethetacnstr=0.0d0
 324       if (with_theta_constr) call etheta_constr(ethetacnstr)
 325 c      print *,"Processor",myrank," computed UB"
 326 C
 327 C Calculate the SC local energy.
 328 C
 329 C      print *,"TU DOCHODZE?"
 330       call esc(escloc)
 331 c      print *,"Processor",myrank," computed USC"
 332 C
 333 C Calculate the virtual-bond torsional energy.
 334 C
 335 cd    print *,'nterm=',nterm
 336 C      print *,"tor",tor_mode
 337       if (wtor.gt.0.0d0) then
 338          if (tor_mode.eq.0) then
 339            call etor(etors)
 340          else
 341 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 342 C energy function
 343            call etor_kcc(etors)
 344          endif
 345       else
 346         etors=0.0d0
 347       endif
 348       edihcnstr=0.0d0
 349       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 350 c      print *,"Processor",myrank," computed Utor"
 351       if (constr_homology.ge.1) then
 352         call e_modeller(ehomology_constr)
 353 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 354 c     &  'Processor',fg_rank,' CG group',kolor,
 355 c     &  ' absolute rank',MyRank
 356       else
 357         ehomology_constr=0.0d0
 358       endif
 359 C
 360 C 6/23/01 Calculate double-torsional energy
 361 C
 362       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 363         call etor_d(etors_d)
 364       else
 365         etors_d=0
 366       endif
 367 c      print *,"Processor",myrank," computed Utord"
 368 C
 369 C 21/5/07 Calculate local sicdechain correlation energy
 370 C
 371       if (wsccor.gt.0.0d0) then
 372         call eback_sc_corr(esccor)
 373       else
 374         esccor=0.0d0
 375       endif
 376 #ifdef FOURBODY
 377 C      print *,"PRZED MULIt"
 378 c      print *,"Processor",myrank," computed Usccorr"
 379 C
 380 C 12/1/95 Multi-body terms
 381 C
 382       n_corr=0
 383       n_corr1=0
 384       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 385      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 386          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 387 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 388 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 389 c        call flush(iout)
 390       else
 391          ecorr=0.0d0
 392          ecorr5=0.0d0
 393          ecorr6=0.0d0
 394          eturn6=0.0d0
 395       endif
 396       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 397 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 398 c     &     n_corr,n_corr1
 399 c         call flush(iout)
 400          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 401 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 402 c     &     n_corr1
 403 c         call flush(iout)
 404       else
 405          ecorr=0.0d0
 406          ecorr5=0.0d0
 407          ecorr6=0.0d0
 408          eturn6=0.0d0
 409       endif
 410 #else
 411       ecorr=0.0d0
 412       ecorr5=0.0d0
 413       ecorr6=0.0d0
 414       eturn6=0.0d0
 415 #endif
 416 c      print *,"Processor",myrank," computed Ucorr"
 417 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 418       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 419         call e_saxs(Esaxs_constr)
 420 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 421       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 422         call e_saxsC(Esaxs_constr)
 423 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 424       else
 425         Esaxs_constr = 0.0d0
 426       endif
 427 C
 428 C If performing constraint dynamics, call the constraint energy
 429 C  after the equilibration time
 430 c      if(usampl.and.totT.gt.eq_time) then
 431 c      write (iout,*) "usampl",usampl
 432       if(usampl) then
 433          call EconstrQ
 434          if (loc_qlike) then
 435            call Econstr_back_qlike
 436          else
 437            call Econstr_back
 438          endif
 439       else
 440          Uconst=0.0d0
 441          Uconst_back=0.0d0
 442       endif
 443 C 01/27/2015 added by adasko
 444 C the energy component below is energy transfer into lipid environment
 445 C based on partition function
 446 C      print *,"przed lipidami"
 447       if (wliptran.gt.0) then
 448         call Eliptransfer(eliptran)
 449       else
 450         eliptran=0.0d0
 451       endif
 452 C      print *,"za lipidami"
 453       if (AFMlog.gt.0) then
 454         call AFMforce(Eafmforce)
 455       else if (selfguide.gt.0) then
 456         call AFMvel(Eafmforce)
 457       else
 458         Eafmforce=0.0d0
 459       endif
 460       if (TUBElog.eq.1) then
 461 C      print *,"just before call"
 462         call calctube(Etube)
 463       elseif (TUBElog.eq.2) then
 464         call calctube2(Etube)
 465       else
 466         Etube=0.0d0
 467       endif
 468
 469 #ifdef TIMING
 470       time_enecalc=time_enecalc+MPI_Wtime()-time00
 471 #endif
 472 c      print *,"Processor",myrank," computed Uconstr"
 473 #ifdef TIMING
 474       time00=MPI_Wtime()
 475 #endif
 476 c
 477 C Sum the energies
 478 C
 479       energia(1)=evdw
 480 #ifdef SCP14
 481       energia(2)=evdw2-evdw2_14
 482       energia(18)=evdw2_14
 483 #else
 484       energia(2)=evdw2
 485       energia(18)=0.0d0
 486 #endif
 487 #ifdef SPLITELE
 488       energia(3)=ees
 489       energia(16)=evdw1
 490 #else
 491       energia(3)=ees+evdw1
 492       energia(16)=0.0d0
 493 #endif
 494       energia(4)=ecorr
 495       energia(5)=ecorr5
 496       energia(6)=ecorr6
 497       energia(7)=eel_loc
 498       energia(8)=eello_turn3
 499       energia(9)=eello_turn4
 500       energia(10)=eturn6
 501       energia(11)=ebe
 502       energia(12)=escloc
 503       energia(13)=etors
 504       energia(14)=etors_d
 505       energia(15)=ehpb
 506       energia(19)=edihcnstr
 507       energia(17)=estr
 508       energia(20)=Uconst+Uconst_back
 509       energia(21)=esccor
 510       energia(22)=eliptran
 511       energia(23)=Eafmforce
 512       energia(24)=ethetacnstr
 513       energia(25)=Etube
 514       energia(26)=Esaxs_constr
 515       energia(27)=ehomology_constr
 516       energia(28)=edfadis
 517       energia(29)=edfator
 518       energia(30)=edfanei
 519       energia(31)=edfabet
 520 c      write (iout,*) "esaxs_constr",energia(26)
 521 c    Here are the energies showed per procesor if the are more processors
 522 c    per molecule then we sum it up in sum_energy subroutine
 523 c      print *," Processor",myrank," calls SUM_ENERGY"
 524       call sum_energy(energia,.true.)
 525 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 526       if (dyn_ss) call dyn_set_nss
 527 c      print *," Processor",myrank," left SUM_ENERGY"
 528 #ifdef TIMING
 529       time_sumene=time_sumene+MPI_Wtime()-time00
 530 #endif
 531       return
 532       end
 533 c-------------------------------------------------------------------------------
 534       subroutine sum_energy(energia,reduce)
 535       implicit none
 536       include 'DIMENSIONS'
 537 #ifndef ISNAN
 538       external proc_proc
 539 #ifdef WINPGI
 540 cMS$ATTRIBUTES C ::  proc_proc
 541 #endif
 542 #endif
 543 #ifdef MPI
 544       include "mpif.h"
 545       integer ierr
 546       double precision time00
 547 #endif
 548       include 'COMMON.SETUP'
 549       include 'COMMON.IOUNITS'
 550       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 551       include 'COMMON.FFIELD'
 552       include 'COMMON.DERIV'
 553       include 'COMMON.INTERACT'
 554       include 'COMMON.SBRIDGE'
 555       include 'COMMON.CHAIN'
 556       include 'COMMON.VAR'
 557       include 'COMMON.CONTROL'
 558       include 'COMMON.TIME1'
 559       logical reduce
 560       integer i
 561       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 562      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 563      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 564      & eliptran,Eafmforce,Etube,
 565      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 566       double precision Uconst,etot
 567 #ifdef MPI
 568       if (nfgtasks.gt.1 .and. reduce) then
 569 #ifdef DEBUG
 570         write (iout,*) "energies before REDUCE"
 571         call enerprint(energia)
 572         call flush(iout)
 573 #endif
 574         do i=0,n_ene
 575           enebuff(i)=energia(i)
 576         enddo
 577         time00=MPI_Wtime()
 578         call MPI_Barrier(FG_COMM,IERR)
 579         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 580         time00=MPI_Wtime()
 581         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 582      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 583 #ifdef DEBUG
 584         write (iout,*) "energies after REDUCE"
 585         call enerprint(energia)
 586         call flush(iout)
 587 #endif
 588         time_Reduce=time_Reduce+MPI_Wtime()-time00
 589       endif
 590       if (fg_rank.eq.0) then
 591 #endif
 592       evdw=energia(1)
 593 #ifdef SCP14
 594       evdw2=energia(2)+energia(18)
 595       evdw2_14=energia(18)
 596 #else
 597       evdw2=energia(2)
 598 #endif
 599 #ifdef SPLITELE
 600       ees=energia(3)
 601       evdw1=energia(16)
 602 #else
 603       ees=energia(3)
 604       evdw1=0.0d0
 605 #endif
 606       ecorr=energia(4)
 607       ecorr5=energia(5)
 608       ecorr6=energia(6)
 609       eel_loc=energia(7)
 610       eello_turn3=energia(8)
 611       eello_turn4=energia(9)
 612       eturn6=energia(10)
 613       ebe=energia(11)
 614       escloc=energia(12)
 615       etors=energia(13)
 616       etors_d=energia(14)
 617       ehpb=energia(15)
 618       edihcnstr=energia(19)
 619       estr=energia(17)
 620       Uconst=energia(20)
 621       esccor=energia(21)
 622       eliptran=energia(22)
 623       Eafmforce=energia(23)
 624       ethetacnstr=energia(24)
 625       Etube=energia(25)
 626       esaxs_constr=energia(26)
 627       ehomology_constr=energia(27)
 628       edfadis=energia(28)
 629       edfator=energia(29)
 630       edfanei=energia(30)
 631       edfabet=energia(31)
 632 #ifdef SPLITELE
 633       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 634      & +wang*ebe+wtor*etors+wscloc*escloc
 635      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 636      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 637      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 638      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 639      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 640      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 641      & +wdfa_beta*edfabet
 642 #else
 643       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 644      & +wang*ebe+wtor*etors+wscloc*escloc
 645      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 646      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 647      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 648      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 649      & +Eafmforce
 650      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 651      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 652      & +wdfa_beta*edfabet
 653 #endif
 654       energia(0)=etot
 655 c detecting NaNQ
 656 #ifdef ISNAN
 657 #ifdef AIX
 658       if (isnan(etot).ne.0) energia(0)=1.0d+99
 659 #else
 660       if (isnan(etot)) energia(0)=1.0d+99
 661 #endif
 662 #else
 663       i=0
 664 #ifdef WINPGI
 665       idumm=proc_proc(etot,i)
 666 #else
 667       call proc_proc(etot,i)
 668 #endif
 669       if(i.eq.1)energia(0)=1.0d+99
 670 #endif
 671 #ifdef MPI
 672       endif
 673 #endif
 674       return
 675       end
 676 c-------------------------------------------------------------------------------
 677       subroutine sum_gradient
 678       implicit none
 679       include 'DIMENSIONS'
 680 #ifndef ISNAN
 681       external proc_proc
 682 #ifdef WINPGI
 683 cMS$ATTRIBUTES C ::  proc_proc
 684 #endif
 685 #endif
 686 #ifdef MPI
 687       include 'mpif.h'
 688       integer ierror,ierr
 689       double precision time00,time01
 690 #endif
 691       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 692      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 693      & ,gloc_scbuf(3,-1:maxres)
 694       include 'COMMON.SETUP'
 695       include 'COMMON.IOUNITS'
 696       include 'COMMON.FFIELD'
 697       include 'COMMON.DERIV'
 698       include 'COMMON.INTERACT'
 699       include 'COMMON.SBRIDGE'
 700       include 'COMMON.CHAIN'
 701       include 'COMMON.VAR'
 702       include 'COMMON.CONTROL'
 703       include 'COMMON.TIME1'
 704       include 'COMMON.MAXGRAD'
 705       include 'COMMON.SCCOR'
 706 c      include 'COMMON.MD'
 707       include 'COMMON.QRESTR'
 708       integer i,j,k
 709       double precision scalar
 710       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 711      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 712      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 713      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 714      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 715      &gsclocx_norm
 716 #ifdef TIMING
 717       time01=MPI_Wtime()
 718 #endif
 719 #ifdef DEBUG
 720       write (iout,*) "sum_gradient gvdwc, gvdwx"
 721       do i=1,nres
 722         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 723      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 724       enddo
 725       call flush(iout)
 726 #endif
 727 #ifdef DEBUG
 728       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 729       do i=0,nres
 730         write (iout,'(i3,3e15.5,5x,3e15.5)')
 731      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 732       enddo
 733       call flush(iout)
 734 #endif
 735 #ifdef MPI
 736 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 737         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 738      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 739 #endif
 740 C
 741 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 742 C            in virtual-bond-vector coordinates
 743 C
 744 #ifdef DEBUG
 745 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 746 c      do i=1,nres-1
 747 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 748 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 749 c      enddo
 750 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 751 c      do i=1,nres-1
 752 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 753 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 754 c      enddo
 755       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 756       do i=1,nres
 757         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 758      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 759      &   g_corr5_loc(i)
 760       enddo
 761       call flush(iout)
 762 #endif
 763 #ifdef DEBUG
 764       write (iout,*) "gsaxsc"
 765       do i=1,nres
 766         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 767       enddo
 768       call flush(iout)
 769 #endif
 770 #ifdef SPLITELE
 771       do i=0,nct
 772         do j=1,3
 773           gradbufc(j,i)=wsc*gvdwc(j,i)+
 774      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 775      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 776      &                wel_loc*gel_loc_long(j,i)+
 777      &                wcorr*gradcorr_long(j,i)+
 778      &                wcorr5*gradcorr5_long(j,i)+
 779      &                wcorr6*gradcorr6_long(j,i)+
 780      &                wturn6*gcorr6_turn_long(j,i)+
 781      &                wstrain*ghpbc(j,i)
 782      &                +wliptran*gliptranc(j,i)
 783      &                +gradafm(j,i)
 784      &                +welec*gshieldc(j,i)
 785      &                +wcorr*gshieldc_ec(j,i)
 786      &                +wturn3*gshieldc_t3(j,i)
 787      &                +wturn4*gshieldc_t4(j,i)
 788      &                +wel_loc*gshieldc_ll(j,i)
 789      &                +wtube*gg_tube(j,i)
 790      &                +wsaxs*gsaxsc(j,i)
 791         enddo
 792       enddo
 793 #else
 794       do i=0,nct
 795         do j=1,3
 796           gradbufc(j,i)=wsc*gvdwc(j,i)+
 797      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 798      &                welec*gelc_long(j,i)+
 799      &                wbond*gradb(j,i)+
 800      &                wel_loc*gel_loc_long(j,i)+
 801      &                wcorr*gradcorr_long(j,i)+
 802      &                wcorr5*gradcorr5_long(j,i)+
 803      &                wcorr6*gradcorr6_long(j,i)+
 804      &                wturn6*gcorr6_turn_long(j,i)+
 805      &                wstrain*ghpbc(j,i)
 806      &                +wliptran*gliptranc(j,i)
 807      &                +gradafm(j,i)
 808      &                 +welec*gshieldc(j,i)
 809      &                 +wcorr*gshieldc_ec(j,i)
 810      &                 +wturn4*gshieldc_t4(j,i)
 811      &                 +wel_loc*gshieldc_ll(j,i)
 812      &                +wtube*gg_tube(j,i)
 813      &                +wsaxs*gsaxsc(j,i)
 814         enddo
 815       enddo
 816 #endif
 817       do i=1,nct
 818         do j=1,3
 819           gradbufc(j,i)=gradbufc(j,i)+
 820      &                wdfa_dist*gdfad(j,i)+
 821      &                wdfa_tor*gdfat(j,i)+
 822      &                wdfa_nei*gdfan(j,i)+
 823      &                wdfa_beta*gdfab(j,i)
 824         enddo
 825       enddo
 826 #ifdef DEBUG
 827       write (iout,*) "gradc from gradbufc"
 828       do i=1,nres
 829         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 830       enddo
 831       call flush(iout)
 832 #endif
 833 #ifdef MPI
 834       if (nfgtasks.gt.1) then
 835       time00=MPI_Wtime()
 836 #ifdef DEBUG
 837       write (iout,*) "gradbufc before allreduce"
 838       do i=1,nres
 839         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 840       enddo
 841       call flush(iout)
 842 #endif
 843       do i=0,nres
 844         do j=1,3
 845           gradbufc_sum(j,i)=gradbufc(j,i)
 846         enddo
 847       enddo
 848 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 849 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 850 c      time_reduce=time_reduce+MPI_Wtime()-time00
 851 #ifdef DEBUG
 852 c      write (iout,*) "gradbufc_sum after allreduce"
 853 c      do i=1,nres
 854 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 855 c      enddo
 856 c      call flush(iout)
 857 #endif
 858 #ifdef TIMING
 859 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 860 #endif
 861 c      do i=nnt,nres
 862       do i=0,nres
 863         do k=1,3
 864           gradbufc(k,i)=0.0d0
 865         enddo
 866       enddo
 867 c#ifdef DEBUG
 868 c      write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 869 c      write (iout,*) (i," jgrad_start",jgrad_start(i),
 870 c     &                  " jgrad_end  ",jgrad_end(i),
 871 c     &                  i=igrad_start,igrad_end)
 872 c#endif
 873 c
 874 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 875 c do not parallelize this part.
 876 c
 877 c      do i=igrad_start,igrad_end
 878 c        do j=jgrad_start(i),jgrad_end(i)
 879 c          do k=1,3
 880 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 881 c          enddo
 882 c        enddo
 883 c      enddo
 884       do j=1,3
 885         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 886       enddo
 887 c      do i=nres-2,-1,-1
 888       do i=nres-2,0,-1
 889         do j=1,3
 890           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 891         enddo
 892       enddo
 893 #ifdef DEBUG
 894       write (iout,*) "gradbufc after summing"
 895       do i=1,nres
 896         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 897       enddo
 898       call flush(iout)
 899 #endif
 900       else
 901 #endif
 902 #ifdef DEBUG
 903       write (iout,*) "gradbufc"
 904       do i=0,nres
 905         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 906       enddo
 907       call flush(iout)
 908 #endif
 909 c      do i=-1,nres
 910       do i=0,nres
 911         do j=1,3
 912           gradbufc_sum(j,i)=gradbufc(j,i)
 913           gradbufc(j,i)=0.0d0
 914         enddo
 915       enddo
 916       do j=1,3
 917         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 918       enddo
 919 c      do i=nres-2,-1,-1
 920       do i=nres-2,0,-1
 921         do j=1,3
 922           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 923         enddo
 924       enddo
 925 c      do i=nnt,nres-1
 926 c        do k=1,3
 927 c          gradbufc(k,i)=0.0d0
 928 c        enddo
 929 c        do j=i+1,nres
 930 c          do k=1,3
 931 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 932 c          enddo
 933 c        enddo
 934 c      enddo
 935 #ifdef DEBUG
 936       write (iout,*) "gradbufc after summing"
 937       do i=1,nres
 938         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 939       enddo
 940       call flush(iout)
 941 #endif
 942 #ifdef MPI
 943       endif
 944 #endif
 945       do k=1,3
 946         gradbufc(k,nres)=0.0d0
 947       enddo
 948 c      do i=-1,nct
 949       do i=0,nct
 950         do j=1,3
 951 #ifdef SPLITELE
 952 C          print *,gradbufc(1,13)
 953 C          print *,welec*gelc(1,13)
 954 C          print *,wel_loc*gel_loc(1,13)
 955 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 956 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 957 C          print *,wel_loc*gel_loc_long(1,13)
 958 C          print *,gradafm(1,13),"AFM"
 959           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 960      &                wel_loc*gel_loc(j,i)+
 961      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 962      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 963      &                wel_loc*gel_loc_long(j,i)+
 964      &                wcorr*gradcorr_long(j,i)+
 965      &                wcorr5*gradcorr5_long(j,i)+
 966      &                wcorr6*gradcorr6_long(j,i)+
 967      &                wturn6*gcorr6_turn_long(j,i))+
 968      &                wbond*gradb(j,i)+
 969      &                wcorr*gradcorr(j,i)+
 970      &                wturn3*gcorr3_turn(j,i)+
 971      &                wturn4*gcorr4_turn(j,i)+
 972      &                wcorr5*gradcorr5(j,i)+
 973      &                wcorr6*gradcorr6(j,i)+
 974      &                wturn6*gcorr6_turn(j,i)+
 975      &                wsccor*gsccorc(j,i)
 976      &               +wscloc*gscloc(j,i)
 977      &               +wliptran*gliptranc(j,i)
 978      &                +gradafm(j,i)
 979      &                 +welec*gshieldc(j,i)
 980      &                 +welec*gshieldc_loc(j,i)
 981      &                 +wcorr*gshieldc_ec(j,i)
 982      &                 +wcorr*gshieldc_loc_ec(j,i)
 983      &                 +wturn3*gshieldc_t3(j,i)
 984      &                 +wturn3*gshieldc_loc_t3(j,i)
 985      &                 +wturn4*gshieldc_t4(j,i)
 986      &                 +wturn4*gshieldc_loc_t4(j,i)
 987      &                 +wel_loc*gshieldc_ll(j,i)
 988      &                 +wel_loc*gshieldc_loc_ll(j,i)
 989      &                +wtube*gg_tube(j,i)
 990
 991 #else
 992           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 993      &                wel_loc*gel_loc(j,i)+
 994      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 995      &                welec*gelc_long(j,i)+
 996      &                wel_loc*gel_loc_long(j,i)+
 997      &                wcorr*gcorr_long(j,i)+
 998      &                wcorr5*gradcorr5_long(j,i)+
 999      &                wcorr6*gradcorr6_long(j,i)+
1000      &                wturn6*gcorr6_turn_long(j,i))+
1001      &                wbond*gradb(j,i)+
1002      &                wcorr*gradcorr(j,i)+
1003      &                wturn3*gcorr3_turn(j,i)+
1004      &                wturn4*gcorr4_turn(j,i)+
1005      &                wcorr5*gradcorr5(j,i)+
1006      &                wcorr6*gradcorr6(j,i)+
1007      &                wturn6*gcorr6_turn(j,i)+
1008      &                wsccor*gsccorc(j,i)
1009      &               +wscloc*gscloc(j,i)
1010      &               +wliptran*gliptranc(j,i)
1011      &                +gradafm(j,i)
1012      &                 +welec*gshieldc(j,i)
1013      &                 +welec*gshieldc_loc(j,i)
1014      &                 +wcorr*gshieldc_ec(j,i)
1015      &                 +wcorr*gshieldc_loc_ec(j,i)
1016      &                 +wturn3*gshieldc_t3(j,i)
1017      &                 +wturn3*gshieldc_loc_t3(j,i)
1018      &                 +wturn4*gshieldc_t4(j,i)
1019      &                 +wturn4*gshieldc_loc_t4(j,i)
1020      &                 +wel_loc*gshieldc_ll(j,i)
1021      &                 +wel_loc*gshieldc_loc_ll(j,i)
1022      &                +wtube*gg_tube(j,i)
1023
1024
1025 #endif
1026           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
1027      &                  wbond*gradbx(j,i)+
1028      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
1029      &                  wsccor*gsccorx(j,i)
1030      &                 +wscloc*gsclocx(j,i)
1031      &                 +wliptran*gliptranx(j,i)
1032      &                 +welec*gshieldx(j,i)
1033      &                 +wcorr*gshieldx_ec(j,i)
1034      &                 +wturn3*gshieldx_t3(j,i)
1035      &                 +wturn4*gshieldx_t4(j,i)
1036      &                 +wel_loc*gshieldx_ll(j,i)
1037      &                 +wtube*gg_tube_sc(j,i)
1038      &                 +wsaxs*gsaxsx(j,i)
1039
1040
1041
1042         enddo
1043       enddo
1044       if (constr_homology.gt.0) then
1045         do i=1,nct
1046           do j=1,3
1047             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
1048             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1049           enddo
1050         enddo
1051       endif
1052 #ifdef DEBUG
1053       write (iout,*) "gradc gradx gloc after adding"
1054       write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1055      &   i,(gradc(j,0,icg),j=1,3),(gradx(j,0,icg),j=1,3)
1056       do i=1,nres
1057         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1058      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1059       enddo
1060 #endif
1061 #ifdef DEBUG
1062       write (iout,*) "gloc before adding corr"
1063       do i=1,4*nres
1064         write (iout,*) i,gloc(i,icg)
1065       enddo
1066 #endif
1067       do i=1,nres-3
1068         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1069      &   +wcorr5*g_corr5_loc(i)
1070      &   +wcorr6*g_corr6_loc(i)
1071      &   +wturn4*gel_loc_turn4(i)
1072      &   +wturn3*gel_loc_turn3(i)
1073      &   +wturn6*gel_loc_turn6(i)
1074      &   +wel_loc*gel_loc_loc(i)
1075       enddo
1076 #ifdef DEBUG
1077       write (iout,*) "gloc after adding corr"
1078       do i=1,4*nres
1079         write (iout,*) i,gloc(i,icg)
1080       enddo
1081 #endif
1082 #ifdef MPI
1083       if (nfgtasks.gt.1) then
1084         do j=1,3
1085           do i=0,nres
1086             gradbufc(j,i)=gradc(j,i,icg)
1087             gradbufx(j,i)=gradx(j,i,icg)
1088           enddo
1089         enddo
1090         do i=1,4*nres
1091           glocbuf(i)=gloc(i,icg)
1092         enddo
1093 c#define DEBUG
1094 #ifdef DEBUG
1095       write (iout,*) "gloc_sc before reduce"
1096       do i=1,nres
1097        do j=1,1
1098         write (iout,*) i,j,gloc_sc(j,i,icg)
1099        enddo
1100       enddo
1101 #endif
1102 c#undef DEBUG
1103         do i=1,nres
1104          do j=1,3
1105           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1106          enddo
1107         enddo
1108         time00=MPI_Wtime()
1109         call MPI_Barrier(FG_COMM,IERR)
1110         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1111         time00=MPI_Wtime()
1112         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*(nres+1),
1113      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1114         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*(nres+1),
1115      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1116         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1117      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1118         time_reduce=time_reduce+MPI_Wtime()-time00
1119         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1120      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1121         time_reduce=time_reduce+MPI_Wtime()-time00
1122 #ifdef DEBUG
1123       write (iout,*) "gradc after reduce"
1124       do i=0,nres
1125        do j=1,3
1126         write (iout,*) i,j,gradc(j,i,icg)
1127        enddo
1128       enddo
1129 #endif
1130 #ifdef DEBUG
1131       write (iout,*) "gloc_sc after reduce"
1132       do i=1,nres
1133        do j=1,1
1134         write (iout,*) i,j,gloc_sc(j,i,icg)
1135        enddo
1136       enddo
1137 #endif
1138 #ifdef DEBUG
1139       write (iout,*) "gloc after reduce"
1140       do i=1,4*nres
1141         write (iout,*) i,gloc(i,icg)
1142       enddo
1143 #endif
1144       endif
1145 #endif
1146       if (gnorm_check) then
1147 c
1148 c Compute the maximum elements of the gradient
1149 c
1150       gvdwc_max=0.0d0
1151       gvdwc_scp_max=0.0d0
1152       gelc_max=0.0d0
1153       gvdwpp_max=0.0d0
1154       gradb_max=0.0d0
1155       ghpbc_max=0.0d0
1156       gradcorr_max=0.0d0
1157       gel_loc_max=0.0d0
1158       gcorr3_turn_max=0.0d0
1159       gcorr4_turn_max=0.0d0
1160       gradcorr5_max=0.0d0
1161       gradcorr6_max=0.0d0
1162       gcorr6_turn_max=0.0d0
1163       gsccorrc_max=0.0d0
1164       gscloc_max=0.0d0
1165       gvdwx_max=0.0d0
1166       gradx_scp_max=0.0d0
1167       ghpbx_max=0.0d0
1168       gradxorr_max=0.0d0
1169       gsccorrx_max=0.0d0
1170       gsclocx_max=0.0d0
1171       do i=1,nct
1172         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1173         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1174         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1175         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1176      &   gvdwc_scp_max=gvdwc_scp_norm
1177         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1178         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1179         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1180         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1181         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1182         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1183         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1184         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1185         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1186         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1187         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1188         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1189         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1190      &    gcorr3_turn(1,i)))
1191         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1192      &    gcorr3_turn_max=gcorr3_turn_norm
1193         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1194      &    gcorr4_turn(1,i)))
1195         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1196      &    gcorr4_turn_max=gcorr4_turn_norm
1197         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1198         if (gradcorr5_norm.gt.gradcorr5_max)
1199      &    gradcorr5_max=gradcorr5_norm
1200         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1201         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1202         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1203      &    gcorr6_turn(1,i)))
1204         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1205      &    gcorr6_turn_max=gcorr6_turn_norm
1206         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1207         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1208         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1209         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1210         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1211         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1212         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1213         if (gradx_scp_norm.gt.gradx_scp_max)
1214      &    gradx_scp_max=gradx_scp_norm
1215         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1216         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1217         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1218         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1219         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1220         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1221         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1222         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1223       enddo
1224       if (gradout) then
1225 #if (defined AIX || defined CRAY)
1226         open(istat,file=statname,position="append")
1227 #else
1228         open(istat,file=statname,access="append")
1229 #endif
1230         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1231      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1232      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1233      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1234      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1235      &     gsccorrx_max,gsclocx_max
1236         close(istat)
1237         if (gvdwc_max.gt.1.0d4) then
1238           write (iout,*) "gvdwc gvdwx gradb gradbx"
1239           do i=nnt,nct
1240             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1241      &        gradb(j,i),gradbx(j,i),j=1,3)
1242           enddo
1243           call pdbout(0.0d0,'cipiszcze',iout)
1244           call flush(iout)
1245         endif
1246       endif
1247       endif
1248 #ifdef DEBUG
1249       write (iout,*) "gradc gradx gloc"
1250       do i=1,nres
1251         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1252      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1253       enddo
1254 #endif
1255 #ifdef TIMING
1256       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1257 #endif
1258       return
1259       end
1260 c-------------------------------------------------------------------------------
1261       subroutine rescale_weights(t_bath)
1262       implicit none
1263 #ifdef MPI
1264       include 'mpif.h'
1265       integer ierror
1266 #endif
1267       include 'DIMENSIONS'
1268       include 'COMMON.IOUNITS'
1269       include 'COMMON.FFIELD'
1270       include 'COMMON.SBRIDGE'
1271       include 'COMMON.CONTROL'
1272       double precision t_bath
1273       double precision facT,facT2,facT3,facT4,facT5
1274       double precision kfac /2.4d0/
1275       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1276 c      facT=temp0/t_bath
1277 c      facT=2*temp0/(t_bath+temp0)
1278       if (rescale_mode.eq.0) then
1279         facT=1.0d0
1280         facT2=1.0d0
1281         facT3=1.0d0
1282         facT4=1.0d0
1283         facT5=1.0d0
1284       else if (rescale_mode.eq.1) then
1285         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1286         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1287         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1288         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1289         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1290       else if (rescale_mode.eq.2) then
1291         x=t_bath/temp0
1292         x2=x*x
1293         x3=x2*x
1294         x4=x3*x
1295         x5=x4*x
1296         facT=licznik/dlog(dexp(x)+dexp(-x))
1297         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1298         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1299         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1300         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1301       else
1302         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1303         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1304 #ifdef MPI
1305        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1306 #endif
1307        stop 555
1308       endif
1309       if (shield_mode.gt.0) then
1310        wscp=weights(2)*fact
1311        wsc=weights(1)*fact
1312        wvdwpp=weights(16)*fact
1313       endif
1314       welec=weights(3)*fact
1315       wcorr=weights(4)*fact3
1316       wcorr5=weights(5)*fact4
1317       wcorr6=weights(6)*fact5
1318       wel_loc=weights(7)*fact2
1319       wturn3=weights(8)*fact2
1320       wturn4=weights(9)*fact3
1321       wturn6=weights(10)*fact5
1322       wtor=weights(13)*fact
1323       wtor_d=weights(14)*fact2
1324       wsccor=weights(21)*fact
1325       if (scale_umb) wumb=t_bath/temp0
1326 c      write (iout,*) "scale_umb",scale_umb
1327 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1328
1329       return
1330       end
1331 C------------------------------------------------------------------------
1332       subroutine enerprint(energia)
1333       implicit none
1334       include 'DIMENSIONS'
1335       include 'COMMON.IOUNITS'
1336       include 'COMMON.FFIELD'
1337       include 'COMMON.SBRIDGE'
1338       include 'COMMON.QRESTR'
1339       double precision energia(0:n_ene)
1340       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1341      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1342      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1343      & eello_turn6,
1344      & eliptran,Eafmforce,Etube,
1345      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1346       etot=energia(0)
1347       evdw=energia(1)
1348       evdw2=energia(2)
1349 #ifdef SCP14
1350       evdw2=energia(2)+energia(18)
1351 #else
1352       evdw2=energia(2)
1353 #endif
1354       ees=energia(3)
1355 #ifdef SPLITELE
1356       evdw1=energia(16)
1357 #endif
1358       ecorr=energia(4)
1359       ecorr5=energia(5)
1360       ecorr6=energia(6)
1361       eel_loc=energia(7)
1362       eello_turn3=energia(8)
1363       eello_turn4=energia(9)
1364       eello_turn6=energia(10)
1365       ebe=energia(11)
1366       escloc=energia(12)
1367       etors=energia(13)
1368       etors_d=energia(14)
1369       ehpb=energia(15)
1370       edihcnstr=energia(19)
1371       estr=energia(17)
1372       Uconst=energia(20)
1373       esccor=energia(21)
1374       eliptran=energia(22)
1375       Eafmforce=energia(23)
1376       ethetacnstr=energia(24)
1377       etube=energia(25)
1378       esaxs=energia(26)
1379       ehomology_constr=energia(27)
1380 C     Bartek
1381       edfadis = energia(28)
1382       edfator = energia(29)
1383       edfanei = energia(30)
1384       edfabet = energia(31)
1385 #ifdef SPLITELE
1386       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1387      &  estr,wbond,ebe,wang,
1388      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1389 #ifdef FOURBODY
1390      &  ecorr,wcorr,
1391      &  ecorr5,wcorr5,ecorr6,wcorr6,
1392 #endif
1393      &  eel_loc,wel_loc,eello_turn3,wturn3,
1394      &  eello_turn4,wturn4,
1395 #ifdef FOURBODY
1396      &  eello_turn6,wturn6,
1397 #endif
1398      &  esccor,wsccor,edihcnstr,
1399      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1400      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1401      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1402      &  edfabet,wdfa_beta,
1403      &  etot
1404    10 format (/'Virtual-chain energies:'//
1405      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1406      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1407      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1408      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1409      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1410      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1411      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1412      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1413      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1414      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1415      & ' (SS bridges & dist. cnstr.)'/
1416 #ifdef FOURBODY
1417      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1418      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1419      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1420 #endif
1421      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1422      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1423      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1424 #ifdef FOURBODY
1425      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1426 #endif
1427      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1428      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1429      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1430      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1431      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1432      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1433      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1434      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1435      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1436      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1437      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1438      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1439      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1440      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1441      & 'ETOT=  ',1pE16.6,' (total)')
1442
1443 #else
1444       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1445      &  estr,wbond,ebe,wang,
1446      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1447 #ifdef FOURBODY
1448      &  ecorr,wcorr,
1449      &  ecorr5,wcorr5,ecorr6,wcorr6,
1450 #endif
1451      &  eel_loc,wel_loc,eello_turn3,wturn3,
1452      &  eello_turn4,wturn4,
1453 #ifdef FOURBODY
1454      &  eello_turn6,wturn6,
1455 #endif
1456      &  esccor,wsccor,edihcnstr,
1457      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1458      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1459      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1460      &  edfabet,wdfa_beta,
1461      &  etot
1462    10 format (/'Virtual-chain energies:'//
1463      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1464      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1465      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1466      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1467      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1468      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1469      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1470      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1471      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1472      & ' (SS bridges & dist. restr.)'/
1473 #ifdef FOURBODY
1474      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1475      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1476      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1477 #endif
1478      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1479      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1480      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1481 #ifdef FOURBODY
1482      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1483 #endif
1484      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1485      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1486      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1487      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1488      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1489      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1490      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1491      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1492      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1493      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1494      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1495      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1496      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1497      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1498      & 'ETOT=  ',1pE16.6,' (total)')
1499 #endif
1500       return
1501       end
1502 C-----------------------------------------------------------------------
1503       subroutine elj(evdw)
1504 C
1505 C This subroutine calculates the interaction energy of nonbonded side chains
1506 C assuming the LJ potential of interaction.
1507 C
1508       implicit none
1509       double precision accur
1510       include 'DIMENSIONS'
1511       parameter (accur=1.0d-10)
1512       include 'COMMON.GEO'
1513       include 'COMMON.VAR'
1514       include 'COMMON.LOCAL'
1515       include 'COMMON.CHAIN'
1516       include 'COMMON.DERIV'
1517       include 'COMMON.INTERACT'
1518       include 'COMMON.TORSION'
1519       include 'COMMON.SBRIDGE'
1520       include 'COMMON.NAMES'
1521       include 'COMMON.IOUNITS'
1522       include 'COMMON.SPLITELE'
1523 #ifdef FOURBODY
1524       include 'COMMON.CONTACTS'
1525       include 'COMMON.CONTMAT'
1526 #endif
1527       double precision gg(3)
1528       double precision evdw,evdwij
1529       integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1530       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1531      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1532       double precision fcont,fprimcont
1533       double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1534      & faclip
1535       double precision sscale,sscagrad,sscagradlip,sscalelip
1536       double precision gg_lipi(3),gg_lipj(3)
1537       double precision boxshift
1538       external boxshift
1539 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1540       evdw=0.0D0
1541       gg_lipi=0.0d0
1542       gg_lipj=0.0d0
1543 c      do i=iatsc_s,iatsc_e
1544       do ikont=g_listscsc_start,g_listscsc_end
1545         i=newcontlisti(ikont)
1546         j=newcontlistj(ikont)
1547         itypi=iabs(itype(i))
1548         if (itypi.eq.ntyp1) cycle
1549         itypi1=iabs(itype(i+1))
1550         xi=c(1,nres+i)
1551         yi=c(2,nres+i)
1552         zi=c(3,nres+i)
1553         call to_box(xi,yi,zi)
1554         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1555 C Change 12/1/95
1556         num_conti=0
1557 C
1558 C Calculate SC interaction energy.
1559 C
1560 c        do iint=1,nint_gr(i)
1561 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1562 cd   &                  'iend=',iend(i,iint)
1563 c          do j=istart(i,iint),iend(i,iint)
1564             itypj=iabs(itype(j))
1565             if (itypj.eq.ntyp1) cycle
1566             xj=c(1,nres+j)
1567             yj=c(2,nres+j)
1568             zj=c(3,nres+j)
1569             call to_box(xj,yj,zj)
1570             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1571             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1572      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1573             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1574      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1575             xj=boxshift(xj-xi,boxxsize)
1576             yj=boxshift(yj-yi,boxysize)
1577             zj=boxshift(zj-zi,boxzsize)
1578 C Change 12/1/95 to calculate four-body interactions
1579             rij=xj*xj+yj*yj+zj*zj
1580             rrij=1.0D0/rij
1581             sqrij=dsqrt(rij)
1582             sss1=sscale(sqrij,r_cut_int)
1583             if (sss1.eq.0.0d0) cycle
1584             sssgrad1=sscagrad(sqrij,r_cut_int)
1585
1586 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1587             eps0ij=eps(itypi,itypj)
1588             fac=rrij**expon2
1589             faclip=fac
1590 C have you changed here?
1591             e1=fac*fac*aa
1592             e2=fac*bb
1593             evdwij=e1+e2
1594 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1595 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1596 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1597 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1598 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1599 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1600             evdw=evdw+sss1*evdwij
1601 C
1602 C Calculate the components of the gradient in DC and X
1603 C
1604             fac=-rrij*(e1+evdwij)*sss1
1605      &          +evdwij*sssgrad1/sqrij/expon
1606             gg(1)=xj*fac
1607             gg(2)=yj*fac
1608             gg(3)=zj*fac
1609             gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1610      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1611      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1612             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1613             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1614             do k=1,3
1615               gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1616               gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1617               gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1618               gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1619             enddo
1620 cgrad            do k=i,j-1
1621 cgrad              do l=1,3
1622 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1623 cgrad              enddo
1624 cgrad            enddo
1625 C
1626 #ifdef FOURBODY
1627 C 12/1/95, revised on 5/20/97
1628 C
1629 C Calculate the contact function. The ith column of the array JCONT will
1630 C contain the numbers of atoms that make contacts with the atom I (of numbers
1631 C greater than I). The arrays FACONT and GACONT will contain the values of
1632 C the contact function and its derivative.
1633 C
1634 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1635 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1636 C Uncomment next line, if the correlation interactions are contact function only
1637             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1638               rij=dsqrt(rij)
1639               sigij=sigma(itypi,itypj)
1640               r0ij=rs0(itypi,itypj)
1641 C
1642 C Check whether the SC's are not too far to make a contact.
1643 C
1644               rcut=1.5d0*r0ij
1645               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1646 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1647 C
1648               if (fcont.gt.0.0D0) then
1649 C If the SC-SC distance if close to sigma, apply spline.
1650 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1651 cAdam &             fcont1,fprimcont1)
1652 cAdam           fcont1=1.0d0-fcont1
1653 cAdam           if (fcont1.gt.0.0d0) then
1654 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1655 cAdam             fcont=fcont*fcont1
1656 cAdam           endif
1657 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1658 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1659 cga             do k=1,3
1660 cga               gg(k)=gg(k)*eps0ij
1661 cga             enddo
1662 cga             eps0ij=-evdwij*eps0ij
1663 C Uncomment for AL's type of SC correlation interactions.
1664 cadam           eps0ij=-evdwij
1665                 num_conti=num_conti+1
1666                 jcont(num_conti,i)=j
1667                 facont(num_conti,i)=fcont*eps0ij
1668                 fprimcont=eps0ij*fprimcont/rij
1669                 fcont=expon*fcont
1670 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1671 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1672 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1673 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1674                 gacont(1,num_conti,i)=-fprimcont*xj
1675                 gacont(2,num_conti,i)=-fprimcont*yj
1676                 gacont(3,num_conti,i)=-fprimcont*zj
1677 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1678 cd              write (iout,'(2i3,3f10.5)')
1679 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1680               endif
1681             endif
1682 #endif
1683 c          enddo      ! j
1684 c        enddo        ! iint
1685 C Change 12/1/95
1686 #ifdef FOURBODY
1687         num_cont(i)=num_conti
1688 #endif
1689       enddo          ! i
1690       do i=1,nct
1691         do j=1,3
1692           gvdwc(j,i)=expon*gvdwc(j,i)
1693           gvdwx(j,i)=expon*gvdwx(j,i)
1694         enddo
1695       enddo
1696 C******************************************************************************
1697 C
1698 C                              N O T E !!!
1699 C
1700 C To save time, the factor of EXPON has been extracted from ALL components
1701 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1702 C use!
1703 C
1704 C******************************************************************************
1705       return
1706       end
1707 C-----------------------------------------------------------------------------
1708       subroutine eljk(evdw)
1709 C
1710 C This subroutine calculates the interaction energy of nonbonded side chains
1711 C assuming the LJK potential of interaction.
1712 C
1713       implicit none
1714       include 'DIMENSIONS'
1715       include 'COMMON.GEO'
1716       include 'COMMON.VAR'
1717       include 'COMMON.LOCAL'
1718       include 'COMMON.CHAIN'
1719       include 'COMMON.DERIV'
1720       include 'COMMON.INTERACT'
1721       include 'COMMON.IOUNITS'
1722       include 'COMMON.NAMES'
1723       include 'COMMON.SPLITELE'
1724       double precision gg(3)
1725       double precision evdw,evdwij
1726       integer i,j,k,itypi,itypj,itypi1,iint,ikont
1727       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1728      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1729       logical scheck
1730       double precision boxshift
1731       double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1732      & faclip
1733       double precision gg_lipi(3),gg_lipj(3)
1734       double precision sscale,sscagrad,sscagradlip,sscalelip
1735 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1736       evdw=0.0D0
1737       gg_lipi=0.0d0
1738       gg_lipj=0.0d0
1739 c      do i=iatsc_s,iatsc_e
1740       do ikont=g_listscsc_start,g_listscsc_end
1741         i=newcontlisti(ikont)
1742         j=newcontlistj(ikont)
1743         itypi=iabs(itype(i))
1744         if (itypi.eq.ntyp1) cycle
1745         itypi1=iabs(itype(i+1))
1746         xi=c(1,nres+i)
1747         yi=c(2,nres+i)
1748         zi=c(3,nres+i)
1749         call to_box(xi,yi,zi)
1750         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1751 C
1752 C Calculate SC interaction energy.
1753 C
1754 c        do iint=1,nint_gr(i)
1755 c          do j=istart(i,iint),iend(i,iint)
1756             itypj=iabs(itype(j))
1757             if (itypj.eq.ntyp1) cycle
1758             xj=c(1,nres+j)
1759             yj=c(2,nres+j)
1760             zj=c(3,nres+j)
1761             call to_box(xj,yj,zj)
1762             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1763             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1764      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1765             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1766      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1767             xj=boxshift(xj-xi,boxxsize)
1768             yj=boxshift(yj-yi,boxysize)
1769             zj=boxshift(zj-zi,boxzsize)
1770             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1771             fac_augm=rrij**expon
1772             e_augm=augm(itypi,itypj)*fac_augm
1773             r_inv_ij=dsqrt(rrij)
1774             rij=1.0D0/r_inv_ij
1775             sss1=sscale(rij,r_cut_int)
1776             if (sss1.eq.0.0d0) cycle
1777             sssgrad1=sscagrad(rij,r_cut_int)
1778             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1779             fac=r_shift_inv**expon
1780             faclip=fac
1781 C have you changed here?
1782             e1=fac*fac*aa
1783             e2=fac*bb
1784             evdwij=e_augm+e1+e2
1785 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1786 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1787 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1788 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1789 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1790 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1791 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1792             evdw=evdw+evdwij*sss1
1793 C
1794 C Calculate the components of the gradient in DC and X
1795 C
1796             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1797      &          +evdwij*sssgrad1*r_inv_ij/expon
1798             gg(1)=xj*fac
1799             gg(2)=yj*fac
1800             gg(3)=zj*fac
1801             gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1802      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1803      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1804             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1805             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1806             do k=1,3
1807               gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1808               gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1809               gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1810               gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1811             enddo
1812 cgrad            do k=i,j-1
1813 cgrad              do l=1,3
1814 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1815 cgrad              enddo
1816 cgrad            enddo
1817 c          enddo      ! j
1818 c        enddo        ! iint
1819       enddo          ! i
1820       do i=1,nct
1821         do j=1,3
1822           gvdwc(j,i)=expon*gvdwc(j,i)
1823           gvdwx(j,i)=expon*gvdwx(j,i)
1824         enddo
1825       enddo
1826       return
1827       end
1828 C-----------------------------------------------------------------------------
1829       subroutine ebp(evdw)
1830 C
1831 C This subroutine calculates the interaction energy of nonbonded side chains
1832 C assuming the Berne-Pechukas potential of interaction.
1833 C
1834       implicit none
1835       include 'DIMENSIONS'
1836       include 'COMMON.GEO'
1837       include 'COMMON.VAR'
1838       include 'COMMON.LOCAL'
1839       include 'COMMON.CHAIN'
1840       include 'COMMON.DERIV'
1841       include 'COMMON.NAMES'
1842       include 'COMMON.INTERACT'
1843       include 'COMMON.IOUNITS'
1844       include 'COMMON.CALC'
1845       include 'COMMON.SPLITELE'
1846       integer icall
1847       common /srutu/ icall
1848       double precision evdw
1849       integer itypi,itypj,itypi1,iint,ind,ikont
1850       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1851      & sss1,sssgrad1
1852       double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1853      & faclip
1854       double precision sscale,sscagrad,sscagradlip,sscalelip
1855       double precision boxshift
1856 c     double precision rrsave(maxdim)
1857       logical lprn
1858       evdw=0.0D0
1859 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1860       gg_lipi=0.0d0
1861       gg_lipj=0.0d0
1862 c     if (icall.eq.0) then
1863 c       lprn=.true.
1864 c     else
1865         lprn=.false.
1866 c     endif
1867       ind=0
1868 c      do i=iatsc_s,iatsc_e
1869       do ikont=g_listscsc_start,g_listscsc_end
1870         i=newcontlisti(ikont)
1871         j=newcontlistj(ikont)
1872         itypi=iabs(itype(i))
1873         if (itypi.eq.ntyp1) cycle
1874         itypi1=iabs(itype(i+1))
1875         xi=c(1,nres+i)
1876         yi=c(2,nres+i)
1877         zi=c(3,nres+i)
1878         call to_box(xi,yi,zi)
1879         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1880         dxi=dc_norm(1,nres+i)
1881         dyi=dc_norm(2,nres+i)
1882         dzi=dc_norm(3,nres+i)
1883 c        dsci_inv=dsc_inv(itypi)
1884         dsci_inv=vbld_inv(i+nres)
1885 C
1886 C Calculate SC interaction energy.
1887 C
1888 c        do iint=1,nint_gr(i)
1889 c          do j=istart(i,iint),iend(i,iint)
1890             ind=ind+1
1891             itypj=iabs(itype(j))
1892             if (itypj.eq.ntyp1) cycle
1893 c            dscj_inv=dsc_inv(itypj)
1894             dscj_inv=vbld_inv(j+nres)
1895             chi1=chi(itypi,itypj)
1896             chi2=chi(itypj,itypi)
1897             chi12=chi1*chi2
1898             chip1=chip(itypi)
1899             chip2=chip(itypj)
1900             chip12=chip1*chip2
1901             alf1=alp(itypi)
1902             alf2=alp(itypj)
1903             alf12=0.5D0*(alf1+alf2)
1904 C For diagnostics only!!!
1905 c           chi1=0.0D0
1906 c           chi2=0.0D0
1907 c           chi12=0.0D0
1908 c           chip1=0.0D0
1909 c           chip2=0.0D0
1910 c           chip12=0.0D0
1911 c           alf1=0.0D0
1912 c           alf2=0.0D0
1913 c           alf12=0.0D0
1914             xj=c(1,nres+j)
1915             yj=c(2,nres+j)
1916             zj=c(3,nres+j)
1917             call to_box(xj,yj,zj)
1918             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1919             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1920      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1921             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1922      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1923             xj=boxshift(xj-xi,boxxsize)
1924             yj=boxshift(yj-yi,boxysize)
1925             zj=boxshift(zj-zi,boxzsize)
1926             dxj=dc_norm(1,nres+j)
1927             dyj=dc_norm(2,nres+j)
1928             dzj=dc_norm(3,nres+j)
1929             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1930 cd          if (icall.eq.0) then
1931 cd            rrsave(ind)=rrij
1932 cd          else
1933 cd            rrij=rrsave(ind)
1934 cd          endif
1935             rij=dsqrt(rrij)
1936             sss1=sscale(1.0d0/rij,r_cut_int)
1937             if (sss1.eq.0.0d0) cycle
1938             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1939 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1940             call sc_angular
1941 C Calculate whole angle-dependent part of epsilon and contributions
1942 C to its derivatives
1943 C have you changed here?
1944             fac=(rrij*sigsq)**expon2
1945             faclip=fac
1946             e1=fac*fac*aa
1947             e2=fac*bb
1948             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1949             eps2der=evdwij*eps3rt
1950             eps3der=evdwij*eps2rt
1951             evdwij=evdwij*eps2rt*eps3rt
1952             evdw=evdw+sss1*evdwij
1953             if (lprn) then
1954             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1955             epsi=bb**2/aa
1956 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1957 cd     &        restyp(itypi),i,restyp(itypj),j,
1958 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1959 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1960 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1961 cd     &        evdwij
1962             endif
1963 C Calculate gradient components.
1964             e1=e1*eps1*eps2rt**2*eps3rt**2
1965             fac=-expon*(e1+evdwij)
1966             sigder=fac/sigsq
1967             fac=rrij*fac
1968      &          +evdwij*sssgrad1/sss1*rij
1969 C Calculate radial part of the gradient
1970             gg(1)=xj*fac
1971             gg(2)=yj*fac
1972             gg(3)=zj*fac
1973             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1974      &        *(eps3rt*eps3rt)*sss1/2.0d0*(faclip*faclip*
1975      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1976      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1977             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1978             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1979 C Calculate the angular part of the gradient and sum add the contributions
1980 C to the appropriate components of the Cartesian gradient.
1981             call sc_grad
1982 !          enddo      ! j
1983 !        enddo        ! iint
1984       enddo          ! i
1985 c     stop
1986       return
1987       end
1988 C-----------------------------------------------------------------------------
1989       subroutine egb(evdw)
1990 C
1991 C This subroutine calculates the interaction energy of nonbonded side chains
1992 C assuming the Gay-Berne potential of interaction.
1993 C
1994       implicit none
1995       include 'DIMENSIONS'
1996       include 'COMMON.GEO'
1997       include 'COMMON.VAR'
1998       include 'COMMON.LOCAL'
1999       include 'COMMON.CHAIN'
2000       include 'COMMON.DERIV'
2001       include 'COMMON.NAMES'
2002       include 'COMMON.INTERACT'
2003       include 'COMMON.IOUNITS'
2004       include 'COMMON.CALC'
2005       include 'COMMON.CONTROL'
2006       include 'COMMON.SPLITELE'
2007       include 'COMMON.SBRIDGE'
2008       logical lprn
2009       double precision evdw
2010       integer itypi,itypj,itypi1,iint,ind,ikont
2011       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
2012       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2013      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
2014       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2015       double precision boxshift
2016       double precision x0,y0,r012,rij12,facx0,
2017      &  facx02,afacx0,bfacx0,abfacx0,Afac,BBfac,Afacsig,Bfacsig
2018 c      alpha_GB=0.5d0
2019 c      alpha_GB=0.01d0
2020 c      alpha_GB1=1.0d0+1.0d0/alpha_GB
2021       evdw=0.0D0
2022 ccccc      energy_dec=.false.
2023 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2024       gg_lipi=0.0d0
2025       gg_lipj=0.0d0
2026       lprn=.false.
2027 c     if (icall.eq.0) lprn=.false.
2028       ind=0
2029 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
2030 C we have the original box)
2031 C      do xshift=-1,1
2032 C      do yshift=-1,1
2033 C      do zshift=-1,1
2034 c      do i=iatsc_s,iatsc_e
2035       do ikont=g_listscsc_start,g_listscsc_end
2036         i=newcontlisti(ikont)
2037         j=newcontlistj(ikont)
2038         itypi=iabs(itype(i))
2039         if (itypi.eq.ntyp1) cycle
2040         itypi1=iabs(itype(i+1))
2041         xi=c(1,nres+i)
2042         yi=c(2,nres+i)
2043         zi=c(3,nres+i)
2044         call to_box(xi,yi,zi)
2045 C define scaling factor for lipids
2046
2047 C        if (positi.le.0) positi=positi+boxzsize
2048 C        print *,i
2049 C first for peptide groups
2050 c for each residue check if it is in lipid or lipid water border area
2051         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2052 C          xi=xi+xshift*boxxsize
2053 C          yi=yi+yshift*boxysize
2054 C          zi=zi+zshift*boxzsize
2055
2056         dxi=dc_norm(1,nres+i)
2057         dyi=dc_norm(2,nres+i)
2058         dzi=dc_norm(3,nres+i)
2059 c        dsci_inv=dsc_inv(itypi)
2060         dsci_inv=vbld_inv(i+nres)
2061 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
2062 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
2063 C
2064 C Calculate SC interaction energy.
2065 C
2066 c        do iint=1,nint_gr(i)
2067 c          do j=istart(i,iint),iend(i,iint)
2068             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2069
2070 c              write(iout,*) "PRZED ZWYKLE", evdwij
2071               call dyn_ssbond_ene(i,j,evdwij)
2072 c              write(iout,*) "PO ZWYKLE", evdwij
2073 c              call flush(iout)
2074
2075               evdw=evdw+evdwij
2076               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2077      &                        'evdw',i,j,evdwij,' ss'
2078 C triple bond artifac removal
2079 c              do k=j+1,iend(i,iint)
2080               do k=j+1,nct
2081 C search over all next residues
2082                 if (dyn_ss_mask(k)) then
2083 C check if they are cysteins
2084 C              write(iout,*) 'k=',k
2085
2086 c              write(iout,*) "PRZED TRI", evdwij
2087                   evdwij_przed_tri=evdwij
2088                   call triple_ssbond_ene(i,j,k,evdwij)
2089 c               if(evdwij_przed_tri.ne.evdwij) then
2090 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2091 c               endif
2092
2093 c              write(iout,*) "PO TRI", evdwij
2094 C call the energy function that removes the artifical triple disulfide
2095 C bond the soubroutine is located in ssMD.F
2096                   evdw=evdw+evdwij
2097                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2098      &                        'evdw',i,j,evdwij,'tss'
2099                 endif!dyn_ss_mask(k)
2100               enddo! k
2101             ELSE
2102               ind=ind+1
2103               itypj=iabs(itype(j))
2104               if (itypj.eq.ntyp1) cycle
2105 c            dscj_inv=dsc_inv(itypj)
2106               dscj_inv=vbld_inv(j+nres)
2107 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2108 c     &       1.0d0/vbld(j+nres)
2109 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2110               sig0ij=sigma(itypi,itypj)
2111               chi1=chi(itypi,itypj)
2112               chi2=chi(itypj,itypi)
2113               chi12=chi1*chi2
2114               chip1=chip(itypi)
2115               chip2=chip(itypj)
2116               chip12=chip1*chip2
2117               alf1=alp(itypi)
2118               alf2=alp(itypj)
2119               alf12=0.5D0*(alf1+alf2)
2120 C For diagnostics only!!!
2121 c           chi1=0.0D0
2122 c           chi2=0.0D0
2123 c           chi12=0.0D0
2124 c           chip1=0.0D0
2125 c           chip2=0.0D0
2126 c           chip12=0.0D0
2127 c           alf1=0.0D0
2128 c           alf2=0.0D0
2129 c           alf12=0.0D0
2130               xj=c(1,nres+j)
2131               yj=c(2,nres+j)
2132               zj=c(3,nres+j)
2133               call to_box(xj,yj,zj)
2134               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2135               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2136      &          +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2137               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2138      &          +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2139 c            write (iout,*) "aa bb",aa_lip(itypi,itypj),
2140 c     &       bb_lip(itypi,itypj),aa_aq(itypi,itypj),
2141 c     &       bb_aq(itypi,itypj),aa,bb
2142 c            write (iout,*) (sslipi+sslipj)/2.0d0,
2143 c     &        (2.0d0-sslipi-sslipj)/2.0d0
2144
2145 c      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2146 c      if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
2147 c     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2148 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2149 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2150               xj=boxshift(xj-xi,boxxsize)
2151               yj=boxshift(yj-yi,boxysize)
2152               zj=boxshift(zj-zi,boxzsize)
2153               dxj=dc_norm(1,nres+j)
2154               dyj=dc_norm(2,nres+j)
2155               dzj=dc_norm(3,nres+j)
2156 C            xj=xj-xi
2157 C            yj=yj-yi
2158 C            zj=zj-zi
2159 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2160 c            write (iout,*) "j",j," dc_norm",
2161 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2162               rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2163               rij=dsqrt(rrij)
2164               sss=sscale(1.0d0/rij,r_cut_int)
2165 c            write (iout,'(a7,4f8.3)')
2166 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2167               if (sss.eq.0.0d0) cycle
2168               sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2169 C Calculate angle-dependent terms of energy and contributions to their
2170 C derivatives.
2171               call sc_angular
2172               sigsq=1.0D0/sigsq
2173               sig=sig0ij*dsqrt(sigsq)
2174               rij_shift=1.0D0/rij-sig+sig0ij
2175 c              if (energy_dec)
2176 c     &        write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2177 c     &       " sig",sig," sig0ij",sig0ij
2178 c for diagnostics; uncomment
2179 c            rij_shift=1.2*sig0ij
2180 C I hate to put IF's in the loops, but here don't have another choice!!!!
2181 c              if (rij_shift.le.0.0D0) then
2182               x0=alpha_GB*(sig-sig0ij)
2183               if (energy_dec) write (iout,*) i,j," x0",x0
2184               if (rij_shift.le.x0) then
2185 c                sig=2.0d0*sig0ij
2186                 sigder=-sig*sigsq
2187 c                sigder=0.0d0
2188                 fac=rij**expon
2189                 rij12=fac*fac
2190 c                rij12=1.0d0
2191                 x0=alpha_GB*(sig-sig0ij)
2192                 facx0=1.0d0/x0**expon
2193                 facx02=facx0*facx0
2194                 r012=((1.0d0+alpha_GB)*(sig-sig0ij))**(2*expon)
2195                 afacx0=aa*facx02
2196                 bfacx0=bb*facx0
2197                 abfacx0=afacx0+0.5d0*bfacx0
2198                 Afac=alpha_GB1*abfacx0
2199                 Afacsig=0.5d0*alpha_GB1*bfacx0/(sig-sig0ij)
2200                 BBfac=Afac-(afacx0+bfacx0)
2201 c                BBfac=0.0d0
2202                 Bfacsig=(-alpha_GB1*(abfacx0+afacx0)+
2203      &              (afacx0+afacx0+bfacx0))/(sig-sig0ij)
2204 c                Bfacsig=0.0d0
2205                 Afac=Afac*r012
2206                 Afacsig=Afacsig*r012
2207 c                Afac=1.0d0
2208 c                Afacsig=0.0d0
2209 c    w(x)=4*eps*((1.0+1.0/alpha_GB)*(y0**12-0.5*y0**6)*(r0/x)**12-(1+1/alpha)*(y0**12-0.5*y0**6)+y0**12-y0**6)
2210 c                eps1=1.0d0
2211 c                eps2rt=1.0d0
2212 c                eps3rt=1.0d0
2213                 e1 = eps1*eps2rt*eps3rt*Afac*rij12
2214                 e2 = -eps1*eps2rt*eps3rt*BBfac
2215                 evdwij = e1+e2
2216                 eps2der=evdwij*eps3rt
2217                 eps3der=evdwij*eps2rt
2218 c                eps2der=0.0d0
2219 c                eps3der=0.0d0
2220 c                eps1_om12=0.0d0
2221                 evdwij=evdwij*eps2rt*eps3rt
2222 c                Afacsig=0.d0
2223 c                Bfacsig=0.0d0
2224                 if (lprn) then
2225                   write (iout,*) "aa",aa," bb",bb," sig0ij",sig0ij
2226                   sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2227                   epsi=bb**2/aa
2228                   write (iout,'(2(a3,i3,2x),18(0pf9.5))')
2229      &             restyp(itypi),i,restyp(itypj),j,
2230      &             epsi,sigm,chi1,chi2,chip1,chip2,
2231      &             eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2232      &             eps1*eps2rt**2*eps3rt**2,om1,om2,om12,
2233      &             1.0D0/rij,rij_shift,
2234      &             evdwij
2235                 endif
2236                 if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2237      &          'RE r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2238                 evdw=evdw+evdwij*sss
2239 C Calculate gradient components.
2240                 e1=e1*eps2rt*eps3rt
2241                 sigder=-expon*eps1*eps2rt*eps2rt*eps3rt*eps3rt
2242      &            *(Afacsig*rij12-Bfacsig)*sigder
2243                 fac=-2.0d0*expon*e1*rij*rij
2244 c              print '(2i4,6f8.4)',i,j,sss,sssgrad*
2245 c     &        evdwij,fac,sigma(itypi,itypj),expon
2246                 fac=fac+evdwij*sssgrad/sss*rij
2247 c                fac=0.0d0
2248 c                write (iout,*) "sigder",sigder," fac",fac," e1",e1,
2249 c     &              " e2",e2," sss",sss," sssgrad",sssgrad,"esp123",
2250 c     &              eps1*eps2rt**2*eps3rt**2
2251 C Calculate the radial part of the gradient
2252                 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2253      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2254      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2255      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2256                 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2257                 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2258 C              gg_lipi(3)=0.0d0
2259 C              gg_lipj(3)=0.0d0
2260                 gg(1)=xj*fac
2261                 gg(2)=yj*fac
2262                 gg(3)=zj*fac
2263 c                evdw=1.0D20
2264 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2265 cd     &        restyp(itypi),i,restyp(itypj),j,
2266 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2267 c                return
2268               else
2269                 rij_shift=1.0D0/rij_shift
2270                 sigder=-sig*sigsq
2271 c---------------------------------------------------------------
2272                 fac=rij_shift**expon
2273 C here to start with
2274 C            if (c(i,3).gt.
2275                 faclip=fac
2276                 e1=fac*fac*aa
2277                 e2=fac*bb
2278                 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2279                 eps2der=evdwij*eps3rt
2280                 eps3der=evdwij*eps2rt
2281 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2282 C     &((sslipi+sslipj)/2.0d0+
2283 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2284 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2285 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2286                 evdwij=evdwij*eps2rt*eps3rt
2287                 evdw=evdw+evdwij*sss
2288                 if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2289      &          'GB r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2290                 if (lprn) then
2291                   write (iout,*) "aa",aa," bb",bb," sig0ij",sig0ij
2292                   sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2293                   epsi=bb**2/aa
2294                   write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2295      &             restyp(itypi),i,restyp(itypj),j,
2296      &             epsi,sigm,chi1,chi2,chip1,chip2,
2297      &             eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2298      &             om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2299      &             evdwij
2300                 endif
2301
2302
2303 C Calculate gradient components.
2304                 e1=e1*eps1*eps2rt**2*eps3rt**2
2305                 fac=-expon*(e1+evdwij)*rij_shift
2306                 sigder=fac*sigder
2307                 fac=rij*fac
2308 c              print '(2i4,6f8.4)',i,j,sss,sssgrad*
2309 c     &        evdwij,fac,sigma(itypi,itypj),expon
2310                 fac=fac+evdwij*sssgrad/sss*rij
2311 c              fac=0.0d0
2312 C Calculate the radial part of the gradient
2313                 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2314      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2315      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2316      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2317                 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2318                 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2319 C              gg_lipi(3)=0.0d0
2320 C              gg_lipj(3)=0.0d0
2321                 gg(1)=xj*fac
2322                 gg(2)=yj*fac
2323                 gg(3)=zj*fac
2324               endif
2325 C Calculate angular part of the gradient.
2326 c            call sc_grad_scale(sss)
2327               call sc_grad
2328             ENDIF    ! dyn_ss
2329 c          enddo      ! j
2330 c        enddo        ! iint
2331       enddo          ! i
2332 C      enddo          ! zshift
2333 C      enddo          ! yshift
2334 C      enddo          ! xshift
2335 c      write (iout,*) "Number of loop steps in EGB:",ind
2336 cccc      energy_dec=.false.
2337       return
2338       end
2339 C-----------------------------------------------------------------------------
2340       subroutine egbv(evdw)
2341 C
2342 C This subroutine calculates the interaction energy of nonbonded side chains
2343 C assuming the Gay-Berne-Vorobjev potential of interaction.
2344 C
2345       implicit none
2346       include 'DIMENSIONS'
2347       include 'COMMON.GEO'
2348       include 'COMMON.VAR'
2349       include 'COMMON.LOCAL'
2350       include 'COMMON.CHAIN'
2351       include 'COMMON.DERIV'
2352       include 'COMMON.NAMES'
2353       include 'COMMON.INTERACT'
2354       include 'COMMON.IOUNITS'
2355       include 'COMMON.CALC'
2356       include 'COMMON.SPLITELE'
2357       double precision boxshift
2358       integer icall
2359       common /srutu/ icall
2360       logical lprn
2361       double precision evdw
2362       integer itypi,itypj,itypi1,iint,ind,ikont
2363       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2364      & xi,yi,zi,fac_augm,e_augm
2365       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2366      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2367       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2368       evdw=0.0D0
2369 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2370       gg_lipi=0.0d0
2371       gg_lipj=0.0d0
2372       lprn=.false.
2373 c     if (icall.eq.0) lprn=.true.
2374       ind=0
2375 c      do i=iatsc_s,iatsc_e
2376       do ikont=g_listscsc_start,g_listscsc_end
2377         i=newcontlisti(ikont)
2378         j=newcontlistj(ikont)
2379         itypi=iabs(itype(i))
2380         if (itypi.eq.ntyp1) cycle
2381         itypi1=iabs(itype(i+1))
2382         xi=c(1,nres+i)
2383         yi=c(2,nres+i)
2384         zi=c(3,nres+i)
2385         call to_box(xi,yi,zi)
2386 C define scaling factor for lipids
2387
2388 C        if (positi.le.0) positi=positi+boxzsize
2389 C        print *,i
2390 C first for peptide groups
2391 c for each residue check if it is in lipid or lipid water border area
2392         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2393         dxi=dc_norm(1,nres+i)
2394         dyi=dc_norm(2,nres+i)
2395         dzi=dc_norm(3,nres+i)
2396 c        dsci_inv=dsc_inv(itypi)
2397         dsci_inv=vbld_inv(i+nres)
2398 C
2399 C Calculate SC interaction energy.
2400 C
2401 c        do iint=1,nint_gr(i)
2402 c          do j=istart(i,iint),iend(i,iint)
2403             ind=ind+1
2404             itypj=iabs(itype(j))
2405             if (itypj.eq.ntyp1) cycle
2406 c            dscj_inv=dsc_inv(itypj)
2407             dscj_inv=vbld_inv(j+nres)
2408             sig0ij=sigma(itypi,itypj)
2409             r0ij=r0(itypi,itypj)
2410             chi1=chi(itypi,itypj)
2411             chi2=chi(itypj,itypi)
2412             chi12=chi1*chi2
2413             chip1=chip(itypi)
2414             chip2=chip(itypj)
2415             chip12=chip1*chip2
2416             alf1=alp(itypi)
2417             alf2=alp(itypj)
2418             alf12=0.5D0*(alf1+alf2)
2419 C For diagnostics only!!!
2420 c           chi1=0.0D0
2421 c           chi2=0.0D0
2422 c           chi12=0.0D0
2423 c           chip1=0.0D0
2424 c           chip2=0.0D0
2425 c           chip12=0.0D0
2426 c           alf1=0.0D0
2427 c           alf2=0.0D0
2428 c           alf12=0.0D0
2429            xj=c(1,nres+j)
2430            yj=c(2,nres+j)
2431            zj=c(3,nres+j)
2432            call to_box(xj,yj,zj)
2433            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2434            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2435      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2436            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2437      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2438 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2439 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2440 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2441            xj=boxshift(xj-xi,boxxsize)
2442            yj=boxshift(yj-yi,boxysize)
2443            zj=boxshift(zj-zi,boxzsize)
2444            dxj=dc_norm(1,nres+j)
2445            dyj=dc_norm(2,nres+j)
2446            dzj=dc_norm(3,nres+j)
2447            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2448            rij=dsqrt(rrij)
2449            sss=sscale(1.0d0/rij,r_cut_int)
2450            if (sss.eq.0.0d0) cycle
2451            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2452 C Calculate angle-dependent terms of energy and contributions to their
2453 C derivatives.
2454            call sc_angular
2455            sigsq=1.0D0/sigsq
2456            sig=sig0ij*dsqrt(sigsq)
2457            rij_shift=1.0D0/rij-sig+r0ij
2458 C I hate to put IF's in the loops, but here don't have another choice!!!!
2459            if (rij_shift.le.0.0D0) then
2460              evdw=1.0D20
2461              return
2462            endif
2463            sigder=-sig*sigsq
2464 c---------------------------------------------------------------
2465            rij_shift=1.0D0/rij_shift
2466            fac=rij_shift**expon
2467            faclip=fac
2468            e1=fac*fac*aa
2469            e2=fac*bb
2470            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2471            eps2der=evdwij*eps3rt
2472            eps3der=evdwij*eps2rt
2473            fac_augm=rrij**expon
2474            e_augm=augm(itypi,itypj)*fac_augm
2475            evdwij=evdwij*eps2rt*eps3rt
2476            evdw=evdw+evdwij+e_augm
2477            if (lprn) then
2478              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2479              epsi=bb**2/aa
2480              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2481      &        restyp(itypi),i,restyp(itypj),j,
2482      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2483      &        chi1,chi2,chip1,chip2,
2484      &        eps1,eps2rt**2,eps3rt**2,
2485      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2486      &        evdwij+e_augm
2487            endif
2488 C Calculate gradient components.
2489            e1=e1*eps1*eps2rt**2*eps3rt**2
2490            fac=-expon*(e1+evdwij)*rij_shift
2491            sigder=fac*sigder
2492            fac=rij*fac-2*expon*rrij*e_augm
2493            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2494 C Calculate the radial part of the gradient
2495            gg_lipi(3)=eps1*(eps2rt*eps2rt)
2496      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2497      &       (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2498      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2499            gg_lipj(3)=ssgradlipj*gg_lipi(3)
2500            gg_lipi(3)=gg_lipi(3)*ssgradlipi
2501            gg(1)=xj*fac
2502            gg(2)=yj*fac
2503            gg(3)=zj*fac
2504 C Calculate angular part of the gradient.
2505 c            call sc_grad_scale(sss)
2506            call sc_grad
2507 c          enddo      ! j
2508 c        enddo        ! iint
2509       enddo          ! i
2510       end
2511 C-----------------------------------------------------------------------------
2512       subroutine sc_angular
2513 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2514 C om12. Called by ebp, egb, and egbv.
2515       implicit none
2516       include 'COMMON.CALC'
2517       include 'COMMON.IOUNITS'
2518       erij(1)=xj*rij
2519       erij(2)=yj*rij
2520       erij(3)=zj*rij
2521       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2522       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2523       om12=dxi*dxj+dyi*dyj+dzi*dzj
2524       chiom12=chi12*om12
2525 C Calculate eps1(om12) and its derivative in om12
2526       faceps1=1.0D0-om12*chiom12
2527       faceps1_inv=1.0D0/faceps1
2528       eps1=dsqrt(faceps1_inv)
2529 C Following variable is eps1*deps1/dom12
2530       eps1_om12=faceps1_inv*chiom12
2531 c diagnostics only
2532 c      faceps1_inv=om12
2533 c      eps1=om12
2534 c      eps1_om12=1.0d0
2535 c      write (iout,*) "om12",om12," eps1",eps1
2536 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2537 C and om12.
2538       om1om2=om1*om2
2539       chiom1=chi1*om1
2540       chiom2=chi2*om2
2541       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2542       sigsq=1.0D0-facsig*faceps1_inv
2543       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2544       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2545       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2546 c diagnostics only
2547 c      sigsq=1.0d0
2548 c      sigsq_om1=0.0d0
2549 c      sigsq_om2=0.0d0
2550 c      sigsq_om12=0.0d0
2551 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2552 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2553 c     &    " eps1",eps1
2554 C Calculate eps2 and its derivatives in om1, om2, and om12.
2555       chipom1=chip1*om1
2556       chipom2=chip2*om2
2557       chipom12=chip12*om12
2558       facp=1.0D0-om12*chipom12
2559       facp_inv=1.0D0/facp
2560       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2561 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2562 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2563 C Following variable is the square root of eps2
2564       eps2rt=1.0D0-facp1*facp_inv
2565 C Following three variables are the derivatives of the square root of eps
2566 C in om1, om2, and om12.
2567       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2568       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2569       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2570 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2571       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2572 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2573 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2574 c     &  " eps2rt_om12",eps2rt_om12
2575 C Calculate whole angle-dependent part of epsilon and contributions
2576 C to its derivatives
2577       return
2578       end
2579 C----------------------------------------------------------------------------
2580       subroutine sc_grad
2581       implicit real*8 (a-h,o-z)
2582       include 'DIMENSIONS'
2583       include 'COMMON.CHAIN'
2584       include 'COMMON.DERIV'
2585       include 'COMMON.CALC'
2586       include 'COMMON.IOUNITS'
2587       double precision dcosom1(3),dcosom2(3)
2588 cc      print *,'sss=',sss
2589       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2590       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2591       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2592      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2593 c diagnostics only
2594 c      eom1=0.0d0
2595 c      eom2=0.0d0
2596 c      eom12=evdwij*eps1_om12
2597 c end diagnostics
2598 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2599 c     &  " sigder",sigder
2600 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2601 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2602       do k=1,3
2603         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2604         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2605       enddo
2606       do k=1,3
2607         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2608       enddo
2609 c      write (iout,*) "gg",(gg(k),k=1,3)
2610       do k=1,3
2611         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2612      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2613      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2614         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2615      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2616      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2617 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2618 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2619 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2620 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2621       enddo
2622 C
2623 C Calculate the components of the gradient in DC and X
2624 C
2625 cgrad      do k=i,j-1
2626 cgrad        do l=1,3
2627 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2628 cgrad        enddo
2629 cgrad      enddo
2630       do l=1,3
2631         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2632         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2633       enddo
2634       return
2635       end
2636 C-----------------------------------------------------------------------
2637       subroutine e_softsphere(evdw)
2638 C
2639 C This subroutine calculates the interaction energy of nonbonded side chains
2640 C assuming the LJ potential of interaction.
2641 C
2642       implicit real*8 (a-h,o-z)
2643       include 'DIMENSIONS'
2644       parameter (accur=1.0d-10)
2645       include 'COMMON.GEO'
2646       include 'COMMON.VAR'
2647       include 'COMMON.LOCAL'
2648       include 'COMMON.CHAIN'
2649       include 'COMMON.DERIV'
2650       include 'COMMON.INTERACT'
2651       include 'COMMON.TORSION'
2652       include 'COMMON.SBRIDGE'
2653       include 'COMMON.NAMES'
2654       include 'COMMON.IOUNITS'
2655 c      include 'COMMON.CONTACTS'
2656       dimension gg(3)
2657       double precision boxshift
2658 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2659       evdw=0.0D0
2660 c      do i=iatsc_s,iatsc_e
2661       do ikont=g_listscsc_start,g_listscsc_end
2662         i=newcontlisti(ikont)
2663         j=newcontlistj(ikont)
2664         itypi=iabs(itype(i))
2665         if (itypi.eq.ntyp1) cycle
2666         itypi1=iabs(itype(i+1))
2667         xi=c(1,nres+i)
2668         yi=c(2,nres+i)
2669         zi=c(3,nres+i)
2670         call to_box(xi,yi,zi)
2671 C
2672 C Calculate SC interaction energy.
2673 C
2674 c        do iint=1,nint_gr(i)
2675 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2676 cd   &                  'iend=',iend(i,iint)
2677 c          do j=istart(i,iint),iend(i,iint)
2678             itypj=iabs(itype(j))
2679             if (itypj.eq.ntyp1) cycle
2680             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2681             yj=boxshift(c(2,nres+j)-yi,boxysize)
2682             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2683             rij=xj*xj+yj*yj+zj*zj
2684 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2685             r0ij=r0(itypi,itypj)
2686             r0ijsq=r0ij*r0ij
2687 c            print *,i,j,r0ij,dsqrt(rij)
2688             if (rij.lt.r0ijsq) then
2689               evdwij=0.25d0*(rij-r0ijsq)**2
2690               fac=rij-r0ijsq
2691             else
2692               evdwij=0.0d0
2693               fac=0.0d0
2694             endif
2695             evdw=evdw+evdwij
2696 C
2697 C Calculate the components of the gradient in DC and X
2698 C
2699             gg(1)=xj*fac
2700             gg(2)=yj*fac
2701             gg(3)=zj*fac
2702             do k=1,3
2703               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2704               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2705               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2706               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2707             enddo
2708 cgrad            do k=i,j-1
2709 cgrad              do l=1,3
2710 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2711 cgrad              enddo
2712 cgrad            enddo
2713 c          enddo ! j
2714 c        enddo ! iint
2715       enddo ! i
2716       return
2717       end
2718 C--------------------------------------------------------------------------
2719       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2720      &              eello_turn4)
2721 C
2722 C Soft-sphere potential of p-p interaction
2723 C
2724       implicit real*8 (a-h,o-z)
2725       include 'DIMENSIONS'
2726       include 'COMMON.CONTROL'
2727       include 'COMMON.IOUNITS'
2728       include 'COMMON.GEO'
2729       include 'COMMON.VAR'
2730       include 'COMMON.LOCAL'
2731       include 'COMMON.CHAIN'
2732       include 'COMMON.DERIV'
2733       include 'COMMON.INTERACT'
2734 c      include 'COMMON.CONTACTS'
2735       include 'COMMON.TORSION'
2736       include 'COMMON.VECTORS'
2737       include 'COMMON.FFIELD'
2738       dimension ggg(3)
2739       double precision boxshift
2740 C      write(iout,*) 'In EELEC_soft_sphere'
2741       ees=0.0D0
2742       evdw1=0.0D0
2743       eel_loc=0.0d0
2744       eello_turn3=0.0d0
2745       eello_turn4=0.0d0
2746       ind=0
2747       do i=iatel_s,iatel_e
2748         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2749         dxi=dc(1,i)
2750         dyi=dc(2,i)
2751         dzi=dc(3,i)
2752         xmedi=c(1,i)+0.5d0*dxi
2753         ymedi=c(2,i)+0.5d0*dyi
2754         zmedi=c(3,i)+0.5d0*dzi
2755         call to_box(xmedi,ymedi,zmedi)
2756         num_conti=0
2757 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2758         do j=ielstart(i),ielend(i)
2759           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2760           ind=ind+1
2761           iteli=itel(i)
2762           itelj=itel(j)
2763           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2764           r0ij=rpp(iteli,itelj)
2765           r0ijsq=r0ij*r0ij
2766           dxj=dc(1,j)
2767           dyj=dc(2,j)
2768           dzj=dc(3,j)
2769           xj=c(1,j)+0.5D0*dxj
2770           yj=c(2,j)+0.5D0*dyj
2771           zj=c(3,j)+0.5D0*dzj
2772           call to_box(xj,yj,zj)
2773           xj=boxshift(xj-xmedi,boxxsize)
2774           yj=boxshift(yj-ymedi,boxysize)
2775           zj=boxshift(zj-zmedi,boxzsize)
2776           rij=xj*xj+yj*yj+zj*zj
2777             sss=sscale(sqrt(rij),r_cut_int)
2778             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2779           if (rij.lt.r0ijsq) then
2780             evdw1ij=0.25d0*(rij-r0ijsq)**2
2781             fac=rij-r0ijsq
2782           else
2783             evdw1ij=0.0d0
2784             fac=0.0d0
2785           endif
2786           evdw1=evdw1+evdw1ij*sss
2787 C
2788 C Calculate contributions to the Cartesian gradient.
2789 C
2790           ggg(1)=fac*xj*sssgrad
2791           ggg(2)=fac*yj*sssgrad
2792           ggg(3)=fac*zj*sssgrad
2793           do k=1,3
2794             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2795             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2796           enddo
2797 *
2798 * Loop over residues i+1 thru j-1.
2799 *
2800 cgrad          do k=i+1,j-1
2801 cgrad            do l=1,3
2802 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2803 cgrad            enddo
2804 cgrad          enddo
2805         enddo ! j
2806       enddo   ! i
2807 cgrad      do i=nnt,nct-1
2808 cgrad        do k=1,3
2809 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2810 cgrad        enddo
2811 cgrad        do j=i+1,nct-1
2812 cgrad          do k=1,3
2813 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2814 cgrad          enddo
2815 cgrad        enddo
2816 cgrad      enddo
2817       return
2818       end
2819 c------------------------------------------------------------------------------
2820       subroutine vec_and_deriv
2821       implicit real*8 (a-h,o-z)
2822       include 'DIMENSIONS'
2823 #ifdef MPI
2824       include 'mpif.h'
2825 #endif
2826       include 'COMMON.IOUNITS'
2827       include 'COMMON.GEO'
2828       include 'COMMON.VAR'
2829       include 'COMMON.LOCAL'
2830       include 'COMMON.CHAIN'
2831       include 'COMMON.VECTORS'
2832       include 'COMMON.SETUP'
2833       include 'COMMON.TIME1'
2834       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2835 C Compute the local reference systems. For reference system (i), the
2836 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2837 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2838 #ifdef PARVEC
2839       do i=ivec_start,ivec_end
2840 #else
2841       do i=1,nres-1
2842 #endif
2843           if (i.eq.nres-1) then
2844 C Case of the last full residue
2845 C Compute the Z-axis
2846             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2847             costh=dcos(pi-theta(nres))
2848             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2849             do k=1,3
2850               uz(k,i)=fac*uz(k,i)
2851             enddo
2852 C Compute the derivatives of uz
2853             uzder(1,1,1)= 0.0d0
2854             uzder(2,1,1)=-dc_norm(3,i-1)
2855             uzder(3,1,1)= dc_norm(2,i-1)
2856             uzder(1,2,1)= dc_norm(3,i-1)
2857             uzder(2,2,1)= 0.0d0
2858             uzder(3,2,1)=-dc_norm(1,i-1)
2859             uzder(1,3,1)=-dc_norm(2,i-1)
2860             uzder(2,3,1)= dc_norm(1,i-1)
2861             uzder(3,3,1)= 0.0d0
2862             uzder(1,1,2)= 0.0d0
2863             uzder(2,1,2)= dc_norm(3,i)
2864             uzder(3,1,2)=-dc_norm(2,i)
2865             uzder(1,2,2)=-dc_norm(3,i)
2866             uzder(2,2,2)= 0.0d0
2867             uzder(3,2,2)= dc_norm(1,i)
2868             uzder(1,3,2)= dc_norm(2,i)
2869             uzder(2,3,2)=-dc_norm(1,i)
2870             uzder(3,3,2)= 0.0d0
2871 C Compute the Y-axis
2872             facy=fac
2873             do k=1,3
2874               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2875             enddo
2876 C Compute the derivatives of uy
2877             do j=1,3
2878               do k=1,3
2879                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2880      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2881                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2882               enddo
2883               uyder(j,j,1)=uyder(j,j,1)-costh
2884               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2885             enddo
2886             do j=1,2
2887               do k=1,3
2888                 do l=1,3
2889                   uygrad(l,k,j,i)=uyder(l,k,j)
2890                   uzgrad(l,k,j,i)=uzder(l,k,j)
2891                 enddo
2892               enddo
2893             enddo
2894             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2895             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2896             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2897             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2898           else
2899 C Other residues
2900 C Compute the Z-axis
2901             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2902             costh=dcos(pi-theta(i+2))
2903             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2904             do k=1,3
2905               uz(k,i)=fac*uz(k,i)
2906             enddo
2907 C Compute the derivatives of uz
2908             uzder(1,1,1)= 0.0d0
2909             uzder(2,1,1)=-dc_norm(3,i+1)
2910             uzder(3,1,1)= dc_norm(2,i+1)
2911             uzder(1,2,1)= dc_norm(3,i+1)
2912             uzder(2,2,1)= 0.0d0
2913             uzder(3,2,1)=-dc_norm(1,i+1)
2914             uzder(1,3,1)=-dc_norm(2,i+1)
2915             uzder(2,3,1)= dc_norm(1,i+1)
2916             uzder(3,3,1)= 0.0d0
2917             uzder(1,1,2)= 0.0d0
2918             uzder(2,1,2)= dc_norm(3,i)
2919             uzder(3,1,2)=-dc_norm(2,i)
2920             uzder(1,2,2)=-dc_norm(3,i)
2921             uzder(2,2,2)= 0.0d0
2922             uzder(3,2,2)= dc_norm(1,i)
2923             uzder(1,3,2)= dc_norm(2,i)
2924             uzder(2,3,2)=-dc_norm(1,i)
2925             uzder(3,3,2)= 0.0d0
2926 C Compute the Y-axis
2927             facy=fac
2928             do k=1,3
2929               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2930             enddo
2931 C Compute the derivatives of uy
2932             do j=1,3
2933               do k=1,3
2934                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2935      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2936                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2937               enddo
2938               uyder(j,j,1)=uyder(j,j,1)-costh
2939               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2940             enddo
2941             do j=1,2
2942               do k=1,3
2943                 do l=1,3
2944                   uygrad(l,k,j,i)=uyder(l,k,j)
2945                   uzgrad(l,k,j,i)=uzder(l,k,j)
2946                 enddo
2947               enddo
2948             enddo
2949             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2950             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2951             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2952             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2953           endif
2954       enddo
2955       do i=1,nres-1
2956         vbld_inv_temp(1)=vbld_inv(i+1)
2957         if (i.lt.nres-1) then
2958           vbld_inv_temp(2)=vbld_inv(i+2)
2959           else
2960           vbld_inv_temp(2)=vbld_inv(i)
2961           endif
2962         do j=1,2
2963           do k=1,3
2964             do l=1,3
2965               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2966               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2967             enddo
2968           enddo
2969         enddo
2970       enddo
2971 #if defined(PARVEC) && defined(MPI)
2972       if (nfgtasks1.gt.1) then
2973         time00=MPI_Wtime()
2974 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2975 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2976 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2977         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2978      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2979      &   FG_COMM1,IERR)
2980         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2981      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2982      &   FG_COMM1,IERR)
2983         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2984      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2985      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2986         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2987      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2988      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2989         time_gather=time_gather+MPI_Wtime()-time00
2990       endif
2991 #endif
2992 #ifdef DEBUG
2993       if (fg_rank.eq.0) then
2994         write (iout,*) "Arrays UY and UZ"
2995         do i=1,nres-1
2996           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2997      &     (uz(k,i),k=1,3)
2998         enddo
2999       endif
3000 #endif
3001       return
3002       end
3003 C--------------------------------------------------------------------------
3004       subroutine set_matrices
3005       implicit real*8 (a-h,o-z)
3006       include 'DIMENSIONS'
3007 #ifdef MPI
3008       include "mpif.h"
3009       include "COMMON.SETUP"
3010       integer IERR
3011       integer status(MPI_STATUS_SIZE)
3012 #endif
3013       include 'COMMON.IOUNITS'
3014       include 'COMMON.GEO'
3015       include 'COMMON.VAR'
3016       include 'COMMON.LOCAL'
3017       include 'COMMON.CHAIN'
3018       include 'COMMON.DERIV'
3019       include 'COMMON.INTERACT'
3020       include 'COMMON.CORRMAT'
3021       include 'COMMON.TORSION'
3022       include 'COMMON.VECTORS'
3023       include 'COMMON.FFIELD'
3024       double precision auxvec(2),auxmat(2,2)
3025 C
3026 C Compute the virtual-bond-torsional-angle dependent quantities needed
3027 C to calculate the el-loc multibody terms of various order.
3028 C
3029 c      write(iout,*) 'nphi=',nphi,nres
3030 c      write(iout,*) "itype2loc",itype2loc
3031 #ifdef PARMAT
3032       do i=ivec_start+2,ivec_end+2
3033 #else
3034       do i=3,nres+1
3035 #endif
3036         ii=ireschain(i-2)
3037 c        write (iout,*) "i",i,i-2," ii",ii
3038         if (ii.eq.0) cycle
3039         innt=chain_border(1,ii)
3040         inct=chain_border(2,ii)
3041 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3042 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3043         if (i.gt. innt+2 .and. i.lt.inct+2) then
3044           iti = itype2loc(itype(i-2))
3045         else
3046           iti=nloctyp
3047         endif
3048 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3049         if (i.gt. innt+1 .and. i.lt.inct+1) then
3050           iti1 = itype2loc(itype(i-1))
3051         else
3052           iti1=nloctyp
3053         endif
3054 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3055 c     &  " iti1",itype(i-1),iti1
3056 #ifdef NEWCORR
3057         cost1=dcos(theta(i-1))
3058         sint1=dsin(theta(i-1))
3059         sint1sq=sint1*sint1
3060         sint1cub=sint1sq*sint1
3061         sint1cost1=2*sint1*cost1
3062 c        write (iout,*) "bnew1",i,iti
3063 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
3064 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3065 c        write (iout,*) "bnew2",i,iti
3066 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3067 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3068         do k=1,2
3069           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3070           b1(k,i-2)=sint1*b1k
3071           gtb1(k,i-2)=cost1*b1k-sint1sq*
3072      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3073           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3074           b2(k,i-2)=sint1*b2k
3075           gtb2(k,i-2)=cost1*b2k-sint1sq*
3076      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3077         enddo
3078         do k=1,2
3079           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3080           cc(1,k,i-2)=sint1sq*aux
3081           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3082      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3083           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3084           dd(1,k,i-2)=sint1sq*aux
3085           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3086      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3087         enddo
3088         cc(2,1,i-2)=cc(1,2,i-2)
3089         cc(2,2,i-2)=-cc(1,1,i-2)
3090         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3091         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3092         dd(2,1,i-2)=dd(1,2,i-2)
3093         dd(2,2,i-2)=-dd(1,1,i-2)
3094         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3095         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3096         do k=1,2
3097           do l=1,2
3098             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3099             EE(l,k,i-2)=sint1sq*aux
3100             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3101           enddo
3102         enddo
3103         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3104         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3105         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3106         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3107         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3108         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3109         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3110 c        b1tilde(1,i-2)=b1(1,i-2)
3111 c        b1tilde(2,i-2)=-b1(2,i-2)
3112 c        b2tilde(1,i-2)=b2(1,i-2)
3113 c        b2tilde(2,i-2)=-b2(2,i-2)
3114 #ifdef DEBUG
3115         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3116         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3117         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3118         write (iout,*) 'theta=', theta(i-1)
3119 #endif
3120 #else
3121         if (i.gt. innt+2 .and. i.lt.inct+2) then
3122 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3123           iti = itype2loc(itype(i-2))
3124         else
3125           iti=nloctyp
3126         endif
3127 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3128 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3129         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3130           iti1 = itype2loc(itype(i-1))
3131         else
3132           iti1=nloctyp
3133         endif
3134         b1(1,i-2)=b(3,iti)
3135         b1(2,i-2)=b(5,iti)
3136         b2(1,i-2)=b(2,iti)
3137         b2(2,i-2)=b(4,iti)
3138         do k=1,2
3139           do l=1,2
3140            CC(k,l,i-2)=ccold(k,l,iti)
3141            DD(k,l,i-2)=ddold(k,l,iti)
3142            EE(k,l,i-2)=eeold(k,l,iti)
3143            gtEE(k,l,i-2)=0.0d0
3144           enddo
3145         enddo
3146 #endif
3147         b1tilde(1,i-2)= b1(1,i-2)
3148         b1tilde(2,i-2)=-b1(2,i-2)
3149         b2tilde(1,i-2)= b2(1,i-2)
3150         b2tilde(2,i-2)=-b2(2,i-2)
3151 c
3152         Ctilde(1,1,i-2)= CC(1,1,i-2)
3153         Ctilde(1,2,i-2)= CC(1,2,i-2)
3154         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3155         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3156 c
3157         Dtilde(1,1,i-2)= DD(1,1,i-2)
3158         Dtilde(1,2,i-2)= DD(1,2,i-2)
3159         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3160         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3161 #ifdef DEBUG
3162         write(iout,*) "i",i," iti",iti
3163         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3164         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3165 #endif
3166       enddo
3167       mu(:,:nres)=0.0d0
3168 #ifdef PARMAT
3169       do i=ivec_start+2,ivec_end+2
3170 #else
3171       do i=3,nres+1
3172 #endif
3173 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3174         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3175           sin1=dsin(phi(i))
3176           cos1=dcos(phi(i))
3177           sintab(i-2)=sin1
3178           costab(i-2)=cos1
3179           obrot(1,i-2)=cos1
3180           obrot(2,i-2)=sin1
3181           sin2=dsin(2*phi(i))
3182           cos2=dcos(2*phi(i))
3183           sintab2(i-2)=sin2
3184           costab2(i-2)=cos2
3185           obrot2(1,i-2)=cos2
3186           obrot2(2,i-2)=sin2
3187           Ug(1,1,i-2)=-cos1
3188           Ug(1,2,i-2)=-sin1
3189           Ug(2,1,i-2)=-sin1
3190           Ug(2,2,i-2)= cos1
3191           Ug2(1,1,i-2)=-cos2
3192           Ug2(1,2,i-2)=-sin2
3193           Ug2(2,1,i-2)=-sin2
3194           Ug2(2,2,i-2)= cos2
3195         else
3196           costab(i-2)=1.0d0
3197           sintab(i-2)=0.0d0
3198           obrot(1,i-2)=1.0d0
3199           obrot(2,i-2)=0.0d0
3200           obrot2(1,i-2)=0.0d0
3201           obrot2(2,i-2)=0.0d0
3202           Ug(1,1,i-2)=1.0d0
3203           Ug(1,2,i-2)=0.0d0
3204           Ug(2,1,i-2)=0.0d0
3205           Ug(2,2,i-2)=1.0d0
3206           Ug2(1,1,i-2)=0.0d0
3207           Ug2(1,2,i-2)=0.0d0
3208           Ug2(2,1,i-2)=0.0d0
3209           Ug2(2,2,i-2)=0.0d0
3210         endif
3211         if (i .gt. 3) then
3212           obrot_der(1,i-2)=-sin1
3213           obrot_der(2,i-2)= cos1
3214           Ugder(1,1,i-2)= sin1
3215           Ugder(1,2,i-2)=-cos1
3216           Ugder(2,1,i-2)=-cos1
3217           Ugder(2,2,i-2)=-sin1
3218           dwacos2=cos2+cos2
3219           dwasin2=sin2+sin2
3220           obrot2_der(1,i-2)=-dwasin2
3221           obrot2_der(2,i-2)= dwacos2
3222           Ug2der(1,1,i-2)= dwasin2
3223           Ug2der(1,2,i-2)=-dwacos2
3224           Ug2der(2,1,i-2)=-dwacos2
3225           Ug2der(2,2,i-2)=-dwasin2
3226         else
3227           obrot_der(1,i-2)=0.0d0
3228           obrot_der(2,i-2)=0.0d0
3229           Ugder(1,1,i-2)=0.0d0
3230           Ugder(1,2,i-2)=0.0d0
3231           Ugder(2,1,i-2)=0.0d0
3232           Ugder(2,2,i-2)=0.0d0
3233           obrot2_der(1,i-2)=0.0d0
3234           obrot2_der(2,i-2)=0.0d0
3235           Ug2der(1,1,i-2)=0.0d0
3236           Ug2der(1,2,i-2)=0.0d0
3237           Ug2der(2,1,i-2)=0.0d0
3238           Ug2der(2,2,i-2)=0.0d0
3239         endif
3240 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3241 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3242         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3243           iti = itype2loc(itype(i-2))
3244         else
3245           iti=nloctyp
3246         endif
3247 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3248         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3249           iti1 = itype2loc(itype(i-1))
3250         else
3251           iti1=nloctyp
3252         endif
3253 cd        write (iout,*) '*******i',i,' iti1',iti
3254 cd        write (iout,*) 'b1',b1(:,iti)
3255 cd        write (iout,*) 'b2',b2(:,iti)
3256 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3257 c        if (i .gt. iatel_s+2) then
3258         if (i .gt. nnt+2) then
3259           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3260 #ifdef NEWCORR
3261           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3262 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3263 #endif
3264 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3265 c     &    EE(1,2,iti),EE(2,2,i)
3266           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3267           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3268 c          write(iout,*) "Macierz EUG",
3269 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3270 c     &    eug(2,2,i-2)
3271 #ifdef FOURBODY
3272           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3273      &    then
3274           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3275           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3276           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3277           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3278           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3279           endif
3280 #endif
3281         else
3282           do k=1,2
3283             Ub2(k,i-2)=0.0d0
3284             Ctobr(k,i-2)=0.0d0
3285             Dtobr2(k,i-2)=0.0d0
3286             do l=1,2
3287               EUg(l,k,i-2)=0.0d0
3288               CUg(l,k,i-2)=0.0d0
3289               DUg(l,k,i-2)=0.0d0
3290               DtUg2(l,k,i-2)=0.0d0
3291             enddo
3292           enddo
3293         endif
3294         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3295         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3296         do k=1,2
3297           muder(k,i-2)=Ub2der(k,i-2)
3298         enddo
3299 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3300         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3301           if (itype(i-1).le.ntyp) then
3302             iti1 = itype2loc(itype(i-1))
3303           else
3304             iti1=nloctyp
3305           endif
3306         else
3307           iti1=nloctyp
3308         endif
3309         do k=1,2
3310           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3311 c          mu(k,i-2)=b1(k,i-1)
3312 c          mu(k,i-2)=Ub2(k,i-2)
3313         enddo
3314 #ifdef MUOUT
3315         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3316      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3317      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3318      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3319      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3320      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3321 #endif
3322 cd        write (iout,*) 'mu1',mu1(:,i-2)
3323 cd        write (iout,*) 'mu2',mu2(:,i-2)
3324 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3325 #ifdef FOURBODY
3326         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3327      &  then
3328         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3329         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3330         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3331         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3332         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3333 C Vectors and matrices dependent on a single virtual-bond dihedral.
3334         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3335         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3336         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3337         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3338         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3339         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3340         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3341         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3342         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3343         endif
3344 #endif
3345       enddo
3346 #ifdef FOURBODY
3347 C Matrices dependent on two consecutive virtual-bond dihedrals.
3348 C The order of matrices is from left to right.
3349       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3350      &then
3351 c      do i=max0(ivec_start,2),ivec_end
3352       do i=2,nres-1
3353         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3354         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3355         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3356         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3357         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3358         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3359         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3360         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3361       enddo
3362       endif
3363 #endif
3364 #if defined(MPI) && defined(PARMAT)
3365 #ifdef DEBUG
3366 c      if (fg_rank.eq.0) then
3367         write (iout,*) "Arrays UG and UGDER before GATHER"
3368         do i=1,nres-1
3369           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3370      &     ((ug(l,k,i),l=1,2),k=1,2),
3371      &     ((ugder(l,k,i),l=1,2),k=1,2)
3372         enddo
3373         write (iout,*) "Arrays UG2 and UG2DER"
3374         do i=1,nres-1
3375           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3376      &     ((ug2(l,k,i),l=1,2),k=1,2),
3377      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3378         enddo
3379         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3380         do i=1,nres-1
3381           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3382      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3383      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3384         enddo
3385         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3386         do i=1,nres-1
3387           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3388      &     costab(i),sintab(i),costab2(i),sintab2(i)
3389         enddo
3390         write (iout,*) "Array MUDER"
3391         do i=1,nres-1
3392           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3393         enddo
3394 c      endif
3395 #endif
3396       if (nfgtasks.gt.1) then
3397         time00=MPI_Wtime()
3398 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3399 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3400 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3401 #ifdef MATGATHER
3402         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3403      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3404      &   FG_COMM1,IERR)
3405         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3406      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3407      &   FG_COMM1,IERR)
3408         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3409      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3410      &   FG_COMM1,IERR)
3411         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3412      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3413      &   FG_COMM1,IERR)
3414         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3415      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3416      &   FG_COMM1,IERR)
3417         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3418      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3419      &   FG_COMM1,IERR)
3420         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3421      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3422      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3423         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3424      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3425      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3426         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3427      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3428      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3429         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3430      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3431      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3432 #ifdef FOURBODY
3433         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3434      &  then
3435         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3436      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3437      &   FG_COMM1,IERR)
3438         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3439      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3440      &   FG_COMM1,IERR)
3441         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3442      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3443      &   FG_COMM1,IERR)
3444        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3445      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3446      &   FG_COMM1,IERR)
3447         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3448      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3449      &   FG_COMM1,IERR)
3450         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3451      &   ivec_count(fg_rank1),
3452      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3453      &   FG_COMM1,IERR)
3454         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3455      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3456      &   FG_COMM1,IERR)
3457         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3458      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3459      &   FG_COMM1,IERR)
3460         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3461      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3462      &   FG_COMM1,IERR)
3463         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3464      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3465      &   FG_COMM1,IERR)
3466         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3467      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3468      &   FG_COMM1,IERR)
3469         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3470      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3471      &   FG_COMM1,IERR)
3472         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3473      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3474      &   FG_COMM1,IERR)
3475         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3476      &   ivec_count(fg_rank1),
3477      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3478      &   FG_COMM1,IERR)
3479         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3480      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3481      &   FG_COMM1,IERR)
3482        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3483      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3484      &   FG_COMM1,IERR)
3485         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3486      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3487      &   FG_COMM1,IERR)
3488        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3489      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3490      &   FG_COMM1,IERR)
3491         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3492      &   ivec_count(fg_rank1),
3493      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3494      &   FG_COMM1,IERR)
3495         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3496      &   ivec_count(fg_rank1),
3497      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3498      &   FG_COMM1,IERR)
3499         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3500      &   ivec_count(fg_rank1),
3501      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3502      &   MPI_MAT2,FG_COMM1,IERR)
3503         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3504      &   ivec_count(fg_rank1),
3505      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3506      &   MPI_MAT2,FG_COMM1,IERR)
3507         endif
3508 #endif
3509 #else
3510 c Passes matrix info through the ring
3511       isend=fg_rank1
3512       irecv=fg_rank1-1
3513       if (irecv.lt.0) irecv=nfgtasks1-1
3514       iprev=irecv
3515       inext=fg_rank1+1
3516       if (inext.ge.nfgtasks1) inext=0
3517       do i=1,nfgtasks1-1
3518 c        write (iout,*) "isend",isend," irecv",irecv
3519 c        call flush(iout)
3520         lensend=lentyp(isend)
3521         lenrecv=lentyp(irecv)
3522 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3523 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3524 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3525 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3526 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3527 c        write (iout,*) "Gather ROTAT1"
3528 c        call flush(iout)
3529 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3530 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3531 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3532 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3533 c        write (iout,*) "Gather ROTAT2"
3534 c        call flush(iout)
3535         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3536      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3537      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3538      &   iprev,4400+irecv,FG_COMM,status,IERR)
3539 c        write (iout,*) "Gather ROTAT_OLD"
3540 c        call flush(iout)
3541         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3542      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3543      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3544      &   iprev,5500+irecv,FG_COMM,status,IERR)
3545 c        write (iout,*) "Gather PRECOMP11"
3546 c        call flush(iout)
3547         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3548      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3549      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3550      &   iprev,6600+irecv,FG_COMM,status,IERR)
3551 c        write (iout,*) "Gather PRECOMP12"
3552 c        call flush(iout)
3553 #ifdef FOURBODY
3554         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3555      &  then
3556         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3557      &   MPI_ROTAT2(lensend),inext,7700+isend,
3558      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3559      &   iprev,7700+irecv,FG_COMM,status,IERR)
3560 c        write (iout,*) "Gather PRECOMP21"
3561 c        call flush(iout)
3562         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3563      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3564      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3565      &   iprev,8800+irecv,FG_COMM,status,IERR)
3566 c        write (iout,*) "Gather PRECOMP22"
3567 c        call flush(iout)
3568         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3569      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3570      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3571      &   MPI_PRECOMP23(lenrecv),
3572      &   iprev,9900+irecv,FG_COMM,status,IERR)
3573 #endif
3574 c        write (iout,*) "Gather PRECOMP23"
3575 c        call flush(iout)
3576         endif
3577         isend=irecv
3578         irecv=irecv-1
3579         if (irecv.lt.0) irecv=nfgtasks1-1
3580       enddo
3581 #endif
3582         time_gather=time_gather+MPI_Wtime()-time00
3583       endif
3584 #ifdef DEBUG
3585 c      if (fg_rank.eq.0) then
3586         write (iout,*) "Arrays UG and UGDER"
3587         do i=1,nres-1
3588           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3589      &     ((ug(l,k,i),l=1,2),k=1,2),
3590      &     ((ugder(l,k,i),l=1,2),k=1,2)
3591         enddo
3592         write (iout,*) "Arrays UG2 and UG2DER"
3593         do i=1,nres-1
3594           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3595      &     ((ug2(l,k,i),l=1,2),k=1,2),
3596      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3597         enddo
3598         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3599         do i=1,nres-1
3600           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3601      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3602      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3603         enddo
3604         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3605         do i=1,nres-1
3606           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3607      &     costab(i),sintab(i),costab2(i),sintab2(i)
3608         enddo
3609         write (iout,*) "Array MUDER"
3610         do i=1,nres-1
3611           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3612         enddo
3613 c      endif
3614 #endif
3615 #endif
3616 cd      do i=1,nres
3617 cd        iti = itype2loc(itype(i))
3618 cd        write (iout,*) i
3619 cd        do j=1,2
3620 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3621 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3622 cd        enddo
3623 cd      enddo
3624       return
3625       end
3626 C-----------------------------------------------------------------------------
3627       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3628 C
3629 C This subroutine calculates the average interaction energy and its gradient
3630 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3631 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3632 C The potential depends both on the distance of peptide-group centers and on
3633 C the orientation of the CA-CA virtual bonds.
3634 C
3635       implicit real*8 (a-h,o-z)
3636 #ifdef MPI
3637       include 'mpif.h'
3638 #endif
3639       include 'DIMENSIONS'
3640       include 'COMMON.CONTROL'
3641       include 'COMMON.SETUP'
3642       include 'COMMON.IOUNITS'
3643       include 'COMMON.GEO'
3644       include 'COMMON.VAR'
3645       include 'COMMON.LOCAL'
3646       include 'COMMON.CHAIN'
3647       include 'COMMON.DERIV'
3648       include 'COMMON.INTERACT'
3649 #ifdef FOURBODY
3650       include 'COMMON.CONTACTS'
3651       include 'COMMON.CONTMAT'
3652 #endif
3653       include 'COMMON.CORRMAT'
3654       include 'COMMON.TORSION'
3655       include 'COMMON.VECTORS'
3656       include 'COMMON.FFIELD'
3657       include 'COMMON.TIME1'
3658       include 'COMMON.SPLITELE'
3659       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3660      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3661       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3662      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3663       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3664      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3665      &    num_conti,j1,j2
3666       double precision sslipi,sslipj,ssgradlipi,ssgradlipj
3667       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
3668 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3669 #ifdef MOMENT
3670       double precision scal_el /1.0d0/
3671 #else
3672       double precision scal_el /0.5d0/
3673 #endif
3674 C 12/13/98
3675 C 13-go grudnia roku pamietnego...
3676       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3677      &                   0.0d0,1.0d0,0.0d0,
3678      &                   0.0d0,0.0d0,1.0d0/
3679 cd      write(iout,*) 'In EELEC'
3680 cd      do i=1,nloctyp
3681 cd        write(iout,*) 'Type',i
3682 cd        write(iout,*) 'B1',B1(:,i)
3683 cd        write(iout,*) 'B2',B2(:,i)
3684 cd        write(iout,*) 'CC',CC(:,:,i)
3685 cd        write(iout,*) 'DD',DD(:,:,i)
3686 cd        write(iout,*) 'EE',EE(:,:,i)
3687 cd      enddo
3688 cd      call check_vecgrad
3689 cd      stop
3690       if (icheckgrad.eq.1) then
3691         do i=1,nres-1
3692           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3693           do k=1,3
3694             dc_norm(k,i)=dc(k,i)*fac
3695           enddo
3696 c          write (iout,*) 'i',i,' fac',fac
3697         enddo
3698       endif
3699       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3700      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3701      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3702 c        call vec_and_deriv
3703 #ifdef TIMING
3704         time01=MPI_Wtime()
3705 #endif
3706         call set_matrices
3707 #ifdef TIMING
3708         time_mat=time_mat+MPI_Wtime()-time01
3709 #endif
3710       endif
3711 cd      do i=1,nres-1
3712 cd        write (iout,*) 'i=',i
3713 cd        do k=1,3
3714 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3715 cd        enddo
3716 cd        do k=1,3
3717 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3718 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3719 cd        enddo
3720 cd      enddo
3721       t_eelecij=0.0d0
3722       ees=0.0D0
3723       evdw1=0.0D0
3724       eel_loc=0.0d0
3725       eello_turn3=0.0d0
3726       eello_turn4=0.0d0
3727       ind=0
3728 #ifdef FOURBODY
3729       do i=1,nres
3730         num_cont_hb(i)=0
3731       enddo
3732 #endif
3733 cd      print '(a)','Enter EELEC'
3734 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3735       do i=1,nres
3736         gel_loc_loc(i)=0.0d0
3737         gcorr_loc(i)=0.0d0
3738       enddo
3739 c
3740 c
3741 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3742 C
3743 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3744 C
3745 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3746       do i=iturn3_start,iturn3_end
3747 c        if (i.le.1) cycle
3748 C        write(iout,*) "tu jest i",i
3749         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3750 C changes suggested by Ana to avoid out of bounds
3751 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3752 c     & .or.((i+4).gt.nres)
3753 c     & .or.((i-1).le.0)
3754 C end of changes by Ana
3755      &  .or. itype(i+2).eq.ntyp1
3756      &  .or. itype(i+3).eq.ntyp1) cycle
3757 C Adam: Instructions below will switch off existing interactions
3758 c        if(i.gt.1)then
3759 c          if(itype(i-1).eq.ntyp1)cycle
3760 c        end if
3761 c        if(i.LT.nres-3)then
3762 c          if (itype(i+4).eq.ntyp1) cycle
3763 c        end if
3764         dxi=dc(1,i)
3765         dyi=dc(2,i)
3766         dzi=dc(3,i)
3767         dx_normi=dc_norm(1,i)
3768         dy_normi=dc_norm(2,i)
3769         dz_normi=dc_norm(3,i)
3770         xmedi=c(1,i)+0.5d0*dxi
3771         ymedi=c(2,i)+0.5d0*dyi
3772         zmedi=c(3,i)+0.5d0*dzi
3773         call to_box(xmedi,ymedi,zmedi)
3774         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3775         num_conti=0
3776         call eelecij(i,i+2,ees,evdw1,eel_loc)
3777         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3778 #ifdef FOURBODY
3779         num_cont_hb(i)=num_conti
3780 #endif
3781       enddo
3782       do i=iturn4_start,iturn4_end
3783         if (i.lt.1) cycle
3784         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3785 C changes suggested by Ana to avoid out of bounds
3786 c     & .or.((i+5).gt.nres)
3787 c     & .or.((i-1).le.0)
3788 C end of changes suggested by Ana
3789      &    .or. itype(i+3).eq.ntyp1
3790      &    .or. itype(i+4).eq.ntyp1
3791 c     &    .or. itype(i+5).eq.ntyp1
3792 c     &    .or. itype(i).eq.ntyp1
3793 c     &    .or. itype(i-1).eq.ntyp1
3794      &                             ) cycle
3795         dxi=dc(1,i)
3796         dyi=dc(2,i)
3797         dzi=dc(3,i)
3798         dx_normi=dc_norm(1,i)
3799         dy_normi=dc_norm(2,i)
3800         dz_normi=dc_norm(3,i)
3801         xmedi=c(1,i)+0.5d0*dxi
3802         ymedi=c(2,i)+0.5d0*dyi
3803         zmedi=c(3,i)+0.5d0*dzi
3804 C Return atom into box, boxxsize is size of box in x dimension
3805 c  194   continue
3806 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3807 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3808 C Condition for being inside the proper box
3809 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3810 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3811 c        go to 194
3812 c        endif
3813 c  195   continue
3814 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3815 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3816 C Condition for being inside the proper box
3817 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3818 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3819 c        go to 195
3820 c        endif
3821 c  196   continue
3822 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3823 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3824 C Condition for being inside the proper box
3825 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3826 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3827 c        go to 196
3828 c        endif
3829         call to_box(xmedi,ymedi,zmedi)
3830         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3831 #ifdef FOURBODY
3832         num_conti=num_cont_hb(i)
3833 #endif
3834 c        write(iout,*) "JESTEM W PETLI"
3835         call eelecij(i,i+3,ees,evdw1,eel_loc)
3836         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3837      &   call eturn4(i,eello_turn4)
3838 #ifdef FOURBODY
3839         num_cont_hb(i)=num_conti
3840 #endif
3841       enddo   ! i
3842 C Loop over all neighbouring boxes
3843 C      do xshift=-1,1
3844 C      do yshift=-1,1
3845 C      do zshift=-1,1
3846 c
3847 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3848 c
3849 CTU KURWA
3850 c      do i=iatel_s,iatel_e
3851       do ikont=g_listpp_start,g_listpp_end
3852         i=newcontlistppi(ikont)
3853         j=newcontlistppj(ikont)
3854 C        do i=75,75
3855 c        if (i.le.1) cycle
3856         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3857 C changes suggested by Ana to avoid out of bounds
3858 c     & .or.((i+2).gt.nres)
3859 c     & .or.((i-1).le.0)
3860 C end of changes by Ana
3861 c     &  .or. itype(i+2).eq.ntyp1
3862 c     &  .or. itype(i-1).eq.ntyp1
3863      &                ) cycle
3864         dxi=dc(1,i)
3865         dyi=dc(2,i)
3866         dzi=dc(3,i)
3867         dx_normi=dc_norm(1,i)
3868         dy_normi=dc_norm(2,i)
3869         dz_normi=dc_norm(3,i)
3870         xmedi=c(1,i)+0.5d0*dxi
3871         ymedi=c(2,i)+0.5d0*dyi
3872         zmedi=c(3,i)+0.5d0*dzi
3873         call to_box(xmedi,ymedi,zmedi)
3874         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3875 C          xmedi=xmedi+xshift*boxxsize
3876 C          ymedi=ymedi+yshift*boxysize
3877 C          zmedi=zmedi+zshift*boxzsize
3878
3879 C Return tom into box, boxxsize is size of box in x dimension
3880 c  164   continue
3881 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3882 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3883 C Condition for being inside the proper box
3884 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3885 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3886 c        go to 164
3887 c        endif
3888 c  165   continue
3889 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3890 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3891 C Condition for being inside the proper box
3892 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3893 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3894 c        go to 165
3895 c        endif
3896 c  166   continue
3897 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3898 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3899 cC Condition for being inside the proper box
3900 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3901 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3902 c        go to 166
3903 c        endif
3904
3905 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3906 #ifdef FOURBODY
3907         num_conti=num_cont_hb(i)
3908 #endif
3909 C I TU KURWA
3910 c        do j=ielstart(i),ielend(i)
3911 C          do j=16,17
3912 C          write (iout,*) i,j
3913 C         if (j.le.1) cycle
3914         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3915 C changes suggested by Ana to avoid out of bounds
3916 c     & .or.((j+2).gt.nres)
3917 c     & .or.((j-1).le.0)
3918 C end of changes by Ana
3919 c     & .or.itype(j+2).eq.ntyp1
3920 c     & .or.itype(j-1).eq.ntyp1
3921      &) cycle
3922         call eelecij(i,j,ees,evdw1,eel_loc)
3923 c        enddo ! j
3924 #ifdef FOURBODY
3925         num_cont_hb(i)=num_conti
3926 #endif
3927       enddo   ! i
3928 C     enddo   ! zshift
3929 C      enddo   ! yshift
3930 C      enddo   ! xshift
3931
3932 c      write (iout,*) "Number of loop steps in EELEC:",ind
3933 cd      do i=1,nres
3934 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3935 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3936 cd      enddo
3937 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3938 ccc      eel_loc=eel_loc+eello_turn3
3939 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3940       return
3941       end
3942 C-------------------------------------------------------------------------------
3943       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3944       implicit none
3945       include 'DIMENSIONS'
3946 #ifdef MPI
3947       include "mpif.h"
3948 #endif
3949       include 'COMMON.CONTROL'
3950       include 'COMMON.IOUNITS'
3951       include 'COMMON.GEO'
3952       include 'COMMON.VAR'
3953       include 'COMMON.LOCAL'
3954       include 'COMMON.CHAIN'
3955       include 'COMMON.DERIV'
3956       include 'COMMON.INTERACT'
3957 #ifdef FOURBODY
3958       include 'COMMON.CONTACTS'
3959       include 'COMMON.CONTMAT'
3960 #endif
3961       include 'COMMON.CORRMAT'
3962       include 'COMMON.TORSION'
3963       include 'COMMON.VECTORS'
3964       include 'COMMON.FFIELD'
3965       include 'COMMON.TIME1'
3966       include 'COMMON.SPLITELE'
3967       include 'COMMON.SHIELD'
3968       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3969      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3970       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3971      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3972      &    gmuij2(4),gmuji2(4)
3973       double precision dxi,dyi,dzi
3974       double precision dx_normi,dy_normi,dz_normi,aux
3975       integer j1,j2,lll,num_conti
3976       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3977      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3978      &    num_conti,j1,j2
3979       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3980       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3981       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3982       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3983      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3984      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3985      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3986      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3987      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3988      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3989      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3990       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3991       double precision xmedi,ymedi,zmedi
3992       double precision sscale,sscagrad,scalar
3993       double precision boxshift
3994       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
3995      & faclipij2
3996       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3997 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3998 #ifdef MOMENT
3999       double precision scal_el /1.0d0/
4000 #else
4001       double precision scal_el /0.5d0/
4002 #endif
4003 C 12/13/98
4004 C 13-go grudnia roku pamietnego...
4005       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4006      &                   0.0d0,1.0d0,0.0d0,
4007      &                   0.0d0,0.0d0,1.0d0/
4008 c          time00=MPI_Wtime()
4009 cd      write (iout,*) "eelecij",i,j
4010 c          ind=ind+1
4011 c          write (iout,*) "lipscale",lipscale
4012           iteli=itel(i)
4013           itelj=itel(j)
4014           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4015           aaa=app(iteli,itelj)
4016           bbb=bpp(iteli,itelj)
4017           ael6i=ael6(iteli,itelj)
4018           ael3i=ael3(iteli,itelj)
4019           dxj=dc(1,j)
4020           dyj=dc(2,j)
4021           dzj=dc(3,j)
4022           dx_normj=dc_norm(1,j)
4023           dy_normj=dc_norm(2,j)
4024           dz_normj=dc_norm(3,j)
4025 C          xj=c(1,j)+0.5D0*dxj-xmedi
4026 C          yj=c(2,j)+0.5D0*dyj-ymedi
4027 C          zj=c(3,j)+0.5D0*dzj-zmedi
4028           xj=c(1,j)+0.5D0*dxj
4029           yj=c(2,j)+0.5D0*dyj
4030           zj=c(3,j)+0.5D0*dzj
4031           call to_box(xj,yj,zj)
4032           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4033           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
4034           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4035           xj=boxshift(xj-xmedi,boxxsize)
4036           yj=boxshift(yj-ymedi,boxysize)
4037           zj=boxshift(zj-zmedi,boxzsize)
4038 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4039 c  174   continue
4040           rij=xj*xj+yj*yj+zj*zj
4041
4042           sss=sscale(dsqrt(rij),r_cut_int)
4043           if (sss.eq.0.0d0) return
4044           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
4045 c            if (sss.gt.0.0d0) then
4046           rrmij=1.0D0/rij
4047           rij=dsqrt(rij)
4048           rmij=1.0D0/rij
4049           r3ij=rrmij*rmij
4050           r6ij=r3ij*r3ij
4051           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4052           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4053           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4054           fac=cosa-3.0D0*cosb*cosg
4055           ev1=aaa*r6ij*r6ij
4056 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4057           if (j.eq.i+2) ev1=scal_el*ev1
4058           ev2=bbb*r6ij
4059           fac3=ael6i*r6ij
4060           fac4=ael3i*r3ij
4061           evdwij=(ev1+ev2)
4062           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4063           el2=fac4*fac
4064 C MARYSIA
4065 C          eesij=(el1+el2)
4066 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4067           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4068           if (shield_mode.gt.0) then
4069 C          fac_shield(i)=0.4
4070 C          fac_shield(j)=0.6
4071           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4072           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4073           eesij=(el1+el2)
4074           ees=ees+eesij*sss*faclipij2
4075           else
4076           fac_shield(i)=1.0
4077           fac_shield(j)=1.0
4078           eesij=(el1+el2)
4079           ees=ees+eesij*sss*faclipij2
4080           endif
4081           ees=ees
4082           evdw1=evdw1+evdwij*sss*faclipij2
4083 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4084 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4085 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4086 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4087
4088           if (energy_dec) then
4089             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4090      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4091             write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
4092      &        fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
4093      &        faclipij2
4094           endif
4095
4096 C
4097 C Calculate contributions to the Cartesian gradient.
4098 C
4099 #ifdef SPLITELE
4100           facvdw=-6*rrmij*(ev1+evdwij)*sss
4101           facel=-3*rrmij*(el1+eesij)
4102           fac1=fac
4103           erij(1)=xj*rmij
4104           erij(2)=yj*rmij
4105           erij(3)=zj*rmij
4106
4107 *
4108 * Radial derivatives. First process both termini of the fragment (i,j)
4109 *
4110           aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
4111           ggg(1)=aux*xj
4112           ggg(2)=aux*yj
4113           ggg(3)=aux*zj
4114           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4115      &  (shield_mode.gt.0)) then
4116 C          print *,i,j
4117           do ilist=1,ishield_list(i)
4118            iresshield=shield_list(ilist,i)
4119            do k=1,3
4120            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4121      &      *2.0
4122            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4123      &              rlocshield
4124      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4125             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4126 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4127 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4128 C             if (iresshield.gt.i) then
4129 C               do ishi=i+1,iresshield-1
4130 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4131 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4132 C
4133 C              enddo
4134 C             else
4135 C               do ishi=iresshield,i
4136 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4137 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4138 C
4139 C               enddo
4140 C              endif
4141            enddo
4142           enddo
4143           do ilist=1,ishield_list(j)
4144            iresshield=shield_list(ilist,j)
4145            do k=1,3
4146            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4147      &     *2.0*sss
4148            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4149      &              rlocshield
4150      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4151            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4152
4153 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4154 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4155 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4156 C             if (iresshield.gt.j) then
4157 C               do ishi=j+1,iresshield-1
4158 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4159 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4160 C
4161 C               enddo
4162 C            else
4163 C               do ishi=iresshield,j
4164 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4165 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4166 C               enddo
4167 C              endif
4168            enddo
4169           enddo
4170
4171           do k=1,3
4172             gshieldc(k,i)=gshieldc(k,i)+
4173      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4174             gshieldc(k,j)=gshieldc(k,j)+
4175      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4176             gshieldc(k,i-1)=gshieldc(k,i-1)+
4177      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4178             gshieldc(k,j-1)=gshieldc(k,j-1)+
4179      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4180
4181            enddo
4182            endif
4183 c          do k=1,3
4184 c            ghalf=0.5D0*ggg(k)
4185 c            gelc(k,i)=gelc(k,i)+ghalf
4186 c            gelc(k,j)=gelc(k,j)+ghalf
4187 c          enddo
4188 c 9/28/08 AL Gradient compotents will be summed only at the end
4189 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4190           do k=1,3
4191             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4192             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4193           enddo
4194           gelc_long(3,j)=gelc_long(3,j)+
4195      &      ssgradlipj*eesij/2.0d0*lipscale**2*sss
4196
4197           gelc_long(3,i)=gelc_long(3,i)+
4198      &      ssgradlipi*eesij/2.0d0*lipscale**2*sss
4199
4200
4201 *
4202 * Loop over residues i+1 thru j-1.
4203 *
4204 cgrad          do k=i+1,j-1
4205 cgrad            do l=1,3
4206 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4207 cgrad            enddo
4208 cgrad          enddo
4209           facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
4210           ggg(1)=facvdw*xj
4211           ggg(2)=facvdw*yj
4212           ggg(3)=facvdw*zj
4213 c          do k=1,3
4214 c            ghalf=0.5D0*ggg(k)
4215 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4216 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4217 c          enddo
4218 c 9/28/08 AL Gradient compotents will be summed only at the end
4219           do k=1,3
4220             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4221             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4222           enddo
4223 !C Lipidic part for scaling weight
4224           gvdwpp(3,j)=gvdwpp(3,j)+
4225      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4226           gvdwpp(3,i)=gvdwpp(3,i)+
4227      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4228 *
4229 * Loop over residues i+1 thru j-1.
4230 *
4231 cgrad          do k=i+1,j-1
4232 cgrad            do l=1,3
4233 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4234 cgrad            enddo
4235 cgrad          enddo
4236 #else
4237 C MARYSIA
4238           facvdw=(ev1+evdwij)*faclipij2
4239           facel=(el1+eesij)
4240           fac1=fac
4241           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4242      &       +(evdwij+eesij)*sssgrad*rrmij
4243           erij(1)=xj*rmij
4244           erij(2)=yj*rmij
4245           erij(3)=zj*rmij
4246 *
4247 * Radial derivatives. First process both termini of the fragment (i,j)
4248 *
4249           ggg(1)=fac*xj
4250 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4251           ggg(2)=fac*yj
4252 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4253           ggg(3)=fac*zj
4254 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4255 c          do k=1,3
4256 c            ghalf=0.5D0*ggg(k)
4257 c            gelc(k,i)=gelc(k,i)+ghalf
4258 c            gelc(k,j)=gelc(k,j)+ghalf
4259 c          enddo
4260 c 9/28/08 AL Gradient compotents will be summed only at the end
4261           do k=1,3
4262             gelc_long(k,j)=gelc(k,j)+ggg(k)
4263             gelc_long(k,i)=gelc(k,i)-ggg(k)
4264           enddo
4265 *
4266 * Loop over residues i+1 thru j-1.
4267 *
4268 cgrad          do k=i+1,j-1
4269 cgrad            do l=1,3
4270 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4271 cgrad            enddo
4272 cgrad          enddo
4273 c 9/28/08 AL Gradient compotents will be summed only at the end
4274           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4275           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4276           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4277           do k=1,3
4278             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4279             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4280           enddo
4281           gvdwpp(3,j)=gvdwpp(3,j)+
4282      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4283           gvdwpp(3,i)=gvdwpp(3,i)+
4284      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4285 #endif
4286 *
4287 * Angular part
4288 *
4289           ecosa=2.0D0*fac3*fac1+fac4
4290           fac4=-3.0D0*fac4
4291           fac3=-6.0D0*fac3
4292           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4293           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4294           do k=1,3
4295             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4296             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4297           enddo
4298 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4299 cd   &          (dcosg(k),k=1,3)
4300           do k=1,3
4301             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4302      &      fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
4303           enddo
4304 c          do k=1,3
4305 c            ghalf=0.5D0*ggg(k)
4306 c            gelc(k,i)=gelc(k,i)+ghalf
4307 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4308 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4309 c            gelc(k,j)=gelc(k,j)+ghalf
4310 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4311 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4312 c          enddo
4313 cgrad          do k=i+1,j-1
4314 cgrad            do l=1,3
4315 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4316 cgrad            enddo
4317 cgrad          enddo
4318 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4319           do k=1,3
4320             gelc(k,i)=gelc(k,i)
4321      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4322      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4323      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4324             gelc(k,j)=gelc(k,j)
4325      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4326      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4327      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4328             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4329             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4330           enddo
4331 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4332
4333 C MARYSIA
4334 c          endif !sscale
4335           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4336      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4337      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4338 C
4339 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4340 C   energy of a peptide unit is assumed in the form of a second-order
4341 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4342 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4343 C   are computed for EVERY pair of non-contiguous peptide groups.
4344 C
4345
4346           if (j.lt.nres-1) then
4347             j1=j+1
4348             j2=j-1
4349           else
4350             j1=j-1
4351             j2=j-2
4352           endif
4353           kkk=0
4354           lll=0
4355           do k=1,2
4356             do l=1,2
4357               kkk=kkk+1
4358               muij(kkk)=mu(k,i)*mu(l,j)
4359 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4360 #ifdef NEWCORR
4361              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4362 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4363              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4364              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4365 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4366              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4367 #endif
4368             enddo
4369           enddo
4370 #ifdef DEBUG
4371           write (iout,*) 'EELEC: i',i,' j',j
4372           write (iout,*) 'j',j,' j1',j1,' j2',j2
4373           write(iout,*) 'muij',muij
4374 #endif
4375           ury=scalar(uy(1,i),erij)
4376           urz=scalar(uz(1,i),erij)
4377           vry=scalar(uy(1,j),erij)
4378           vrz=scalar(uz(1,j),erij)
4379           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4380           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4381           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4382           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4383           fac=dsqrt(-ael6i)*r3ij
4384 #ifdef DEBUG
4385           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4386           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4387      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4388      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4389      &      "uzvz",scalar(uz(1,i),uz(1,j))
4390           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4391           write (iout,*) "fac",fac
4392 #endif
4393           a22=a22*fac
4394           a23=a23*fac
4395           a32=a32*fac
4396           a33=a33*fac
4397 #ifdef DEBUG
4398           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4399 #endif
4400 #undef DEBUG
4401 cd          write (iout,'(4i5,4f10.5)')
4402 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4403 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4404 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4405 cd     &      uy(:,j),uz(:,j)
4406 cd          write (iout,'(4f10.5)')
4407 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4408 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4409 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4410 cd           write (iout,'(9f10.5/)')
4411 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4412 C Derivatives of the elements of A in virtual-bond vectors
4413           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4414           do k=1,3
4415             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4416             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4417             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4418             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4419             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4420             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4421             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4422             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4423             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4424             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4425             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4426             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4427           enddo
4428 C Compute radial contributions to the gradient
4429           facr=-3.0d0*rrmij
4430           a22der=a22*facr
4431           a23der=a23*facr
4432           a32der=a32*facr
4433           a33der=a33*facr
4434           agg(1,1)=a22der*xj
4435           agg(2,1)=a22der*yj
4436           agg(3,1)=a22der*zj
4437           agg(1,2)=a23der*xj
4438           agg(2,2)=a23der*yj
4439           agg(3,2)=a23der*zj
4440           agg(1,3)=a32der*xj
4441           agg(2,3)=a32der*yj
4442           agg(3,3)=a32der*zj
4443           agg(1,4)=a33der*xj
4444           agg(2,4)=a33der*yj
4445           agg(3,4)=a33der*zj
4446 C Add the contributions coming from er
4447           fac3=-3.0d0*fac
4448           do k=1,3
4449             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4450             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4451             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4452             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4453           enddo
4454           do k=1,3
4455 C Derivatives in DC(i)
4456 cgrad            ghalf1=0.5d0*agg(k,1)
4457 cgrad            ghalf2=0.5d0*agg(k,2)
4458 cgrad            ghalf3=0.5d0*agg(k,3)
4459 cgrad            ghalf4=0.5d0*agg(k,4)
4460             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4461      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4462             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4463      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4464             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4465      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4466             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4467      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4468 C Derivatives in DC(i+1)
4469             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4470      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4471             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4472      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4473             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4474      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4475             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4476      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4477 C Derivatives in DC(j)
4478             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4479      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4480             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4481      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4482             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4483      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4484             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4485      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4486 C Derivatives in DC(j+1) or DC(nres-1)
4487             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4488      &      -3.0d0*vryg(k,3)*ury)
4489             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4490      &      -3.0d0*vrzg(k,3)*ury)
4491             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4492      &      -3.0d0*vryg(k,3)*urz)
4493             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4494      &      -3.0d0*vrzg(k,3)*urz)
4495 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4496 cgrad              do l=1,4
4497 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4498 cgrad              enddo
4499 cgrad            endif
4500           enddo
4501           acipa(1,1)=a22
4502           acipa(1,2)=a23
4503           acipa(2,1)=a32
4504           acipa(2,2)=a33
4505           a22=-a22
4506           a23=-a23
4507           do l=1,2
4508             do k=1,3
4509               agg(k,l)=-agg(k,l)
4510               aggi(k,l)=-aggi(k,l)
4511               aggi1(k,l)=-aggi1(k,l)
4512               aggj(k,l)=-aggj(k,l)
4513               aggj1(k,l)=-aggj1(k,l)
4514             enddo
4515           enddo
4516           if (j.lt.nres-1) then
4517             a22=-a22
4518             a32=-a32
4519             do l=1,3,2
4520               do k=1,3
4521                 agg(k,l)=-agg(k,l)
4522                 aggi(k,l)=-aggi(k,l)
4523                 aggi1(k,l)=-aggi1(k,l)
4524                 aggj(k,l)=-aggj(k,l)
4525                 aggj1(k,l)=-aggj1(k,l)
4526               enddo
4527             enddo
4528           else
4529             a22=-a22
4530             a23=-a23
4531             a32=-a32
4532             a33=-a33
4533             do l=1,4
4534               do k=1,3
4535                 agg(k,l)=-agg(k,l)
4536                 aggi(k,l)=-aggi(k,l)
4537                 aggi1(k,l)=-aggi1(k,l)
4538                 aggj(k,l)=-aggj(k,l)
4539                 aggj1(k,l)=-aggj1(k,l)
4540               enddo
4541             enddo
4542           endif
4543           ENDIF ! WCORR
4544           IF (wel_loc.gt.0.0d0) THEN
4545 C Contribution to the local-electrostatic energy coming from the i-j pair
4546           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4547      &     +a33*muij(4)
4548 #ifdef DEBUG
4549           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4550      &     " a33",a33
4551           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4552      &     " wel_loc",wel_loc
4553 #endif
4554           if (shield_mode.eq.0) then
4555            fac_shield(i)=1.0
4556            fac_shield(j)=1.0
4557 C          else
4558 C           fac_shield(i)=0.4
4559 C           fac_shield(j)=0.6
4560           endif
4561           eel_loc_ij=eel_loc_ij
4562      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4563 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4564 c     &            'eelloc',i,j,eel_loc_ij
4565 C Now derivative over eel_loc
4566           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4567      &  (shield_mode.gt.0)) then
4568 C          print *,i,j
4569
4570           do ilist=1,ishield_list(i)
4571            iresshield=shield_list(ilist,i)
4572            do k=1,3
4573            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4574      &                                          /fac_shield(i)
4575 C     &      *2.0
4576            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4577      &              rlocshield
4578      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4579             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4580      &      +rlocshield
4581            enddo
4582           enddo
4583           do ilist=1,ishield_list(j)
4584            iresshield=shield_list(ilist,j)
4585            do k=1,3
4586            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4587      &                                       /fac_shield(j)
4588 C     &     *2.0
4589            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4590      &              rlocshield
4591      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4592            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4593      &             +rlocshield
4594
4595            enddo
4596           enddo
4597
4598           do k=1,3
4599             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4600      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4601             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4602      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4603             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4604      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4605             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4606      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4607            enddo
4608            endif
4609
4610
4611 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4612 c     &                     ' eel_loc_ij',eel_loc_ij
4613 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4614 C Calculate patrial derivative for theta angle
4615 #ifdef NEWCORR
4616          geel_loc_ij=(a22*gmuij1(1)
4617      &     +a23*gmuij1(2)
4618      &     +a32*gmuij1(3)
4619      &     +a33*gmuij1(4))
4620      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4621 c         write(iout,*) "derivative over thatai"
4622 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4623 c     &   a33*gmuij1(4)
4624          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4625      &      geel_loc_ij*wel_loc
4626 c         write(iout,*) "derivative over thatai-1"
4627 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4628 c     &   a33*gmuij2(4)
4629          geel_loc_ij=
4630      &     a22*gmuij2(1)
4631      &     +a23*gmuij2(2)
4632      &     +a32*gmuij2(3)
4633      &     +a33*gmuij2(4)
4634          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4635      &      geel_loc_ij*wel_loc
4636      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4637
4638 c  Derivative over j residue
4639          geel_loc_ji=a22*gmuji1(1)
4640      &     +a23*gmuji1(2)
4641      &     +a32*gmuji1(3)
4642      &     +a33*gmuji1(4)
4643 c         write(iout,*) "derivative over thataj"
4644 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4645 c     &   a33*gmuji1(4)
4646
4647         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4648      &      geel_loc_ji*wel_loc
4649      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4650
4651          geel_loc_ji=
4652      &     +a22*gmuji2(1)
4653      &     +a23*gmuji2(2)
4654      &     +a32*gmuji2(3)
4655      &     +a33*gmuji2(4)
4656 c         write(iout,*) "derivative over thataj-1"
4657 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4658 c     &   a33*gmuji2(4)
4659          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4660      &      geel_loc_ji*wel_loc
4661      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4662 #endif
4663 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4664
4665           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4666      &            'eelloc',i,j,eel_loc_ij
4667 c           if (eel_loc_ij.ne.0)
4668 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4669 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4670
4671           eel_loc=eel_loc+eel_loc_ij
4672 C Partial derivatives in virtual-bond dihedral angles gamma
4673           if (i.gt.1)
4674      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4675      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4676      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4677      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4678
4679           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4680      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4681      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4682      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4683 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4684           aux=eel_loc_ij/sss*sssgrad*rmij
4685           ggg(1)=aux*xj
4686           ggg(2)=aux*yj
4687           ggg(3)=aux*zj
4688           do l=1,3
4689             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4690      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4691      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4692             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4693             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4694 cgrad            ghalf=0.5d0*ggg(l)
4695 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4696 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4697           enddo
4698           gel_loc_long(3,j)=gel_loc_long(3,j)+
4699      &      ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
4700
4701           gel_loc_long(3,i)=gel_loc_long(3,i)+
4702      &      ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
4703
4704 cgrad          do k=i+1,j2
4705 cgrad            do l=1,3
4706 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4707 cgrad            enddo
4708 cgrad          enddo
4709 C Remaining derivatives of eello
4710           do l=1,3
4711             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4712      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4713      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4714
4715             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4716      &        aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4717      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4718
4719             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4720      &        aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4721      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4722
4723             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4724      &        aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4725      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4726
4727           enddo
4728           ENDIF
4729 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4730 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4731 #ifdef FOURBODY
4732           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4733      &       .and. num_conti.le.maxconts) then
4734 c            write (iout,*) i,j," entered corr"
4735 C
4736 C Calculate the contact function. The ith column of the array JCONT will
4737 C contain the numbers of atoms that make contacts with the atom I (of numbers
4738 C greater than I). The arrays FACONT and GACONT will contain the values of
4739 C the contact function and its derivative.
4740 c           r0ij=1.02D0*rpp(iteli,itelj)
4741 c           r0ij=1.11D0*rpp(iteli,itelj)
4742             r0ij=2.20D0*rpp(iteli,itelj)
4743 c           r0ij=1.55D0*rpp(iteli,itelj)
4744             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4745             if (fcont.gt.0.0D0) then
4746               num_conti=num_conti+1
4747               if (num_conti.gt.maxconts) then
4748                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4749      &                         ' will skip next contacts for this conf.'
4750               else
4751                 jcont_hb(num_conti,i)=j
4752 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4753 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4754                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4755      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4756 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4757 C  terms.
4758                 d_cont(num_conti,i)=rij
4759 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4760 C     --- Electrostatic-interaction matrix ---
4761                 a_chuj(1,1,num_conti,i)=a22
4762                 a_chuj(1,2,num_conti,i)=a23
4763                 a_chuj(2,1,num_conti,i)=a32
4764                 a_chuj(2,2,num_conti,i)=a33
4765 C     --- Gradient of rij
4766                 do kkk=1,3
4767                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4768                 enddo
4769                 kkll=0
4770                 do k=1,2
4771                   do l=1,2
4772                     kkll=kkll+1
4773                     do m=1,3
4774                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4775                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4776                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4777                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4778                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4779                     enddo
4780                   enddo
4781                 enddo
4782                 ENDIF
4783                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4784 C Calculate contact energies
4785                 cosa4=4.0D0*cosa
4786                 wij=cosa-3.0D0*cosb*cosg
4787                 cosbg1=cosb+cosg
4788                 cosbg2=cosb-cosg
4789 c               fac3=dsqrt(-ael6i)/r0ij**3
4790                 fac3=dsqrt(-ael6i)*r3ij
4791 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4792                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4793                 if (ees0tmp.gt.0) then
4794                   ees0pij=dsqrt(ees0tmp)
4795                 else
4796                   ees0pij=0
4797                 endif
4798 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4799                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4800                 if (ees0tmp.gt.0) then
4801                   ees0mij=dsqrt(ees0tmp)
4802                 else
4803                   ees0mij=0
4804                 endif
4805 c               ees0mij=0.0D0
4806                 if (shield_mode.eq.0) then
4807                 fac_shield(i)=1.0d0
4808                 fac_shield(j)=1.0d0
4809                 else
4810                 ees0plist(num_conti,i)=j
4811 C                fac_shield(i)=0.4d0
4812 C                fac_shield(j)=0.6d0
4813                 endif
4814                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4815      &          *fac_shield(i)*fac_shield(j)*sss
4816                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4817      &          *fac_shield(i)*fac_shield(j)*sss
4818 C Diagnostics. Comment out or remove after debugging!
4819 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4820 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4821 c               ees0m(num_conti,i)=0.0D0
4822 C End diagnostics.
4823 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4824 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4825 C Angular derivatives of the contact function
4826                 ees0pij1=fac3/ees0pij
4827                 ees0mij1=fac3/ees0mij
4828                 fac3p=-3.0D0*fac3*rrmij
4829                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4830                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4831 c               ees0mij1=0.0D0
4832                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4833                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4834                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4835                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4836                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4837                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4838                 ecosap=ecosa1+ecosa2
4839                 ecosbp=ecosb1+ecosb2
4840                 ecosgp=ecosg1+ecosg2
4841                 ecosam=ecosa1-ecosa2
4842                 ecosbm=ecosb1-ecosb2
4843                 ecosgm=ecosg1-ecosg2
4844 C Diagnostics
4845 c               ecosap=ecosa1
4846 c               ecosbp=ecosb1
4847 c               ecosgp=ecosg1
4848 c               ecosam=0.0D0
4849 c               ecosbm=0.0D0
4850 c               ecosgm=0.0D0
4851 C End diagnostics
4852                 facont_hb(num_conti,i)=fcont
4853                 fprimcont=fprimcont/rij
4854 cd              facont_hb(num_conti,i)=1.0D0
4855 C Following line is for diagnostics.
4856 cd              fprimcont=0.0D0
4857                 do k=1,3
4858                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4859                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4860                 enddo
4861                 do k=1,3
4862                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4863                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4864                 enddo
4865                 gggp(1)=gggp(1)+ees0pijp*xj
4866      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4867                 gggp(2)=gggp(2)+ees0pijp*yj
4868      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4869                 gggp(3)=gggp(3)+ees0pijp*zj
4870      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4871                 gggm(1)=gggm(1)+ees0mijp*xj
4872      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4873                 gggm(2)=gggm(2)+ees0mijp*yj
4874      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4875                 gggm(3)=gggm(3)+ees0mijp*zj
4876      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4877 C Derivatives due to the contact function
4878                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4879                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4880                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4881                 do k=1,3
4882 c
4883 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4884 c          following the change of gradient-summation algorithm.
4885 c
4886 cgrad                  ghalfp=0.5D0*gggp(k)
4887 cgrad                  ghalfm=0.5D0*gggm(k)
4888                   gacontp_hb1(k,num_conti,i)=!ghalfp
4889      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4890      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4891      &          *fac_shield(i)*fac_shield(j)*sss
4892
4893                   gacontp_hb2(k,num_conti,i)=!ghalfp
4894      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4895      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4896      &          *fac_shield(i)*fac_shield(j)*sss
4897
4898                   gacontp_hb3(k,num_conti,i)=gggp(k)
4899      &          *fac_shield(i)*fac_shield(j)*sss
4900
4901                   gacontm_hb1(k,num_conti,i)=!ghalfm
4902      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4903      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4904      &          *fac_shield(i)*fac_shield(j)*sss
4905
4906                   gacontm_hb2(k,num_conti,i)=!ghalfm
4907      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4908      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4909      &          *fac_shield(i)*fac_shield(j)*sss
4910
4911                   gacontm_hb3(k,num_conti,i)=gggm(k)
4912      &          *fac_shield(i)*fac_shield(j)*sss
4913
4914                 enddo
4915 C Diagnostics. Comment out or remove after debugging!
4916 cdiag           do k=1,3
4917 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4918 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4919 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4920 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4921 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4922 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4923 cdiag           enddo
4924               ENDIF ! wcorr
4925               endif  ! num_conti.le.maxconts
4926             endif  ! fcont.gt.0
4927           endif    ! j.gt.i+1
4928 #endif
4929           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4930             do k=1,4
4931               do l=1,3
4932                 ghalf=0.5d0*agg(l,k)
4933                 aggi(l,k)=aggi(l,k)+ghalf
4934                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4935                 aggj(l,k)=aggj(l,k)+ghalf
4936               enddo
4937             enddo
4938             if (j.eq.nres-1 .and. i.lt.j-2) then
4939               do k=1,4
4940                 do l=1,3
4941                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4942                 enddo
4943               enddo
4944             endif
4945           endif
4946 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4947       return
4948       end
4949 C-----------------------------------------------------------------------------
4950       subroutine eturn3(i,eello_turn3)
4951 C Third- and fourth-order contributions from turns
4952       implicit real*8 (a-h,o-z)
4953       include 'DIMENSIONS'
4954       include 'COMMON.IOUNITS'
4955       include 'COMMON.GEO'
4956       include 'COMMON.VAR'
4957       include 'COMMON.LOCAL'
4958       include 'COMMON.CHAIN'
4959       include 'COMMON.DERIV'
4960       include 'COMMON.INTERACT'
4961       include 'COMMON.CORRMAT'
4962       include 'COMMON.TORSION'
4963       include 'COMMON.VECTORS'
4964       include 'COMMON.FFIELD'
4965       include 'COMMON.CONTROL'
4966       include 'COMMON.SHIELD'
4967       dimension ggg(3)
4968       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4969      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4970      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4971      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4972      &  auxgmat2(2,2),auxgmatt2(2,2)
4973       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4974      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4975       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4976      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4977      &    num_conti,j1,j2
4978       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4979       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4980       j=i+2
4981 c      write (iout,*) "eturn3",i,j,j1,j2
4982       a_temp(1,1)=a22
4983       a_temp(1,2)=a23
4984       a_temp(2,1)=a32
4985       a_temp(2,2)=a33
4986 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4987 C
4988 C               Third-order contributions
4989 C
4990 C                 (i+2)o----(i+3)
4991 C                      | |
4992 C                      | |
4993 C                 (i+1)o----i
4994 C
4995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4996 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4997         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4998 c auxalary matices for theta gradient
4999 c auxalary matrix for i+1 and constant i+2
5000         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5001 c auxalary matrix for i+2 and constant i+1
5002         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5003         call transpose2(auxmat(1,1),auxmat1(1,1))
5004         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5005         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5006         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5007         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5008         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5009         if (shield_mode.eq.0) then
5010         fac_shield(i)=1.0
5011         fac_shield(j)=1.0
5012 C        else
5013 C        fac_shield(i)=0.4
5014 C        fac_shield(j)=0.6
5015         endif
5016         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5017      &  *fac_shield(i)*fac_shield(j)*faclipij
5018         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5019      &  *fac_shield(i)*fac_shield(j)
5020         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5021      &    eello_t3
5022 C#ifdef NEWCORR
5023 C Derivatives in theta
5024         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5025      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5026      &   *fac_shield(i)*fac_shield(j)*faclipij
5027         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5028      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5029      &   *fac_shield(i)*fac_shield(j)*faclipij
5030 C#endif
5031
5032 C Derivatives in shield mode
5033           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5034      &  (shield_mode.gt.0)) then
5035 C          print *,i,j
5036
5037           do ilist=1,ishield_list(i)
5038            iresshield=shield_list(ilist,i)
5039            do k=1,3
5040            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5041 C     &      *2.0
5042            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5043      &              rlocshield
5044      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5045             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5046      &      +rlocshield
5047            enddo
5048           enddo
5049           do ilist=1,ishield_list(j)
5050            iresshield=shield_list(ilist,j)
5051            do k=1,3
5052            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5053 C     &     *2.0
5054            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5055      &              rlocshield
5056      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5057            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5058      &             +rlocshield
5059
5060            enddo
5061           enddo
5062
5063           do k=1,3
5064             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5065      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5066             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5067      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5068             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5069      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5070             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5071      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5072            enddo
5073            endif
5074
5075 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5076 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5077 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5078 cd     &    ' eello_turn3_num',4*eello_turn3_num
5079 C Derivatives in gamma(i)
5080         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5081         call transpose2(auxmat2(1,1),auxmat3(1,1))
5082         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5083         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5084      &   *fac_shield(i)*fac_shield(j)*faclipij
5085 C Derivatives in gamma(i+1)
5086         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5087         call transpose2(auxmat2(1,1),auxmat3(1,1))
5088         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5089         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5090      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5091      &   *fac_shield(i)*fac_shield(j)*faclipij
5092 C Cartesian derivatives
5093         do l=1,3
5094 c            ghalf1=0.5d0*agg(l,1)
5095 c            ghalf2=0.5d0*agg(l,2)
5096 c            ghalf3=0.5d0*agg(l,3)
5097 c            ghalf4=0.5d0*agg(l,4)
5098           a_temp(1,1)=aggi(l,1)!+ghalf1
5099           a_temp(1,2)=aggi(l,2)!+ghalf2
5100           a_temp(2,1)=aggi(l,3)!+ghalf3
5101           a_temp(2,2)=aggi(l,4)!+ghalf4
5102           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5103           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5104      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5105      &      *fac_shield(i)*fac_shield(j)*faclipij
5106
5107           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5108           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5109           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5110           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5111           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5112           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5113      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5114      &      *fac_shield(i)*fac_shield(j)*faclipij
5115           a_temp(1,1)=aggj(l,1)!+ghalf1
5116           a_temp(1,2)=aggj(l,2)!+ghalf2
5117           a_temp(2,1)=aggj(l,3)!+ghalf3
5118           a_temp(2,2)=aggj(l,4)!+ghalf4
5119           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5120           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5121      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5122      &      *fac_shield(i)*fac_shield(j)*faclipij
5123           a_temp(1,1)=aggj1(l,1)
5124           a_temp(1,2)=aggj1(l,2)
5125           a_temp(2,1)=aggj1(l,3)
5126           a_temp(2,2)=aggj1(l,4)
5127           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5128           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5129      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5130      &      *fac_shield(i)*fac_shield(j)*faclipij
5131         enddo
5132         gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5133      &    ssgradlipi*eello_t3/4.0d0*lipscale
5134         gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5135      &    ssgradlipj*eello_t3/4.0d0*lipscale
5136         gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5137      &    ssgradlipi*eello_t3/4.0d0*lipscale
5138         gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5139      &    ssgradlipj*eello_t3/4.0d0*lipscale
5140
5141       return
5142       end
5143 C-------------------------------------------------------------------------------
5144       subroutine eturn4(i,eello_turn4)
5145 C Third- and fourth-order contributions from turns
5146       implicit real*8 (a-h,o-z)
5147       include 'DIMENSIONS'
5148       include 'COMMON.IOUNITS'
5149       include 'COMMON.GEO'
5150       include 'COMMON.VAR'
5151       include 'COMMON.LOCAL'
5152       include 'COMMON.CHAIN'
5153       include 'COMMON.DERIV'
5154       include 'COMMON.INTERACT'
5155       include 'COMMON.CORRMAT'
5156       include 'COMMON.TORSION'
5157       include 'COMMON.VECTORS'
5158       include 'COMMON.FFIELD'
5159       include 'COMMON.CONTROL'
5160       include 'COMMON.SHIELD'
5161       dimension ggg(3)
5162       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5163      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5164      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5165      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5166      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5167      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5168      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5169       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5170      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5171       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5172      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5173      &    num_conti,j1,j2
5174       j=i+3
5175 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5176 C
5177 C               Fourth-order contributions
5178 C
5179 C                 (i+3)o----(i+4)
5180 C                     /  |
5181 C               (i+2)o   |
5182 C                     \  |
5183 C                 (i+1)o----i
5184 C
5185 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5186 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5187 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5188 c        write(iout,*)"WCHODZE W PROGRAM"
5189         a_temp(1,1)=a22
5190         a_temp(1,2)=a23
5191         a_temp(2,1)=a32
5192         a_temp(2,2)=a33
5193         iti1=itype2loc(itype(i+1))
5194         iti2=itype2loc(itype(i+2))
5195         iti3=itype2loc(itype(i+3))
5196 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5197         call transpose2(EUg(1,1,i+1),e1t(1,1))
5198         call transpose2(Eug(1,1,i+2),e2t(1,1))
5199         call transpose2(Eug(1,1,i+3),e3t(1,1))
5200 C Ematrix derivative in theta
5201         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5202         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5203         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5204         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5205 c       eta1 in derivative theta
5206         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5207         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5208 c       auxgvec is derivative of Ub2 so i+3 theta
5209         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5210 c       auxalary matrix of E i+1
5211         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5212 c        s1=0.0
5213 c        gs1=0.0
5214         s1=scalar2(b1(1,i+2),auxvec(1))
5215 c derivative of theta i+2 with constant i+3
5216         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5217 c derivative of theta i+2 with constant i+2
5218         gs32=scalar2(b1(1,i+2),auxgvec(1))
5219 c derivative of E matix in theta of i+1
5220         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5221
5222         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5223 c       ea31 in derivative theta
5224         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5225         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5226 c auxilary matrix auxgvec of Ub2 with constant E matirx
5227         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5228 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5229         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5230
5231 c        s2=0.0
5232 c        gs2=0.0
5233         s2=scalar2(b1(1,i+1),auxvec(1))
5234 c derivative of theta i+1 with constant i+3
5235         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5236 c derivative of theta i+2 with constant i+1
5237         gs21=scalar2(b1(1,i+1),auxgvec(1))
5238 c derivative of theta i+3 with constant i+1
5239         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5240 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5241 c     &  gtb1(1,i+1)
5242         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5243 c two derivatives over diffetent matrices
5244 c gtae3e2 is derivative over i+3
5245         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5246 c ae3gte2 is derivative over i+2
5247         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5248         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5249 c three possible derivative over theta E matices
5250 c i+1
5251         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5252 c i+2
5253         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5254 c i+3
5255         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5256         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5257
5258         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5259         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5260         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5261         if (shield_mode.eq.0) then
5262         fac_shield(i)=1.0
5263         fac_shield(j)=1.0
5264 C        else
5265 C        fac_shield(i)=0.6
5266 C        fac_shield(j)=0.4
5267         endif
5268         eello_turn4=eello_turn4-(s1+s2+s3)
5269      &  *fac_shield(i)*fac_shield(j)*faclipij
5270         eello_t4=-(s1+s2+s3)
5271      &  *fac_shield(i)*fac_shield(j)
5272 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5273         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5274      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5275 C Now derivative over shield:
5276           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5277      &  (shield_mode.gt.0)) then
5278 C          print *,i,j
5279
5280           do ilist=1,ishield_list(i)
5281            iresshield=shield_list(ilist,i)
5282            do k=1,3
5283            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5284 C     &      *2.0
5285            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5286      &              rlocshield
5287      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5288             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5289      &      +rlocshield
5290            enddo
5291           enddo
5292           do ilist=1,ishield_list(j)
5293            iresshield=shield_list(ilist,j)
5294            do k=1,3
5295            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5296 C     &     *2.0
5297            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5298      &              rlocshield
5299      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5300            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5301      &             +rlocshield
5302
5303            enddo
5304           enddo
5305
5306           do k=1,3
5307             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5308      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5309             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5310      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5311             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5312      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5313             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5314      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5315            enddo
5316            endif
5317 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5318 cd     &    ' eello_turn4_num',8*eello_turn4_num
5319 #ifdef NEWCORR
5320         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5321      &                  -(gs13+gsE13+gsEE1)*wturn4
5322      &  *fac_shield(i)*fac_shield(j)
5323         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5324      &                    -(gs23+gs21+gsEE2)*wturn4
5325      &  *fac_shield(i)*fac_shield(j)
5326
5327         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5328      &                    -(gs32+gsE31+gsEE3)*wturn4
5329      &  *fac_shield(i)*fac_shield(j)
5330
5331 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5332 c     &   gs2
5333 #endif
5334         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5335      &      'eturn4',i,j,-(s1+s2+s3)
5336 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5337 c     &    ' eello_turn4_num',8*eello_turn4_num
5338 C Derivatives in gamma(i)
5339         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5340         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5341         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5342         s1=scalar2(b1(1,i+2),auxvec(1))
5343         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5344         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5345         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5346      &  *fac_shield(i)*fac_shield(j)*faclipij
5347 C Derivatives in gamma(i+1)
5348         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5349         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5350         s2=scalar2(b1(1,i+1),auxvec(1))
5351         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5352         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5353         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5354         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5355      &  *fac_shield(i)*fac_shield(j)*faclipij
5356 C Derivatives in gamma(i+2)
5357         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5358         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5359         s1=scalar2(b1(1,i+2),auxvec(1))
5360         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5361         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5362         s2=scalar2(b1(1,i+1),auxvec(1))
5363         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5364         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5365         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5366         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5367      &  *fac_shield(i)*fac_shield(j)*faclipij
5368 C Cartesian derivatives
5369 C Derivatives of this turn contributions in DC(i+2)
5370         if (j.lt.nres-1) then
5371           do l=1,3
5372             a_temp(1,1)=agg(l,1)
5373             a_temp(1,2)=agg(l,2)
5374             a_temp(2,1)=agg(l,3)
5375             a_temp(2,2)=agg(l,4)
5376             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5377             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5378             s1=scalar2(b1(1,i+2),auxvec(1))
5379             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5380             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5381             s2=scalar2(b1(1,i+1),auxvec(1))
5382             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5383             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5384             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5385             ggg(l)=-(s1+s2+s3)
5386             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5387      &       *fac_shield(i)*fac_shield(j)*faclipij
5388           enddo
5389         endif
5390 C Remaining derivatives of this turn contribution
5391         do l=1,3
5392           a_temp(1,1)=aggi(l,1)
5393           a_temp(1,2)=aggi(l,2)
5394           a_temp(2,1)=aggi(l,3)
5395           a_temp(2,2)=aggi(l,4)
5396           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5397           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5398           s1=scalar2(b1(1,i+2),auxvec(1))
5399           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5400           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5401           s2=scalar2(b1(1,i+1),auxvec(1))
5402           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5403           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5404           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5405           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5406      &     *fac_shield(i)*fac_shield(j)*faclipij
5407           a_temp(1,1)=aggi1(l,1)
5408           a_temp(1,2)=aggi1(l,2)
5409           a_temp(2,1)=aggi1(l,3)
5410           a_temp(2,2)=aggi1(l,4)
5411           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5412           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5413           s1=scalar2(b1(1,i+2),auxvec(1))
5414           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5415           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5416           s2=scalar2(b1(1,i+1),auxvec(1))
5417           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5418           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5419           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5420           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5421      &      *fac_shield(i)*fac_shield(j)*faclipij
5422           a_temp(1,1)=aggj(l,1)
5423           a_temp(1,2)=aggj(l,2)
5424           a_temp(2,1)=aggj(l,3)
5425           a_temp(2,2)=aggj(l,4)
5426           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5427           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5428           s1=scalar2(b1(1,i+2),auxvec(1))
5429           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5430           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5431           s2=scalar2(b1(1,i+1),auxvec(1))
5432           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5433           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5434           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5435           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5436      &      *fac_shield(i)*fac_shield(j)*faclipij
5437           a_temp(1,1)=aggj1(l,1)
5438           a_temp(1,2)=aggj1(l,2)
5439           a_temp(2,1)=aggj1(l,3)
5440           a_temp(2,2)=aggj1(l,4)
5441           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5442           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5443           s1=scalar2(b1(1,i+2),auxvec(1))
5444           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5445           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5446           s2=scalar2(b1(1,i+1),auxvec(1))
5447           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5448           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5449           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5450 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5451           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5452      &      *fac_shield(i)*fac_shield(j)*faclipij
5453         enddo
5454         gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5455      &    ssgradlipi*eello_t4/4.0d0*lipscale
5456         gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5457      &    ssgradlipj*eello_t4/4.0d0*lipscale
5458         gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5459      &    ssgradlipi*eello_t4/4.0d0*lipscale
5460         gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5461      &    ssgradlipj*eello_t4/4.0d0*lipscale
5462       return
5463       end
5464 C-----------------------------------------------------------------------------
5465       subroutine vecpr(u,v,w)
5466       implicit real*8(a-h,o-z)
5467       dimension u(3),v(3),w(3)
5468       w(1)=u(2)*v(3)-u(3)*v(2)
5469       w(2)=-u(1)*v(3)+u(3)*v(1)
5470       w(3)=u(1)*v(2)-u(2)*v(1)
5471       return
5472       end
5473 C-----------------------------------------------------------------------------
5474       subroutine unormderiv(u,ugrad,unorm,ungrad)
5475 C This subroutine computes the derivatives of a normalized vector u, given
5476 C the derivatives computed without normalization conditions, ugrad. Returns
5477 C ungrad.
5478       implicit none
5479       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5480       double precision vec(3)
5481       double precision scalar
5482       integer i,j
5483 c      write (2,*) 'ugrad',ugrad
5484 c      write (2,*) 'u',u
5485       do i=1,3
5486         vec(i)=scalar(ugrad(1,i),u(1))
5487       enddo
5488 c      write (2,*) 'vec',vec
5489       do i=1,3
5490         do j=1,3
5491           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5492         enddo
5493       enddo
5494 c      write (2,*) 'ungrad',ungrad
5495       return
5496       end
5497 C-----------------------------------------------------------------------------
5498       subroutine escp_soft_sphere(evdw2,evdw2_14)
5499 C
5500 C This subroutine calculates the excluded-volume interaction energy between
5501 C peptide-group centers and side chains and its gradient in virtual-bond and
5502 C side-chain vectors.
5503 C
5504       implicit real*8 (a-h,o-z)
5505       include 'DIMENSIONS'
5506       include 'COMMON.GEO'
5507       include 'COMMON.VAR'
5508       include 'COMMON.LOCAL'
5509       include 'COMMON.CHAIN'
5510       include 'COMMON.DERIV'
5511       include 'COMMON.INTERACT'
5512       include 'COMMON.FFIELD'
5513       include 'COMMON.IOUNITS'
5514       include 'COMMON.CONTROL'
5515       dimension ggg(3)
5516       double precision boxshift
5517       evdw2=0.0D0
5518       evdw2_14=0.0d0
5519       r0_scp=4.5d0
5520 cd    print '(a)','Enter ESCP'
5521 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5522 C      do xshift=-1,1
5523 C      do yshift=-1,1
5524 C      do zshift=-1,1
5525 c      do i=iatscp_s,iatscp_e
5526       do ikont=g_listscp_start,g_listscp_end
5527         i=newcontlistscpi(ikont)
5528         j=newcontlistscpj(ikont)
5529         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5530         iteli=itel(i)
5531         xi=0.5D0*(c(1,i)+c(1,i+1))
5532         yi=0.5D0*(c(2,i)+c(2,i+1))
5533         zi=0.5D0*(c(3,i)+c(3,i+1))
5534 C Return atom into box, boxxsize is size of box in x dimension
5535 c  134   continue
5536 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5537 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5538 C Condition for being inside the proper box
5539 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5540 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5541 c        go to 134
5542 c        endif
5543 c  135   continue
5544 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5545 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5546 C Condition for being inside the proper box
5547 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5548 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5549 c        go to 135
5550 c c       endif
5551 c  136   continue
5552 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5553 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5554 cC Condition for being inside the proper box
5555 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5556 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5557 c        go to 136
5558 c        endif
5559           call to_box(xi,yi,zi)
5560 C          xi=xi+xshift*boxxsize
5561 C          yi=yi+yshift*boxysize
5562 C          zi=zi+zshift*boxzsize
5563 c        do iint=1,nscp_gr(i)
5564
5565 c        do j=iscpstart(i,iint),iscpend(i,iint)
5566           if (itype(j).eq.ntyp1) cycle
5567           itypj=iabs(itype(j))
5568 C Uncomment following three lines for SC-p interactions
5569 c         xj=c(1,nres+j)-xi
5570 c         yj=c(2,nres+j)-yi
5571 c         zj=c(3,nres+j)-zi
5572 C Uncomment following three lines for Ca-p interactions
5573           xj=c(1,j)
5574           yj=c(2,j)
5575           zj=c(3,j)
5576           call to_box(xj,yj,zj)
5577           xj=boxshift(xj-xi,boxxsize)
5578           yj=boxshift(yj-yi,boxysize)
5579           zj=boxshift(zj-zi,boxzsize)
5580 C          xj=xj-xi
5581 C          yj=yj-yi
5582 C          zj=zj-zi
5583           rij=xj*xj+yj*yj+zj*zj
5584
5585           r0ij=r0_scp
5586           r0ijsq=r0ij*r0ij
5587           if (rij.lt.r0ijsq) then
5588             evdwij=0.25d0*(rij-r0ijsq)**2
5589             fac=rij-r0ijsq
5590           else
5591             evdwij=0.0d0
5592             fac=0.0d0
5593           endif
5594           evdw2=evdw2+evdwij
5595 C
5596 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5597 C
5598           ggg(1)=xj*fac
5599           ggg(2)=yj*fac
5600           ggg(3)=zj*fac
5601           do k=1,3
5602             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5603             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5604           enddo
5605 c        enddo
5606
5607 c        enddo ! iint
5608       enddo ! i
5609 C      enddo !zshift
5610 C      enddo !yshift
5611 C      enddo !xshift
5612       return
5613       end
5614 C-----------------------------------------------------------------------------
5615       subroutine escp(evdw2,evdw2_14)
5616 C
5617 C This subroutine calculates the excluded-volume interaction energy between
5618 C peptide-group centers and side chains and its gradient in virtual-bond and
5619 C side-chain vectors.
5620 C
5621       implicit none
5622 #ifdef MPI
5623       include 'mpif.h'
5624 #endif
5625       include 'DIMENSIONS'
5626       include 'COMMON.GEO'
5627       include 'COMMON.VAR'
5628       include 'COMMON.LOCAL'
5629       include 'COMMON.CHAIN'
5630       include 'COMMON.DERIV'
5631       include 'COMMON.INTERACT'
5632       include 'COMMON.FFIELD'
5633       include 'COMMON.IOUNITS'
5634       include 'COMMON.CONTROL'
5635       include 'COMMON.SPLITELE'
5636       include 'COMMON.TIME1'
5637       double precision ggg(3)
5638       integer i,iint,j,k,iteli,itypj,subchap,ikont
5639       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5640      & fac,e1,e2,rij
5641       double precision evdw2,evdw2_14,evdwij
5642       double precision sscale,sscagrad
5643       double precision boxshift
5644       external boxshift,to_box
5645 c#ifdef TIMING_ENE
5646 c      double precision time01
5647 c#endif
5648       evdw2=0.0D0
5649       evdw2_14=0.0d0
5650 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5651 cd    print '(a)','Enter ESCP'
5652 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5653 C      do xshift=-1,1
5654 C      do yshift=-1,1
5655 C      do zshift=-1,1
5656       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5657 c      do i=iatscp_s,iatscp_e
5658       do ikont=g_listscp_start,g_listscp_end
5659 c#ifdef TIMING_ENE
5660 c        time01=MPI_Wtime()
5661 c#endif
5662         i=newcontlistscpi(ikont)
5663         j=newcontlistscpj(ikont)
5664         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5665         iteli=itel(i)
5666         xi=0.5D0*(c(1,i)+c(1,i+1))
5667         yi=0.5D0*(c(2,i)+c(2,i+1))
5668         zi=0.5D0*(c(3,i)+c(3,i+1))
5669 !DIR$ INLINE
5670         call to_box(xi,yi,zi)
5671 c        do iint=1,nscp_gr(i)
5672
5673 c        do j=iscpstart(i,iint),iscpend(i,iint)
5674           itypj=iabs(itype(j))
5675           if (itypj.eq.ntyp1) cycle
5676 C Uncomment following three lines for SC-p interactions
5677 c         xj=c(1,nres+j)-xi
5678 c         yj=c(2,nres+j)-yi
5679 c         zj=c(3,nres+j)-zi
5680 C Uncomment following three lines for Ca-p interactions
5681           xj=c(1,j)
5682           yj=c(2,j)
5683           zj=c(3,j)
5684 !DIR$ INLINE
5685           call to_box(xj,yj,zj)
5686 c#ifdef TIMING_ENE
5687 c       time_escpsetup=time_escpsetup+MPI_Wtime()-time01
5688 c       time01=MPI_Wtime()
5689 c#endif
5690 !DIR$ INLINE
5691           xj=boxshift(xj-xi,boxxsize)
5692           yj=boxshift(yj-yi,boxysize)
5693           zj=boxshift(zj-zi,boxzsize)
5694 c          print *,xj,yj,zj,'polozenie j'
5695 c#ifdef TIMING_ENE
5696 c       time_escpsetup=time_escpsetup+MPI_Wtime()-time01
5697 c       time01=MPI_Wtime()
5698 c#endif
5699           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5700 c          print *,rrij
5701           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5702 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5703 c          if (sss.eq.0) print *,'czasem jest OK'
5704           if (sss.le.0.0d0) cycle
5705           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5706           fac=rrij**expon2
5707           e1=fac*fac*aad(itypj,iteli)
5708           e2=fac*bad(itypj,iteli)
5709           if (iabs(j-i) .le. 2) then
5710             e1=scal14*e1
5711             e2=scal14*e2
5712             evdw2_14=evdw2_14+(e1+e2)*sss
5713           endif
5714           evdwij=e1+e2
5715           evdw2=evdw2+evdwij*sss
5716           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5717      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5718      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5719      &       bad(itypj,iteli)
5720 C
5721 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5722 C
5723           fac=-(evdwij+e1)*rrij*sss
5724           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5725           ggg(1)=xj*fac
5726           ggg(2)=yj*fac
5727           ggg(3)=zj*fac
5728 cgrad          if (j.lt.i) then
5729 cd          write (iout,*) 'j<i'
5730 C Uncomment following three lines for SC-p interactions
5731 c           do k=1,3
5732 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5733 c           enddo
5734 cgrad          else
5735 cd          write (iout,*) 'j>i'
5736 cgrad            do k=1,3
5737 cgrad              ggg(k)=-ggg(k)
5738 C Uncomment following line for SC-p interactions
5739 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5740 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5741 cgrad            enddo
5742 cgrad          endif
5743 cgrad          do k=1,3
5744 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5745 cgrad          enddo
5746 cgrad          kstart=min0(i+1,j)
5747 cgrad          kend=max0(i-1,j-1)
5748 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5749 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5750 cgrad          do k=kstart,kend
5751 cgrad            do l=1,3
5752 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5753 cgrad            enddo
5754 cgrad          enddo
5755           do k=1,3
5756             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5757             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5758           enddo
5759 c#ifdef TIMING_ENE
5760 c          time_escpcalc=time_escpcalc+MPI_Wtime()-time01
5761 c#endif
5762 c        endif !endif for sscale cutoff
5763 c        enddo ! j
5764
5765 c        enddo ! iint
5766       enddo ! i
5767 c      enddo !zshift
5768 c      enddo !yshift
5769 c      enddo !xshift
5770       do i=1,nct
5771         do j=1,3
5772           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5773           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5774           gradx_scp(j,i)=expon*gradx_scp(j,i)
5775         enddo
5776       enddo
5777 C******************************************************************************
5778 C
5779 C                              N O T E !!!
5780 C
5781 C To save time the factor EXPON has been extracted from ALL components
5782 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5783 C use!
5784 C
5785 C******************************************************************************
5786       return
5787       end
5788 C--------------------------------------------------------------------------
5789       subroutine edis(ehpb)
5790 C
5791 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5792 C
5793       implicit real*8 (a-h,o-z)
5794       include 'DIMENSIONS'
5795       include 'COMMON.SBRIDGE'
5796       include 'COMMON.CHAIN'
5797       include 'COMMON.DERIV'
5798       include 'COMMON.VAR'
5799       include 'COMMON.INTERACT'
5800       include 'COMMON.IOUNITS'
5801       include 'COMMON.CONTROL'
5802       dimension ggg(3),ggg_peak(3,1000)
5803       ehpb=0.0D0
5804       do i=1,3
5805        ggg(i)=0.0d0
5806       enddo
5807 c 8/21/18 AL: added explicit restraints on reference coords
5808 c      write (iout,*) "restr_on_coord",restr_on_coord
5809       if (restr_on_coord) then
5810
5811       do i=nnt,nct
5812         ecoor=0.0d0
5813         if (itype(i).eq.ntyp1) cycle
5814         do j=1,3
5815           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5816           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5817         enddo
5818         if (itype(i).ne.10) then
5819           do j=1,3
5820             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5821             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5822           enddo
5823         endif
5824         if (energy_dec) write (iout,*)
5825      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5826         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5827       enddo
5828
5829       endif
5830 C      write (iout,*) ,"link_end",link_end,constr_dist
5831 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5832 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5833 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5834 c     &  " link_end_peak",link_end_peak
5835       if (link_end.eq.0.and.link_end_peak.eq.0) return
5836       do i=link_start_peak,link_end_peak
5837         ehpb_peak=0.0d0
5838 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5839 c     &   ipeak(1,i),ipeak(2,i)
5840         do ip=ipeak(1,i),ipeak(2,i)
5841           ii=ihpb_peak(ip)
5842           jj=jhpb_peak(ip)
5843           dd=dist(ii,jj)
5844           iip=ip-ipeak(1,i)+1
5845 C iii and jjj point to the residues for which the distance is assigned.
5846 c          if (ii.gt.nres) then
5847 c            iii=ii-nres
5848 c            jjj=jj-nres
5849 c          else
5850 c            iii=ii
5851 c            jjj=jj
5852 c          endif
5853           if (ii.gt.nres) then
5854             iii=ii-nres
5855           else
5856             iii=ii
5857           endif
5858           if (jj.gt.nres) then
5859             jjj=jj-nres
5860           else
5861             jjj=jj
5862           endif
5863           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5864           aux=dexp(-scal_peak*aux)
5865           ehpb_peak=ehpb_peak+aux
5866           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5867      &      forcon_peak(ip))*aux/dd
5868           do j=1,3
5869             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5870           enddo
5871           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5872      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5873      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5874         enddo
5875 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5876         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5877         do ip=ipeak(1,i),ipeak(2,i)
5878           iip=ip-ipeak(1,i)+1
5879           do j=1,3
5880             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5881           enddo
5882           ii=ihpb_peak(ip)
5883           jj=jhpb_peak(ip)
5884 C iii and jjj point to the residues for which the distance is assigned.
5885 c          if (ii.gt.nres) then
5886 c            iii=ii-nres
5887 c            jjj=jj-nres
5888 c          else
5889 c            iii=ii
5890 c            jjj=jj
5891 c          endif
5892           if (ii.gt.nres) then
5893             iii=ii-nres
5894           else
5895             iii=ii
5896           endif
5897           if (jj.gt.nres) then
5898             jjj=jj-nres
5899           else
5900             jjj=jj
5901           endif
5902           if (iii.lt.ii) then
5903             do j=1,3
5904               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5905             enddo
5906           endif
5907           if (jjj.lt.jj) then
5908             do j=1,3
5909               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5910             enddo
5911           endif
5912           do k=1,3
5913             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5914             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5915           enddo
5916         enddo
5917       enddo
5918       do i=link_start,link_end
5919 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5920 C CA-CA distance used in regularization of structure.
5921         ii=ihpb(i)
5922         jj=jhpb(i)
5923 C iii and jjj point to the residues for which the distance is assigned.
5924         if (ii.gt.nres) then
5925           iii=ii-nres
5926         else
5927           iii=ii
5928         endif
5929         if (jj.gt.nres) then
5930           jjj=jj-nres
5931         else
5932           jjj=jj
5933         endif
5934 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5935 c     &    dhpb(i),dhpb1(i),forcon(i)
5936 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5937 C    distance and angle dependent SS bond potential.
5938 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5939 C     & iabs(itype(jjj)).eq.1) then
5940 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5941 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5942         if (.not.dyn_ss .and. i.le.nss) then
5943 C 15/02/13 CC dynamic SSbond - additional check
5944           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5945      &        iabs(itype(jjj)).eq.1) then
5946            call ssbond_ene(iii,jjj,eij)
5947 c           ehpb=ehpb+2*eij
5948            ehpb=ehpb+eij
5949          endif
5950 cd          write (iout,*) "eij",eij
5951 cd   &   ' waga=',waga,' fac=',fac
5952 !        else if (ii.gt.nres .and. jj.gt.nres) then
5953         else
5954 C Calculate the distance between the two points and its difference from the
5955 C target distance.
5956           dd=dist(ii,jj)
5957           if (irestr_type(i).eq.11) then
5958             ehpb=ehpb+fordepth(i)!**4.0d0
5959      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5960             fac=fordepth(i)!**4.0d0
5961      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5962             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5963      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5964      &        ehpb,irestr_type(i)
5965           else if (irestr_type(i).eq.10) then
5966 c AL 6//19/2018 cross-link restraints
5967             xdis = 0.5d0*(dd/forcon(i))**2
5968             expdis = dexp(-xdis)
5969 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5970             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5971 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5972 c     &          " wboltzd",wboltzd
5973             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5974 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5975             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5976      &           *expdis/(aux*forcon(i)**2)
5977             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5978      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5979      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5980           else if (irestr_type(i).eq.2) then
5981 c Quartic restraints
5982             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5983             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5984      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5985      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5986             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5987           else
5988 c Quadratic restraints
5989             rdis=dd-dhpb(i)
5990 C Get the force constant corresponding to this distance.
5991             waga=forcon(i)
5992 C Calculate the contribution to energy.
5993             ehpb=ehpb+0.5d0*waga*rdis*rdis
5994             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5995      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5996      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5997 C
5998 C Evaluate gradient.
5999 C
6000             fac=waga*rdis/dd
6001           endif
6002 c Calculate Cartesian gradient
6003           do j=1,3
6004             ggg(j)=fac*(c(j,jj)-c(j,ii))
6005           enddo
6006 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6007 C If this is a SC-SC distance, we need to calculate the contributions to the
6008 C Cartesian gradient in the SC vectors (ghpbx).
6009           if (iii.lt.ii) then
6010             do j=1,3
6011               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6012             enddo
6013           endif
6014           if (jjj.lt.jj) then
6015             do j=1,3
6016               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6017             enddo
6018           endif
6019           do k=1,3
6020             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6021             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6022           enddo
6023         endif
6024       enddo
6025       return
6026       end
6027 C--------------------------------------------------------------------------
6028       subroutine ssbond_ene(i,j,eij)
6029 C
6030 C Calculate the distance and angle dependent SS-bond potential energy
6031 C using a free-energy function derived based on RHF/6-31G** ab initio
6032 C calculations of diethyl disulfide.
6033 C
6034 C A. Liwo and U. Kozlowska, 11/24/03
6035 C
6036       implicit real*8 (a-h,o-z)
6037       include 'DIMENSIONS'
6038       include 'COMMON.SBRIDGE'
6039       include 'COMMON.CHAIN'
6040       include 'COMMON.DERIV'
6041       include 'COMMON.LOCAL'
6042       include 'COMMON.INTERACT'
6043       include 'COMMON.VAR'
6044       include 'COMMON.IOUNITS'
6045       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6046       itypi=iabs(itype(i))
6047       xi=c(1,nres+i)
6048       yi=c(2,nres+i)
6049       zi=c(3,nres+i)
6050       dxi=dc_norm(1,nres+i)
6051       dyi=dc_norm(2,nres+i)
6052       dzi=dc_norm(3,nres+i)
6053 c      dsci_inv=dsc_inv(itypi)
6054       dsci_inv=vbld_inv(nres+i)
6055       itypj=iabs(itype(j))
6056 c      dscj_inv=dsc_inv(itypj)
6057       dscj_inv=vbld_inv(nres+j)
6058       xj=c(1,nres+j)-xi
6059       yj=c(2,nres+j)-yi
6060       zj=c(3,nres+j)-zi
6061       dxj=dc_norm(1,nres+j)
6062       dyj=dc_norm(2,nres+j)
6063       dzj=dc_norm(3,nres+j)
6064       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6065       rij=dsqrt(rrij)
6066       erij(1)=xj*rij
6067       erij(2)=yj*rij
6068       erij(3)=zj*rij
6069       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6070       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6071       om12=dxi*dxj+dyi*dyj+dzi*dzj
6072       do k=1,3
6073         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6074         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6075       enddo
6076       rij=1.0d0/rij
6077       deltad=rij-d0cm
6078       deltat1=1.0d0-om1
6079       deltat2=1.0d0+om2
6080       deltat12=om2-om1+2.0d0
6081       cosphi=om12-om1*om2
6082       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6083      &  +akct*deltad*deltat12
6084      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6085 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6086 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6087 c     &  " deltat12",deltat12," eij",eij
6088       ed=2*akcm*deltad+akct*deltat12
6089       pom1=akct*deltad
6090       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6091       eom1=-2*akth*deltat1-pom1-om2*pom2
6092       eom2= 2*akth*deltat2+pom1-om1*pom2
6093       eom12=pom2
6094       do k=1,3
6095         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6096         ghpbx(k,i)=ghpbx(k,i)-ggk
6097      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6098      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6099         ghpbx(k,j)=ghpbx(k,j)+ggk
6100      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6101      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6102         ghpbc(k,i)=ghpbc(k,i)-ggk
6103         ghpbc(k,j)=ghpbc(k,j)+ggk
6104       enddo
6105 C
6106 C Calculate the components of the gradient in DC and X
6107 C
6108 cgrad      do k=i,j-1
6109 cgrad        do l=1,3
6110 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6111 cgrad        enddo
6112 cgrad      enddo
6113       return
6114       end
6115 C--------------------------------------------------------------------------
6116       subroutine ebond(estr)
6117 c
6118 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6119 c
6120       implicit real*8 (a-h,o-z)
6121       include 'DIMENSIONS'
6122       include 'COMMON.LOCAL'
6123       include 'COMMON.GEO'
6124       include 'COMMON.INTERACT'
6125       include 'COMMON.DERIV'
6126       include 'COMMON.VAR'
6127       include 'COMMON.CHAIN'
6128       include 'COMMON.IOUNITS'
6129       include 'COMMON.NAMES'
6130       include 'COMMON.FFIELD'
6131       include 'COMMON.CONTROL'
6132       include 'COMMON.SETUP'
6133       double precision u(3),ud(3)
6134       estr=0.0d0
6135       estr1=0.0d0
6136       do i=ibondp_start,ibondp_end
6137 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6138 c      used
6139 #ifdef FIVEDIAG
6140         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6141         diff = vbld(i)-vbldp0
6142 #else
6143         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6144 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6145 c          do j=1,3
6146 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6147 c     &      *dc(j,i-1)/vbld(i)
6148 c          enddo
6149 c          if (energy_dec) write(iout,*)
6150 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6151 c        else
6152 C       Checking if it involves dummy (NH3+ or COO-) group
6153         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6154 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6155           diff = vbld(i)-vbldpDUM
6156           if (energy_dec) write(iout,*) "dum_bond",i,diff
6157         else
6158 C NO    vbldp0 is the equlibrium length of spring for peptide group
6159           diff = vbld(i)-vbldp0
6160         endif
6161 #endif
6162         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6163      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6164         estr=estr+diff*diff
6165         do j=1,3
6166           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6167         enddo
6168 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6169 c        endif
6170       enddo
6171
6172       estr=0.5d0*AKP*estr+estr1
6173 c
6174 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6175 c
6176       do i=ibond_start,ibond_end
6177         iti=iabs(itype(i))
6178         if (iti.ne.10 .and. iti.ne.ntyp1) then
6179           nbi=nbondterm(iti)
6180           if (nbi.eq.1) then
6181             diff=vbld(i+nres)-vbldsc0(1,iti)
6182             if (energy_dec)  write (iout,*)
6183      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6184      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6185             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6186             do j=1,3
6187               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6188             enddo
6189           else
6190             do j=1,nbi
6191               diff=vbld(i+nres)-vbldsc0(j,iti)
6192               ud(j)=aksc(j,iti)*diff
6193               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6194             enddo
6195             uprod=u(1)
6196             do j=2,nbi
6197               uprod=uprod*u(j)
6198             enddo
6199             usum=0.0d0
6200             usumsqder=0.0d0
6201             do j=1,nbi
6202               uprod1=1.0d0
6203               uprod2=1.0d0
6204               do k=1,nbi
6205                 if (k.ne.j) then
6206                   uprod1=uprod1*u(k)
6207                   uprod2=uprod2*u(k)*u(k)
6208                 endif
6209               enddo
6210               usum=usum+uprod1
6211               usumsqder=usumsqder+ud(j)*uprod2
6212             enddo
6213             estr=estr+uprod/usum
6214             do j=1,3
6215              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6216             enddo
6217           endif
6218         endif
6219       enddo
6220       return
6221       end
6222 #ifdef CRYST_THETA
6223 C--------------------------------------------------------------------------
6224       subroutine ebend(etheta)
6225 C
6226 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6227 C angles gamma and its derivatives in consecutive thetas and gammas.
6228 C
6229       implicit real*8 (a-h,o-z)
6230       include 'DIMENSIONS'
6231       include 'COMMON.LOCAL'
6232       include 'COMMON.GEO'
6233       include 'COMMON.INTERACT'
6234       include 'COMMON.DERIV'
6235       include 'COMMON.VAR'
6236       include 'COMMON.CHAIN'
6237       include 'COMMON.IOUNITS'
6238       include 'COMMON.NAMES'
6239       include 'COMMON.FFIELD'
6240       include 'COMMON.CONTROL'
6241       include 'COMMON.TORCNSTR'
6242       common /calcthet/ term1,term2,termm,diffak,ratak,
6243      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6244      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6245       double precision y(2),z(2)
6246       delta=0.02d0*pi
6247 c      time11=dexp(-2*time)
6248 c      time12=1.0d0
6249       etheta=0.0D0
6250 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6251       do i=ithet_start,ithet_end
6252         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6253      &  .or.itype(i).eq.ntyp1) cycle
6254 C Zero the energy function and its derivative at 0 or pi.
6255         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6256         it=itype(i-1)
6257         ichir1=isign(1,itype(i-2))
6258         ichir2=isign(1,itype(i))
6259          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6260          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6261          if (itype(i-1).eq.10) then
6262           itype1=isign(10,itype(i-2))
6263           ichir11=isign(1,itype(i-2))
6264           ichir12=isign(1,itype(i-2))
6265           itype2=isign(10,itype(i))
6266           ichir21=isign(1,itype(i))
6267           ichir22=isign(1,itype(i))
6268          endif
6269
6270         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6271 #ifdef OSF
6272           phii=phi(i)
6273           if (phii.ne.phii) phii=150.0
6274 #else
6275           phii=phi(i)
6276 #endif
6277           y(1)=dcos(phii)
6278           y(2)=dsin(phii)
6279         else
6280           y(1)=0.0D0
6281           y(2)=0.0D0
6282         endif
6283         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6284 #ifdef OSF
6285           phii1=phi(i+1)
6286           if (phii1.ne.phii1) phii1=150.0
6287           phii1=pinorm(phii1)
6288           z(1)=cos(phii1)
6289 #else
6290           phii1=phi(i+1)
6291 #endif
6292           z(1)=dcos(phii1)
6293           z(2)=dsin(phii1)
6294         else
6295           z(1)=0.0D0
6296           z(2)=0.0D0
6297         endif
6298 C Calculate the "mean" value of theta from the part of the distribution
6299 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6300 C In following comments this theta will be referred to as t_c.
6301         thet_pred_mean=0.0d0
6302         do k=1,2
6303             athetk=athet(k,it,ichir1,ichir2)
6304             bthetk=bthet(k,it,ichir1,ichir2)
6305           if (it.eq.10) then
6306              athetk=athet(k,itype1,ichir11,ichir12)
6307              bthetk=bthet(k,itype2,ichir21,ichir22)
6308           endif
6309          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6310 c         write(iout,*) 'chuj tu', y(k),z(k)
6311         enddo
6312         dthett=thet_pred_mean*ssd
6313         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6314 C Derivatives of the "mean" values in gamma1 and gamma2.
6315         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6316      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6317          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6318      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6319          if (it.eq.10) then
6320       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6321      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6322         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6323      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6324          endif
6325         if (theta(i).gt.pi-delta) then
6326           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6327      &         E_tc0)
6328           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6329           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6330           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6331      &        E_theta)
6332           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6333      &        E_tc)
6334         else if (theta(i).lt.delta) then
6335           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6336           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6337           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6338      &        E_theta)
6339           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6340           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6341      &        E_tc)
6342         else
6343           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6344      &        E_theta,E_tc)
6345         endif
6346         etheta=etheta+ethetai
6347         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6348      &      'ebend',i,ethetai,theta(i),itype(i)
6349         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6350         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6351         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6352       enddo
6353
6354 C Ufff.... We've done all this!!!
6355       return
6356       end
6357 C---------------------------------------------------------------------------
6358       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6359      &     E_tc)
6360       implicit real*8 (a-h,o-z)
6361       include 'DIMENSIONS'
6362       include 'COMMON.LOCAL'
6363       include 'COMMON.IOUNITS'
6364       common /calcthet/ term1,term2,termm,diffak,ratak,
6365      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6366      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6367 C Calculate the contributions to both Gaussian lobes.
6368 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6369 C The "polynomial part" of the "standard deviation" of this part of
6370 C the distributioni.
6371 ccc        write (iout,*) thetai,thet_pred_mean
6372         sig=polthet(3,it)
6373         do j=2,0,-1
6374           sig=sig*thet_pred_mean+polthet(j,it)
6375         enddo
6376 C Derivative of the "interior part" of the "standard deviation of the"
6377 C gamma-dependent Gaussian lobe in t_c.
6378         sigtc=3*polthet(3,it)
6379         do j=2,1,-1
6380           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6381         enddo
6382         sigtc=sig*sigtc
6383 C Set the parameters of both Gaussian lobes of the distribution.
6384 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6385         fac=sig*sig+sigc0(it)
6386         sigcsq=fac+fac
6387         sigc=1.0D0/sigcsq
6388 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6389         sigsqtc=-4.0D0*sigcsq*sigtc
6390 c       print *,i,sig,sigtc,sigsqtc
6391 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6392         sigtc=-sigtc/(fac*fac)
6393 C Following variable is sigma(t_c)**(-2)
6394         sigcsq=sigcsq*sigcsq
6395         sig0i=sig0(it)
6396         sig0inv=1.0D0/sig0i**2
6397         delthec=thetai-thet_pred_mean
6398         delthe0=thetai-theta0i
6399         term1=-0.5D0*sigcsq*delthec*delthec
6400         term2=-0.5D0*sig0inv*delthe0*delthe0
6401 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6402 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6403 C NaNs in taking the logarithm. We extract the largest exponent which is added
6404 C to the energy (this being the log of the distribution) at the end of energy
6405 C term evaluation for this virtual-bond angle.
6406         if (term1.gt.term2) then
6407           termm=term1
6408           term2=dexp(term2-termm)
6409           term1=1.0d0
6410         else
6411           termm=term2
6412           term1=dexp(term1-termm)
6413           term2=1.0d0
6414         endif
6415 C The ratio between the gamma-independent and gamma-dependent lobes of
6416 C the distribution is a Gaussian function of thet_pred_mean too.
6417         diffak=gthet(2,it)-thet_pred_mean
6418         ratak=diffak/gthet(3,it)**2
6419         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6420 C Let's differentiate it in thet_pred_mean NOW.
6421         aktc=ak*ratak
6422 C Now put together the distribution terms to make complete distribution.
6423         termexp=term1+ak*term2
6424         termpre=sigc+ak*sig0i
6425 C Contribution of the bending energy from this theta is just the -log of
6426 C the sum of the contributions from the two lobes and the pre-exponential
6427 C factor. Simple enough, isn't it?
6428         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6429 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6430 C NOW the derivatives!!!
6431 C 6/6/97 Take into account the deformation.
6432         E_theta=(delthec*sigcsq*term1
6433      &       +ak*delthe0*sig0inv*term2)/termexp
6434         E_tc=((sigtc+aktc*sig0i)/termpre
6435      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6436      &       aktc*term2)/termexp)
6437       return
6438       end
6439 c-----------------------------------------------------------------------------
6440       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6441       implicit real*8 (a-h,o-z)
6442       include 'DIMENSIONS'
6443       include 'COMMON.LOCAL'
6444       include 'COMMON.IOUNITS'
6445       common /calcthet/ term1,term2,termm,diffak,ratak,
6446      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6447      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6448       delthec=thetai-thet_pred_mean
6449       delthe0=thetai-theta0i
6450 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6451       t3 = thetai-thet_pred_mean
6452       t6 = t3**2
6453       t9 = term1
6454       t12 = t3*sigcsq
6455       t14 = t12+t6*sigsqtc
6456       t16 = 1.0d0
6457       t21 = thetai-theta0i
6458       t23 = t21**2
6459       t26 = term2
6460       t27 = t21*t26
6461       t32 = termexp
6462       t40 = t32**2
6463       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6464      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6465      & *(-t12*t9-ak*sig0inv*t27)
6466       return
6467       end
6468 #else
6469 C--------------------------------------------------------------------------
6470       subroutine ebend(etheta)
6471 C
6472 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6473 C angles gamma and its derivatives in consecutive thetas and gammas.
6474 C ab initio-derived potentials from
6475 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6476 C
6477       implicit real*8 (a-h,o-z)
6478       include 'DIMENSIONS'
6479       include 'COMMON.LOCAL'
6480       include 'COMMON.GEO'
6481       include 'COMMON.INTERACT'
6482       include 'COMMON.DERIV'
6483       include 'COMMON.VAR'
6484       include 'COMMON.CHAIN'
6485       include 'COMMON.IOUNITS'
6486       include 'COMMON.NAMES'
6487       include 'COMMON.FFIELD'
6488       include 'COMMON.CONTROL'
6489       include 'COMMON.TORCNSTR'
6490       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6491      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6492      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6493      & sinph1ph2(maxdouble,maxdouble)
6494       logical lprn /.false./, lprn1 /.false./
6495       etheta=0.0D0
6496       do i=ithet_start,ithet_end
6497 c        print *,i,itype(i-1),itype(i),itype(i-2)
6498         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6499      &  .or.itype(i).eq.ntyp1) cycle
6500 C        print *,i,theta(i)
6501         if (iabs(itype(i+1)).eq.20) iblock=2
6502         if (iabs(itype(i+1)).ne.20) iblock=1
6503         dethetai=0.0d0
6504         dephii=0.0d0
6505         dephii1=0.0d0
6506         theti2=0.5d0*theta(i)
6507         ityp2=ithetyp((itype(i-1)))
6508         do k=1,nntheterm
6509           coskt(k)=dcos(k*theti2)
6510           sinkt(k)=dsin(k*theti2)
6511         enddo
6512 C        print *,ethetai
6513         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6514 #ifdef OSF
6515           phii=phi(i)
6516           if (phii.ne.phii) phii=150.0
6517 #else
6518           phii=phi(i)
6519 #endif
6520           ityp1=ithetyp((itype(i-2)))
6521 C propagation of chirality for glycine type
6522           do k=1,nsingle
6523             cosph1(k)=dcos(k*phii)
6524             sinph1(k)=dsin(k*phii)
6525           enddo
6526         else
6527           phii=0.0d0
6528           do k=1,nsingle
6529           ityp1=ithetyp((itype(i-2)))
6530             cosph1(k)=0.0d0
6531             sinph1(k)=0.0d0
6532           enddo
6533         endif
6534         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6535 #ifdef OSF
6536           phii1=phi(i+1)
6537           if (phii1.ne.phii1) phii1=150.0
6538           phii1=pinorm(phii1)
6539 #else
6540           phii1=phi(i+1)
6541 #endif
6542           ityp3=ithetyp((itype(i)))
6543           do k=1,nsingle
6544             cosph2(k)=dcos(k*phii1)
6545             sinph2(k)=dsin(k*phii1)
6546           enddo
6547         else
6548           phii1=0.0d0
6549           ityp3=ithetyp((itype(i)))
6550           do k=1,nsingle
6551             cosph2(k)=0.0d0
6552             sinph2(k)=0.0d0
6553           enddo
6554         endif
6555         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6556         do k=1,ndouble
6557           do l=1,k-1
6558             ccl=cosph1(l)*cosph2(k-l)
6559             ssl=sinph1(l)*sinph2(k-l)
6560             scl=sinph1(l)*cosph2(k-l)
6561             csl=cosph1(l)*sinph2(k-l)
6562             cosph1ph2(l,k)=ccl-ssl
6563             cosph1ph2(k,l)=ccl+ssl
6564             sinph1ph2(l,k)=scl+csl
6565             sinph1ph2(k,l)=scl-csl
6566           enddo
6567         enddo
6568         if (lprn) then
6569         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6570      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6571         write (iout,*) "coskt and sinkt"
6572         do k=1,nntheterm
6573           write (iout,*) k,coskt(k),sinkt(k)
6574         enddo
6575         endif
6576         do k=1,ntheterm
6577           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6578           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6579      &      *coskt(k)
6580           if (lprn)
6581      &    write (iout,*) "k",k,"
6582      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6583      &     " ethetai",ethetai
6584         enddo
6585         if (lprn) then
6586         write (iout,*) "cosph and sinph"
6587         do k=1,nsingle
6588           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6589         enddo
6590         write (iout,*) "cosph1ph2 and sinph2ph2"
6591         do k=2,ndouble
6592           do l=1,k-1
6593             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6594      &         sinph1ph2(l,k),sinph1ph2(k,l)
6595           enddo
6596         enddo
6597         write(iout,*) "ethetai",ethetai
6598         endif
6599 C       print *,ethetai
6600         do m=1,ntheterm2
6601           do k=1,nsingle
6602             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6603      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6604      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6605      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6606             ethetai=ethetai+sinkt(m)*aux
6607             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6608             dephii=dephii+k*sinkt(m)*(
6609      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6610      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6611             dephii1=dephii1+k*sinkt(m)*(
6612      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6613      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6614             if (lprn)
6615      &      write (iout,*) "m",m," k",k," bbthet",
6616      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6617      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6618      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6619      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6620 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6621           enddo
6622         enddo
6623 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6624 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6625 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6626 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6627         if (lprn)
6628      &  write(iout,*) "ethetai",ethetai
6629 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6630         do m=1,ntheterm3
6631           do k=2,ndouble
6632             do l=1,k-1
6633               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6634      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6635      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6636      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6637               ethetai=ethetai+sinkt(m)*aux
6638               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6639               dephii=dephii+l*sinkt(m)*(
6640      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6641      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6642      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6643      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6644               dephii1=dephii1+(k-l)*sinkt(m)*(
6645      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6646      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6647      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6648      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6649               if (lprn) then
6650               write (iout,*) "m",m," k",k," l",l," ffthet",
6651      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6652      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6653      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6654      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6655      &            " ethetai",ethetai
6656               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6657      &            cosph1ph2(k,l)*sinkt(m),
6658      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6659               endif
6660             enddo
6661           enddo
6662         enddo
6663 10      continue
6664 c        lprn1=.true.
6665 C        print *,ethetai
6666         if (lprn1)
6667      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6668      &   i,theta(i)*rad2deg,phii*rad2deg,
6669      &   phii1*rad2deg,ethetai
6670 c        lprn1=.false.
6671         etheta=etheta+ethetai
6672         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6673         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6674         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6675       enddo
6676
6677       return
6678       end
6679 #endif
6680 #ifdef CRYST_SC
6681 c-----------------------------------------------------------------------------
6682       subroutine esc(escloc)
6683 C Calculate the local energy of a side chain and its derivatives in the
6684 C corresponding virtual-bond valence angles THETA and the spherical angles
6685 C ALPHA and OMEGA.
6686       implicit real*8 (a-h,o-z)
6687       include 'DIMENSIONS'
6688       include 'COMMON.GEO'
6689       include 'COMMON.LOCAL'
6690       include 'COMMON.VAR'
6691       include 'COMMON.INTERACT'
6692       include 'COMMON.DERIV'
6693       include 'COMMON.CHAIN'
6694       include 'COMMON.IOUNITS'
6695       include 'COMMON.NAMES'
6696       include 'COMMON.FFIELD'
6697       include 'COMMON.CONTROL'
6698       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6699      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6700       common /sccalc/ time11,time12,time112,theti,it,nlobit
6701       delta=0.02d0*pi
6702       escloc=0.0D0
6703 c     write (iout,'(a)') 'ESC'
6704       do i=loc_start,loc_end
6705         it=itype(i)
6706         if (it.eq.ntyp1) cycle
6707         if (it.eq.10) goto 1
6708         nlobit=nlob(iabs(it))
6709 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6710 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6711         theti=theta(i+1)-pipol
6712         x(1)=dtan(theti)
6713         x(2)=alph(i)
6714         x(3)=omeg(i)
6715
6716         if (x(2).gt.pi-delta) then
6717           xtemp(1)=x(1)
6718           xtemp(2)=pi-delta
6719           xtemp(3)=x(3)
6720           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6721           xtemp(2)=pi
6722           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6723           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6724      &        escloci,dersc(2))
6725           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6726      &        ddersc0(1),dersc(1))
6727           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6728      &        ddersc0(3),dersc(3))
6729           xtemp(2)=pi-delta
6730           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6731           xtemp(2)=pi
6732           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6733           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6734      &            dersc0(2),esclocbi,dersc02)
6735           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6736      &            dersc12,dersc01)
6737           call splinthet(x(2),0.5d0*delta,ss,ssd)
6738           dersc0(1)=dersc01
6739           dersc0(2)=dersc02
6740           dersc0(3)=0.0d0
6741           do k=1,3
6742             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6743           enddo
6744           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6745 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6746 c    &             esclocbi,ss,ssd
6747           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6748 c         escloci=esclocbi
6749 c         write (iout,*) escloci
6750         else if (x(2).lt.delta) then
6751           xtemp(1)=x(1)
6752           xtemp(2)=delta
6753           xtemp(3)=x(3)
6754           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6755           xtemp(2)=0.0d0
6756           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6757           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6758      &        escloci,dersc(2))
6759           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6760      &        ddersc0(1),dersc(1))
6761           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6762      &        ddersc0(3),dersc(3))
6763           xtemp(2)=delta
6764           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6765           xtemp(2)=0.0d0
6766           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6767           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6768      &            dersc0(2),esclocbi,dersc02)
6769           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6770      &            dersc12,dersc01)
6771           dersc0(1)=dersc01
6772           dersc0(2)=dersc02
6773           dersc0(3)=0.0d0
6774           call splinthet(x(2),0.5d0*delta,ss,ssd)
6775           do k=1,3
6776             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6777           enddo
6778           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6779 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6780 c    &             esclocbi,ss,ssd
6781           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6782 c         write (iout,*) escloci
6783         else
6784           call enesc(x,escloci,dersc,ddummy,.false.)
6785         endif
6786
6787         escloc=escloc+escloci
6788         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6789      &     'escloc',i,escloci
6790 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6791
6792         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6793      &   wscloc*dersc(1)
6794         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6795         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6796     1   continue
6797       enddo
6798       return
6799       end
6800 C---------------------------------------------------------------------------
6801       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6802       implicit real*8 (a-h,o-z)
6803       include 'DIMENSIONS'
6804       include 'COMMON.GEO'
6805       include 'COMMON.LOCAL'
6806       include 'COMMON.IOUNITS'
6807       common /sccalc/ time11,time12,time112,theti,it,nlobit
6808       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6809       double precision contr(maxlob,-1:1)
6810       logical mixed
6811 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6812         escloc_i=0.0D0
6813         do j=1,3
6814           dersc(j)=0.0D0
6815           if (mixed) ddersc(j)=0.0d0
6816         enddo
6817         x3=x(3)
6818
6819 C Because of periodicity of the dependence of the SC energy in omega we have
6820 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6821 C To avoid underflows, first compute & store the exponents.
6822
6823         do iii=-1,1
6824
6825           x(3)=x3+iii*dwapi
6826
6827           do j=1,nlobit
6828             do k=1,3
6829               z(k)=x(k)-censc(k,j,it)
6830             enddo
6831             do k=1,3
6832               Axk=0.0D0
6833               do l=1,3
6834                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6835               enddo
6836               Ax(k,j,iii)=Axk
6837             enddo
6838             expfac=0.0D0
6839             do k=1,3
6840               expfac=expfac+Ax(k,j,iii)*z(k)
6841             enddo
6842             contr(j,iii)=expfac
6843           enddo ! j
6844
6845         enddo ! iii
6846
6847         x(3)=x3
6848 C As in the case of ebend, we want to avoid underflows in exponentiation and
6849 C subsequent NaNs and INFs in energy calculation.
6850 C Find the largest exponent
6851         emin=contr(1,-1)
6852         do iii=-1,1
6853           do j=1,nlobit
6854             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6855           enddo
6856         enddo
6857         emin=0.5D0*emin
6858 cd      print *,'it=',it,' emin=',emin
6859
6860 C Compute the contribution to SC energy and derivatives
6861         do iii=-1,1
6862
6863           do j=1,nlobit
6864 #ifdef OSF
6865             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6866             if(adexp.ne.adexp) adexp=1.0
6867             expfac=dexp(adexp)
6868 #else
6869             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6870 #endif
6871 cd          print *,'j=',j,' expfac=',expfac
6872             escloc_i=escloc_i+expfac
6873             do k=1,3
6874               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6875             enddo
6876             if (mixed) then
6877               do k=1,3,2
6878                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6879      &            +gaussc(k,2,j,it))*expfac
6880               enddo
6881             endif
6882           enddo
6883
6884         enddo ! iii
6885
6886         dersc(1)=dersc(1)/cos(theti)**2
6887         ddersc(1)=ddersc(1)/cos(theti)**2
6888         ddersc(3)=ddersc(3)
6889
6890         escloci=-(dlog(escloc_i)-emin)
6891         do j=1,3
6892           dersc(j)=dersc(j)/escloc_i
6893         enddo
6894         if (mixed) then
6895           do j=1,3,2
6896             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6897           enddo
6898         endif
6899       return
6900       end
6901 C------------------------------------------------------------------------------
6902       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6903       implicit real*8 (a-h,o-z)
6904       include 'DIMENSIONS'
6905       include 'COMMON.GEO'
6906       include 'COMMON.LOCAL'
6907       include 'COMMON.IOUNITS'
6908       common /sccalc/ time11,time12,time112,theti,it,nlobit
6909       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6910       double precision contr(maxlob)
6911       logical mixed
6912
6913       escloc_i=0.0D0
6914
6915       do j=1,3
6916         dersc(j)=0.0D0
6917       enddo
6918
6919       do j=1,nlobit
6920         do k=1,2
6921           z(k)=x(k)-censc(k,j,it)
6922         enddo
6923         z(3)=dwapi
6924         do k=1,3
6925           Axk=0.0D0
6926           do l=1,3
6927             Axk=Axk+gaussc(l,k,j,it)*z(l)
6928           enddo
6929           Ax(k,j)=Axk
6930         enddo
6931         expfac=0.0D0
6932         do k=1,3
6933           expfac=expfac+Ax(k,j)*z(k)
6934         enddo
6935         contr(j)=expfac
6936       enddo ! j
6937
6938 C As in the case of ebend, we want to avoid underflows in exponentiation and
6939 C subsequent NaNs and INFs in energy calculation.
6940 C Find the largest exponent
6941       emin=contr(1)
6942       do j=1,nlobit
6943         if (emin.gt.contr(j)) emin=contr(j)
6944       enddo
6945       emin=0.5D0*emin
6946
6947 C Compute the contribution to SC energy and derivatives
6948
6949       dersc12=0.0d0
6950       do j=1,nlobit
6951         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6952         escloc_i=escloc_i+expfac
6953         do k=1,2
6954           dersc(k)=dersc(k)+Ax(k,j)*expfac
6955         enddo
6956         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6957      &            +gaussc(1,2,j,it))*expfac
6958         dersc(3)=0.0d0
6959       enddo
6960
6961       dersc(1)=dersc(1)/cos(theti)**2
6962       dersc12=dersc12/cos(theti)**2
6963       escloci=-(dlog(escloc_i)-emin)
6964       do j=1,2
6965         dersc(j)=dersc(j)/escloc_i
6966       enddo
6967       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6968       return
6969       end
6970 #else
6971 c----------------------------------------------------------------------------------
6972       subroutine esc(escloc)
6973 C Calculate the local energy of a side chain and its derivatives in the
6974 C corresponding virtual-bond valence angles THETA and the spherical angles
6975 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6976 C added by Urszula Kozlowska. 07/11/2007
6977 C
6978       implicit real*8 (a-h,o-z)
6979       include 'DIMENSIONS'
6980       include 'COMMON.GEO'
6981       include 'COMMON.LOCAL'
6982       include 'COMMON.VAR'
6983       include 'COMMON.SCROT'
6984       include 'COMMON.INTERACT'
6985       include 'COMMON.DERIV'
6986       include 'COMMON.CHAIN'
6987       include 'COMMON.IOUNITS'
6988       include 'COMMON.NAMES'
6989       include 'COMMON.FFIELD'
6990       include 'COMMON.CONTROL'
6991       include 'COMMON.VECTORS'
6992       double precision x_prime(3),y_prime(3),z_prime(3)
6993      &    , sumene,dsc_i,dp2_i,x(65),
6994      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6995      &    de_dxx,de_dyy,de_dzz,de_dt
6996       double precision s1_t,s1_6_t,s2_t,s2_6_t
6997       double precision
6998      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6999      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7000      & dt_dCi(3),dt_dCi1(3)
7001       common /sccalc/ time11,time12,time112,theti,it,nlobit
7002       delta=0.02d0*pi
7003       escloc=0.0D0
7004       do i=loc_start,loc_end
7005         if (itype(i).eq.ntyp1) cycle
7006         costtab(i+1) =dcos(theta(i+1))
7007         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7008         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7009         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7010         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7011         cosfac=dsqrt(cosfac2)
7012         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7013         sinfac=dsqrt(sinfac2)
7014         it=iabs(itype(i))
7015         if (it.eq.10) goto 1
7016 c
7017 C  Compute the axes of tghe local cartesian coordinates system; store in
7018 c   x_prime, y_prime and z_prime
7019 c
7020         do j=1,3
7021           x_prime(j) = 0.00
7022           y_prime(j) = 0.00
7023           z_prime(j) = 0.00
7024         enddo
7025 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7026 C     &   dc_norm(3,i+nres)
7027         do j = 1,3
7028           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7029           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7030         enddo
7031         do j = 1,3
7032           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7033         enddo
7034 c       write (2,*) "i",i
7035 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7036 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7037 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7038 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7039 c      & " xy",scalar(x_prime(1),y_prime(1)),
7040 c      & " xz",scalar(x_prime(1),z_prime(1)),
7041 c      & " yy",scalar(y_prime(1),y_prime(1)),
7042 c      & " yz",scalar(y_prime(1),z_prime(1)),
7043 c      & " zz",scalar(z_prime(1),z_prime(1))
7044 c
7045 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7046 C to local coordinate system. Store in xx, yy, zz.
7047 c
7048         xx=0.0d0
7049         yy=0.0d0
7050         zz=0.0d0
7051         do j = 1,3
7052           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7053           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7054           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7055         enddo
7056
7057         xxtab(i)=xx
7058         yytab(i)=yy
7059         zztab(i)=zz
7060 C
7061 C Compute the energy of the ith side cbain
7062 C
7063 c        write (2,*) "xx",xx," yy",yy," zz",zz
7064         it=iabs(itype(i))
7065         do j = 1,65
7066           x(j) = sc_parmin(j,it)
7067         enddo
7068 #ifdef CHECK_COORD
7069 Cc diagnostics - remove later
7070         xx1 = dcos(alph(2))
7071         yy1 = dsin(alph(2))*dcos(omeg(2))
7072         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7073         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7074      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7075      &    xx1,yy1,zz1
7076 C,"  --- ", xx_w,yy_w,zz_w
7077 c end diagnostics
7078 #endif
7079         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7080      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7081      &   + x(10)*yy*zz
7082         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7083      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7084      & + x(20)*yy*zz
7085         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7086      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7087      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7088      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7089      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7090      &  +x(40)*xx*yy*zz
7091         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7092      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7093      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7094      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7095      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7096      &  +x(60)*xx*yy*zz
7097         dsc_i   = 0.743d0+x(61)
7098         dp2_i   = 1.9d0+x(62)
7099         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7100      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7101         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7102      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7103         s1=(1+x(63))/(0.1d0 + dscp1)
7104         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7105         s2=(1+x(65))/(0.1d0 + dscp2)
7106         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7107         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7108      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7109 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7110 c     &   sumene4,
7111 c     &   dscp1,dscp2,sumene
7112 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7113         escloc = escloc + sumene
7114         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7115      &   " escloc",sumene,escloc,it,itype(i)
7116 c     & ,zz,xx,yy
7117 c#define DEBUG
7118 #ifdef DEBUG
7119 C
7120 C This section to check the numerical derivatives of the energy of ith side
7121 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7122 C #define DEBUG in the code to turn it on.
7123 C
7124         write (2,*) "sumene               =",sumene
7125         aincr=1.0d-7
7126         xxsave=xx
7127         xx=xx+aincr
7128         write (2,*) xx,yy,zz
7129         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7130         de_dxx_num=(sumenep-sumene)/aincr
7131         xx=xxsave
7132         write (2,*) "xx+ sumene from enesc=",sumenep
7133         yysave=yy
7134         yy=yy+aincr
7135         write (2,*) xx,yy,zz
7136         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7137         de_dyy_num=(sumenep-sumene)/aincr
7138         yy=yysave
7139         write (2,*) "yy+ sumene from enesc=",sumenep
7140         zzsave=zz
7141         zz=zz+aincr
7142         write (2,*) xx,yy,zz
7143         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7144         de_dzz_num=(sumenep-sumene)/aincr
7145         zz=zzsave
7146         write (2,*) "zz+ sumene from enesc=",sumenep
7147         costsave=cost2tab(i+1)
7148         sintsave=sint2tab(i+1)
7149         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7150         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7151         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7152         de_dt_num=(sumenep-sumene)/aincr
7153         write (2,*) " t+ sumene from enesc=",sumenep
7154         cost2tab(i+1)=costsave
7155         sint2tab(i+1)=sintsave
7156 C End of diagnostics section.
7157 #endif
7158 C
7159 C Compute the gradient of esc
7160 C
7161 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7162         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7163         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7164         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7165         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7166         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7167         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7168         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7169         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7170         pom1=(sumene3*sint2tab(i+1)+sumene1)
7171      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7172         pom2=(sumene4*cost2tab(i+1)+sumene2)
7173      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7174         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7175         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7176      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7177      &  +x(40)*yy*zz
7178         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7179         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7180      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7181      &  +x(60)*yy*zz
7182         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7183      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7184      &        +(pom1+pom2)*pom_dx
7185 #ifdef DEBUG
7186         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7187 #endif
7188 C
7189         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7190         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7191      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7192      &  +x(40)*xx*zz
7193         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7194         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7195      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7196      &  +x(59)*zz**2 +x(60)*xx*zz
7197         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7198      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7199      &        +(pom1-pom2)*pom_dy
7200 #ifdef DEBUG
7201         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7202 #endif
7203 C
7204         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7205      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7206      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7207      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7208      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7209      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7210      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7211      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7212 #ifdef DEBUG
7213         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7214 #endif
7215 C
7216         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7217      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7218      &  +pom1*pom_dt1+pom2*pom_dt2
7219 #ifdef DEBUG
7220         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7221 #endif
7222 c#undef DEBUG
7223 c
7224 C
7225        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7226        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7227        cosfac2xx=cosfac2*xx
7228        sinfac2yy=sinfac2*yy
7229        do k = 1,3
7230          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7231      &      vbld_inv(i+1)
7232          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7233      &      vbld_inv(i)
7234          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7235          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7236 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7237 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7238 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7239 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7240          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7241          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7242          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7243          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7244          dZZ_Ci1(k)=0.0d0
7245          dZZ_Ci(k)=0.0d0
7246          do j=1,3
7247            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7248      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7249            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7250      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7251          enddo
7252
7253          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7254          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7255          dZZ_XYZ(k)=vbld_inv(i+nres)*
7256      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7257 c
7258          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7259          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7260        enddo
7261
7262        do k=1,3
7263          dXX_Ctab(k,i)=dXX_Ci(k)
7264          dXX_C1tab(k,i)=dXX_Ci1(k)
7265          dYY_Ctab(k,i)=dYY_Ci(k)
7266          dYY_C1tab(k,i)=dYY_Ci1(k)
7267          dZZ_Ctab(k,i)=dZZ_Ci(k)
7268          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7269          dXX_XYZtab(k,i)=dXX_XYZ(k)
7270          dYY_XYZtab(k,i)=dYY_XYZ(k)
7271          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7272        enddo
7273
7274        do k = 1,3
7275 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7276 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7277 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7278 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7279 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7280 c     &    dt_dci(k)
7281 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7282 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7283          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7284      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7285          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7286      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7287          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7288      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7289        enddo
7290 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7291 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7292
7293 C to check gradient call subroutine check_grad
7294
7295     1 continue
7296       enddo
7297       return
7298       end
7299 c------------------------------------------------------------------------------
7300       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7301       implicit none
7302       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7303      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7304       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7305      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7306      &   + x(10)*yy*zz
7307       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7308      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7309      & + x(20)*yy*zz
7310       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7311      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7312      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7313      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7314      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7315      &  +x(40)*xx*yy*zz
7316       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7317      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7318      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7319      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7320      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7321      &  +x(60)*xx*yy*zz
7322       dsc_i   = 0.743d0+x(61)
7323       dp2_i   = 1.9d0+x(62)
7324       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7325      &          *(xx*cost2+yy*sint2))
7326       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7327      &          *(xx*cost2-yy*sint2))
7328       s1=(1+x(63))/(0.1d0 + dscp1)
7329       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7330       s2=(1+x(65))/(0.1d0 + dscp2)
7331       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7332       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7333      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7334       enesc=sumene
7335       return
7336       end
7337 #endif
7338 c------------------------------------------------------------------------------
7339       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7340 C
7341 C This procedure calculates two-body contact function g(rij) and its derivative:
7342 C
7343 C           eps0ij                                     !       x < -1
7344 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7345 C            0                                         !       x > 1
7346 C
7347 C where x=(rij-r0ij)/delta
7348 C
7349 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7350 C
7351       implicit none
7352       double precision rij,r0ij,eps0ij,fcont,fprimcont
7353       double precision x,x2,x4,delta
7354 c     delta=0.02D0*r0ij
7355 c      delta=0.2D0*r0ij
7356       x=(rij-r0ij)/delta
7357       if (x.lt.-1.0D0) then
7358         fcont=eps0ij
7359         fprimcont=0.0D0
7360       else if (x.le.1.0D0) then
7361         x2=x*x
7362         x4=x2*x2
7363         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7364         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7365       else
7366         fcont=0.0D0
7367         fprimcont=0.0D0
7368       endif
7369       return
7370       end
7371 c------------------------------------------------------------------------------
7372       subroutine splinthet(theti,delta,ss,ssder)
7373       implicit real*8 (a-h,o-z)
7374       include 'DIMENSIONS'
7375       include 'COMMON.VAR'
7376       include 'COMMON.GEO'
7377       thetup=pi-delta
7378       thetlow=delta
7379       if (theti.gt.pipol) then
7380         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7381       else
7382         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7383         ssder=-ssder
7384       endif
7385       return
7386       end
7387 c------------------------------------------------------------------------------
7388       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7389       implicit none
7390       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7391       double precision ksi,ksi2,ksi3,a1,a2,a3
7392       a1=fprim0*delta/(f1-f0)
7393       a2=3.0d0-2.0d0*a1
7394       a3=a1-2.0d0
7395       ksi=(x-x0)/delta
7396       ksi2=ksi*ksi
7397       ksi3=ksi2*ksi
7398       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7399       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7400       return
7401       end
7402 c------------------------------------------------------------------------------
7403       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7404       implicit none
7405       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7406       double precision ksi,ksi2,ksi3,a1,a2,a3
7407       ksi=(x-x0)/delta
7408       ksi2=ksi*ksi
7409       ksi3=ksi2*ksi
7410       a1=fprim0x*delta
7411       a2=3*(f1x-f0x)-2*fprim0x*delta
7412       a3=fprim0x*delta-2*(f1x-f0x)
7413       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7414       return
7415       end
7416 C-----------------------------------------------------------------------------
7417 #ifdef CRYST_TOR
7418 C-----------------------------------------------------------------------------
7419       subroutine etor(etors)
7420       implicit real*8 (a-h,o-z)
7421       include 'DIMENSIONS'
7422       include 'COMMON.VAR'
7423       include 'COMMON.GEO'
7424       include 'COMMON.LOCAL'
7425       include 'COMMON.TORSION'
7426       include 'COMMON.INTERACT'
7427       include 'COMMON.DERIV'
7428       include 'COMMON.CHAIN'
7429       include 'COMMON.NAMES'
7430       include 'COMMON.IOUNITS'
7431       include 'COMMON.FFIELD'
7432       include 'COMMON.TORCNSTR'
7433       include 'COMMON.CONTROL'
7434       logical lprn
7435 C Set lprn=.true. for debugging
7436       lprn=.false.
7437 c      lprn=.true.
7438       etors=0.0D0
7439       do i=iphi_start,iphi_end
7440       etors_ii=0.0D0
7441         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7442      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7443         itori=itortyp(itype(i-2))
7444         itori1=itortyp(itype(i-1))
7445         phii=phi(i)
7446         gloci=0.0D0
7447 C Proline-Proline pair is a special case...
7448         if (itori.eq.3 .and. itori1.eq.3) then
7449           if (phii.gt.-dwapi3) then
7450             cosphi=dcos(3*phii)
7451             fac=1.0D0/(1.0D0-cosphi)
7452             etorsi=v1(1,3,3)*fac
7453             etorsi=etorsi+etorsi
7454             etors=etors+etorsi-v1(1,3,3)
7455             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7456             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7457           endif
7458           do j=1,3
7459             v1ij=v1(j+1,itori,itori1)
7460             v2ij=v2(j+1,itori,itori1)
7461             cosphi=dcos(j*phii)
7462             sinphi=dsin(j*phii)
7463             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7464             if (energy_dec) etors_ii=etors_ii+
7465      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7466             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7467           enddo
7468         else
7469           do j=1,nterm_old
7470             v1ij=v1(j,itori,itori1)
7471             v2ij=v2(j,itori,itori1)
7472             cosphi=dcos(j*phii)
7473             sinphi=dsin(j*phii)
7474             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7475             if (energy_dec) etors_ii=etors_ii+
7476      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7477             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7478           enddo
7479         endif
7480         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7481              'etor',i,etors_ii
7482         if (lprn)
7483      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7484      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7485      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7486         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7487 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7488       enddo
7489       return
7490       end
7491 c------------------------------------------------------------------------------
7492       subroutine etor_d(etors_d)
7493       etors_d=0.0d0
7494       return
7495       end
7496 c----------------------------------------------------------------------------
7497 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7498       subroutine e_modeller(ehomology_constr)
7499       ehomology_constr=0.0d0
7500       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7501       return
7502       end
7503 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7504
7505 c------------------------------------------------------------------------------
7506       subroutine etor_d(etors_d)
7507       etors_d=0.0d0
7508       return
7509       end
7510 c----------------------------------------------------------------------------
7511 #else
7512       subroutine etor(etors)
7513       implicit real*8 (a-h,o-z)
7514       include 'DIMENSIONS'
7515       include 'COMMON.VAR'
7516       include 'COMMON.GEO'
7517       include 'COMMON.LOCAL'
7518       include 'COMMON.TORSION'
7519       include 'COMMON.INTERACT'
7520       include 'COMMON.DERIV'
7521       include 'COMMON.CHAIN'
7522       include 'COMMON.NAMES'
7523       include 'COMMON.IOUNITS'
7524       include 'COMMON.FFIELD'
7525       include 'COMMON.TORCNSTR'
7526       include 'COMMON.CONTROL'
7527       logical lprn
7528 C Set lprn=.true. for debugging
7529       lprn=.false.
7530 c     lprn=.true.
7531       etors=0.0D0
7532       do i=iphi_start,iphi_end
7533 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7534 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7535 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7536 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7537         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7538      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7539 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7540 C For introducing the NH3+ and COO- group please check the etor_d for reference
7541 C and guidance
7542         etors_ii=0.0D0
7543          if (iabs(itype(i)).eq.20) then
7544          iblock=2
7545          else
7546          iblock=1
7547          endif
7548         itori=itortyp(itype(i-2))
7549         itori1=itortyp(itype(i-1))
7550         phii=phi(i)
7551         gloci=0.0D0
7552 C Regular cosine and sine terms
7553         do j=1,nterm(itori,itori1,iblock)
7554           v1ij=v1(j,itori,itori1,iblock)
7555           v2ij=v2(j,itori,itori1,iblock)
7556           cosphi=dcos(j*phii)
7557           sinphi=dsin(j*phii)
7558           etors=etors+v1ij*cosphi+v2ij*sinphi
7559           if (energy_dec) etors_ii=etors_ii+
7560      &                v1ij*cosphi+v2ij*sinphi
7561           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7562         enddo
7563 C Lorentz terms
7564 C                         v1
7565 C  E = SUM ----------------------------------- - v1
7566 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7567 C
7568         cosphi=dcos(0.5d0*phii)
7569         sinphi=dsin(0.5d0*phii)
7570         do j=1,nlor(itori,itori1,iblock)
7571           vl1ij=vlor1(j,itori,itori1)
7572           vl2ij=vlor2(j,itori,itori1)
7573           vl3ij=vlor3(j,itori,itori1)
7574           pom=vl2ij*cosphi+vl3ij*sinphi
7575           pom1=1.0d0/(pom*pom+1.0d0)
7576           etors=etors+vl1ij*pom1
7577           if (energy_dec) etors_ii=etors_ii+
7578      &                vl1ij*pom1
7579           pom=-pom*pom1*pom1
7580           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7581         enddo
7582 C Subtract the constant term
7583         etors=etors-v0(itori,itori1,iblock)
7584           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7585      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7586         if (lprn)
7587      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7588      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7589      &  (v1(j,itori,itori1,iblock),j=1,6),
7590      &  (v2(j,itori,itori1,iblock),j=1,6)
7591         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7592 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7593       enddo
7594       return
7595       end
7596 c----------------------------------------------------------------------------
7597       subroutine etor_d(etors_d)
7598 C 6/23/01 Compute double torsional energy
7599       implicit real*8 (a-h,o-z)
7600       include 'DIMENSIONS'
7601       include 'COMMON.VAR'
7602       include 'COMMON.GEO'
7603       include 'COMMON.LOCAL'
7604       include 'COMMON.TORSION'
7605       include 'COMMON.INTERACT'
7606       include 'COMMON.DERIV'
7607       include 'COMMON.CHAIN'
7608       include 'COMMON.NAMES'
7609       include 'COMMON.IOUNITS'
7610       include 'COMMON.FFIELD'
7611       include 'COMMON.TORCNSTR'
7612       logical lprn
7613 C Set lprn=.true. for debugging
7614       lprn=.false.
7615 c     lprn=.true.
7616       etors_d=0.0D0
7617 c      write(iout,*) "a tu??"
7618       do i=iphid_start,iphid_end
7619 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7620 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7621 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7622 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7623 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7624          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7625      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7626      &  (itype(i+1).eq.ntyp1)) cycle
7627 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7628         itori=itortyp(itype(i-2))
7629         itori1=itortyp(itype(i-1))
7630         itori2=itortyp(itype(i))
7631         phii=phi(i)
7632         phii1=phi(i+1)
7633         gloci1=0.0D0
7634         gloci2=0.0D0
7635         iblock=1
7636         if (iabs(itype(i+1)).eq.20) iblock=2
7637 C Iblock=2 Proline type
7638 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7639 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7640 C        if (itype(i+1).eq.ntyp1) iblock=3
7641 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7642 C IS or IS NOT need for this
7643 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7644 C        is (itype(i-3).eq.ntyp1) ntblock=2
7645 C        ntblock is N-terminal blocking group
7646
7647 C Regular cosine and sine terms
7648         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7649 C Example of changes for NH3+ blocking group
7650 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7651 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7652           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7653           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7654           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7655           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7656           cosphi1=dcos(j*phii)
7657           sinphi1=dsin(j*phii)
7658           cosphi2=dcos(j*phii1)
7659           sinphi2=dsin(j*phii1)
7660           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7661      &     v2cij*cosphi2+v2sij*sinphi2
7662           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7663           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7664         enddo
7665         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7666           do l=1,k-1
7667             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7668             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7669             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7670             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7671             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7672             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7673             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7674             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7675             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7676      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7677             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7678      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7679             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7680      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7681           enddo
7682         enddo
7683         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7684         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7685       enddo
7686       return
7687       end
7688 #endif
7689 C----------------------------------------------------------------------------------
7690 C The rigorous attempt to derive energy function
7691       subroutine etor_kcc(etors)
7692       implicit real*8 (a-h,o-z)
7693       include 'DIMENSIONS'
7694       include 'COMMON.VAR'
7695       include 'COMMON.GEO'
7696       include 'COMMON.LOCAL'
7697       include 'COMMON.TORSION'
7698       include 'COMMON.INTERACT'
7699       include 'COMMON.DERIV'
7700       include 'COMMON.CHAIN'
7701       include 'COMMON.NAMES'
7702       include 'COMMON.IOUNITS'
7703       include 'COMMON.FFIELD'
7704       include 'COMMON.TORCNSTR'
7705       include 'COMMON.CONTROL'
7706       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7707       logical lprn
7708 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7709 C Set lprn=.true. for debugging
7710       lprn=energy_dec
7711 c     lprn=.true.
7712 C      print *,"wchodze kcc"
7713       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7714       etors=0.0D0
7715       do i=iphi_start,iphi_end
7716 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7717 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7718 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7719 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7720         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7721      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7722         itori=itortyp(itype(i-2))
7723         itori1=itortyp(itype(i-1))
7724         phii=phi(i)
7725         glocig=0.0D0
7726         glocit1=0.0d0
7727         glocit2=0.0d0
7728 C to avoid multiple devision by 2
7729 c        theti22=0.5d0*theta(i)
7730 C theta 12 is the theta_1 /2
7731 C theta 22 is theta_2 /2
7732 c        theti12=0.5d0*theta(i-1)
7733 C and appropriate sinus function
7734         sinthet1=dsin(theta(i-1))
7735         sinthet2=dsin(theta(i))
7736         costhet1=dcos(theta(i-1))
7737         costhet2=dcos(theta(i))
7738 C to speed up lets store its mutliplication
7739         sint1t2=sinthet2*sinthet1
7740         sint1t2n=1.0d0
7741 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7742 C +d_n*sin(n*gamma)) *
7743 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7744 C we have two sum 1) Non-Chebyshev which is with n and gamma
7745         nval=nterm_kcc_Tb(itori,itori1)
7746         c1(0)=0.0d0
7747         c2(0)=0.0d0
7748         c1(1)=1.0d0
7749         c2(1)=1.0d0
7750         do j=2,nval
7751           c1(j)=c1(j-1)*costhet1
7752           c2(j)=c2(j-1)*costhet2
7753         enddo
7754         etori=0.0d0
7755         do j=1,nterm_kcc(itori,itori1)
7756           cosphi=dcos(j*phii)
7757           sinphi=dsin(j*phii)
7758           sint1t2n1=sint1t2n
7759           sint1t2n=sint1t2n*sint1t2
7760           sumvalc=0.0d0
7761           gradvalct1=0.0d0
7762           gradvalct2=0.0d0
7763           do k=1,nval
7764             do l=1,nval
7765               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7766               gradvalct1=gradvalct1+
7767      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7768               gradvalct2=gradvalct2+
7769      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7770             enddo
7771           enddo
7772           gradvalct1=-gradvalct1*sinthet1
7773           gradvalct2=-gradvalct2*sinthet2
7774           sumvals=0.0d0
7775           gradvalst1=0.0d0
7776           gradvalst2=0.0d0
7777           do k=1,nval
7778             do l=1,nval
7779               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7780               gradvalst1=gradvalst1+
7781      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7782               gradvalst2=gradvalst2+
7783      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7784             enddo
7785           enddo
7786           gradvalst1=-gradvalst1*sinthet1
7787           gradvalst2=-gradvalst2*sinthet2
7788           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7789           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7790 C glocig is the gradient local i site in gamma
7791           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7792 C now gradient over theta_1
7793           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7794      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7795           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7796      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7797         enddo ! j
7798         etors=etors+etori
7799 C derivative over gamma
7800         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7801 C derivative over theta1
7802         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7803 C now derivative over theta2
7804         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7805         if (lprn) then
7806           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7807      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7808           write (iout,*) "c1",(c1(k),k=0,nval),
7809      &    " c2",(c2(k),k=0,nval)
7810         endif
7811       enddo
7812       return
7813       end
7814 c---------------------------------------------------------------------------------------------
7815       subroutine etor_constr(edihcnstr)
7816       implicit real*8 (a-h,o-z)
7817       include 'DIMENSIONS'
7818       include 'COMMON.VAR'
7819       include 'COMMON.GEO'
7820       include 'COMMON.LOCAL'
7821       include 'COMMON.TORSION'
7822       include 'COMMON.INTERACT'
7823       include 'COMMON.DERIV'
7824       include 'COMMON.CHAIN'
7825       include 'COMMON.NAMES'
7826       include 'COMMON.IOUNITS'
7827       include 'COMMON.FFIELD'
7828       include 'COMMON.TORCNSTR'
7829       include 'COMMON.BOUNDS'
7830       include 'COMMON.CONTROL'
7831 ! 6/20/98 - dihedral angle constraints
7832       edihcnstr=0.0d0
7833 c      do i=1,ndih_constr
7834       if (raw_psipred) then
7835         do i=idihconstr_start,idihconstr_end
7836           itori=idih_constr(i)
7837           phii=phi(itori)
7838           gaudih_i=vpsipred(1,i)
7839           gauder_i=0.0d0
7840           do j=1,2
7841             s = sdihed(j,i)
7842             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7843             dexpcos_i=dexp(-cos_i*cos_i)
7844             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7845             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7846      &            *cos_i*dexpcos_i/s**2
7847           enddo
7848           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7849           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7850           if (energy_dec)
7851      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7852      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7853      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7854      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7855      &     -wdihc*dlog(gaudih_i)
7856         enddo
7857       else
7858
7859       do i=idihconstr_start,idihconstr_end
7860         itori=idih_constr(i)
7861         phii=phi(itori)
7862         difi=pinorm(phii-phi0(i))
7863         if (difi.gt.drange(i)) then
7864           difi=difi-drange(i)
7865           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7866           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7867         else if (difi.lt.-drange(i)) then
7868           difi=difi+drange(i)
7869           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7870           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7871         else
7872           difi=0.0
7873         endif
7874       enddo
7875
7876       endif
7877
7878       return
7879       end
7880 c----------------------------------------------------------------------------
7881 c MODELLER restraint function
7882       subroutine e_modeller(ehomology_constr)
7883       implicit none
7884       include 'DIMENSIONS'
7885
7886       double precision ehomology_constr
7887       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7888       integer katy, odleglosci, test7
7889       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7890       real*8 Eval,Erot
7891       real*8 distance(max_template),distancek(max_template),
7892      &    min_odl,godl(max_template),dih_diff(max_template)
7893
7894 c
7895 c     FP - 30/10/2014 Temporary specifications for homology restraints
7896 c
7897       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7898      &                 sgtheta
7899       double precision, dimension (maxres) :: guscdiff,usc_diff
7900       double precision, dimension (max_template) ::
7901      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7902      &           theta_diff
7903       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7904      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7905      & betai,sum_sgodl,dij
7906       double precision dist,pinorm
7907 c
7908       include 'COMMON.SBRIDGE'
7909       include 'COMMON.CHAIN'
7910       include 'COMMON.GEO'
7911       include 'COMMON.DERIV'
7912       include 'COMMON.LOCAL'
7913       include 'COMMON.INTERACT'
7914       include 'COMMON.VAR'
7915       include 'COMMON.IOUNITS'
7916 c      include 'COMMON.MD'
7917       include 'COMMON.CONTROL'
7918       include 'COMMON.HOMOLOGY'
7919       include 'COMMON.QRESTR'
7920 c
7921 c     From subroutine Econstr_back
7922 c
7923       include 'COMMON.NAMES'
7924       include 'COMMON.TIME1'
7925 c
7926
7927
7928       do i=1,max_template
7929         distancek(i)=9999999.9
7930       enddo
7931
7932
7933       odleg=0.0d0
7934
7935 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7936 c function)
7937 C AL 5/2/14 - Introduce list of restraints
7938 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7939 #ifdef DEBUG
7940       write(iout,*) "------- dist restrs start -------"
7941 #endif
7942       do ii = link_start_homo,link_end_homo
7943          i = ires_homo(ii)
7944          j = jres_homo(ii)
7945          dij=dist(i,j)
7946 c        write (iout,*) "dij(",i,j,") =",dij
7947          nexl=0
7948          do k=1,constr_homology
7949 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7950            if(.not.l_homo(k,ii)) then
7951              nexl=nexl+1
7952              cycle
7953            endif
7954            distance(k)=odl(k,ii)-dij
7955 c          write (iout,*) "distance(",k,") =",distance(k)
7956 c
7957 c          For Gaussian-type Urestr
7958 c
7959            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7960 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7961 c          write (iout,*) "distancek(",k,") =",distancek(k)
7962 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7963 c
7964 c          For Lorentzian-type Urestr
7965 c
7966            if (waga_dist.lt.0.0d0) then
7967               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7968               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7969      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7970            endif
7971          enddo
7972
7973 c         min_odl=minval(distancek)
7974          if (nexl.gt.0) then
7975            min_odl=0.0d0
7976          else
7977            do kk=1,constr_homology
7978             if(l_homo(kk,ii)) then
7979               min_odl=distancek(kk)
7980               exit
7981             endif
7982            enddo
7983            do kk=1,constr_homology
7984             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7985      &              min_odl=distancek(kk)
7986            enddo
7987          endif
7988
7989 c        write (iout,* )"min_odl",min_odl
7990 #ifdef DEBUG
7991          write (iout,*) "ij dij",i,j,dij
7992          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7993          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7994          write (iout,* )"min_odl",min_odl
7995 #endif
7996 #ifdef OLDRESTR
7997          odleg2=0.0d0
7998 #else
7999          if (waga_dist.ge.0.0d0) then
8000            odleg2=nexl
8001          else
8002            odleg2=0.0d0
8003          endif
8004 #endif
8005          do k=1,constr_homology
8006 c Nie wiem po co to liczycie jeszcze raz!
8007 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8008 c     &              (2*(sigma_odl(i,j,k))**2))
8009            if(.not.l_homo(k,ii)) cycle
8010            if (waga_dist.ge.0.0d0) then
8011 c
8012 c          For Gaussian-type Urestr
8013 c
8014             godl(k)=dexp(-distancek(k)+min_odl)
8015             odleg2=odleg2+godl(k)
8016 c
8017 c          For Lorentzian-type Urestr
8018 c
8019            else
8020             odleg2=odleg2+distancek(k)
8021            endif
8022
8023 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8024 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8025 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8026 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8027
8028          enddo
8029 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8030 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8031 #ifdef DEBUG
8032          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8033          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8034 #endif
8035            if (waga_dist.ge.0.0d0) then
8036 c
8037 c          For Gaussian-type Urestr
8038 c
8039               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8040 c
8041 c          For Lorentzian-type Urestr
8042 c
8043            else
8044               odleg=odleg+odleg2/constr_homology
8045            endif
8046 c
8047 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8048 c Gradient
8049 c
8050 c          For Gaussian-type Urestr
8051 c
8052          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8053          sum_sgodl=0.0d0
8054          do k=1,constr_homology
8055 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8056 c     &           *waga_dist)+min_odl
8057 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8058 c
8059          if(.not.l_homo(k,ii)) cycle
8060          if (waga_dist.ge.0.0d0) then
8061 c          For Gaussian-type Urestr
8062 c
8063            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8064 c
8065 c          For Lorentzian-type Urestr
8066 c
8067          else
8068            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8069      &           sigma_odlir(k,ii)**2)**2)
8070          endif
8071            sum_sgodl=sum_sgodl+sgodl
8072
8073 c            sgodl2=sgodl2+sgodl
8074 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8075 c      write(iout,*) "constr_homology=",constr_homology
8076 c      write(iout,*) i, j, k, "TEST K"
8077          enddo
8078          if (waga_dist.ge.0.0d0) then
8079 c
8080 c          For Gaussian-type Urestr
8081 c
8082             grad_odl3=waga_homology(iset)*waga_dist
8083      &                *sum_sgodl/(sum_godl*dij)
8084 c
8085 c          For Lorentzian-type Urestr
8086 c
8087          else
8088 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8089 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8090             grad_odl3=-waga_homology(iset)*waga_dist*
8091      &                sum_sgodl/(constr_homology*dij)
8092          endif
8093 c
8094 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8095
8096
8097 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8098 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8099 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8100
8101 ccc      write(iout,*) godl, sgodl, grad_odl3
8102
8103 c          grad_odl=grad_odl+grad_odl3
8104
8105          do jik=1,3
8106             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8107 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8108 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8109 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8110             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8111             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8112 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8113 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8114 c         if (i.eq.25.and.j.eq.27) then
8115 c         write(iout,*) "jik",jik,"i",i,"j",j
8116 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8117 c         write(iout,*) "grad_odl3",grad_odl3
8118 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8119 c         write(iout,*) "ggodl",ggodl
8120 c         write(iout,*) "ghpbc(",jik,i,")",
8121 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8122 c     &                 ghpbc(jik,j)
8123 c         endif
8124          enddo
8125 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8126 ccc     & dLOG(odleg2),"-odleg=", -odleg
8127
8128       enddo ! ii-loop for dist
8129 #ifdef DEBUG
8130       write(iout,*) "------- dist restrs end -------"
8131 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8132 c    &     waga_d.eq.1.0d0) call sum_gradient
8133 #endif
8134 c Pseudo-energy and gradient from dihedral-angle restraints from
8135 c homology templates
8136 c      write (iout,*) "End of distance loop"
8137 c      call flush(iout)
8138       kat=0.0d0
8139 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8140 #ifdef DEBUG
8141       write(iout,*) "------- dih restrs start -------"
8142       do i=idihconstr_start_homo,idihconstr_end_homo
8143         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8144       enddo
8145 #endif
8146       do i=idihconstr_start_homo,idihconstr_end_homo
8147         kat2=0.0d0
8148 c        betai=beta(i,i+1,i+2,i+3)
8149         betai = phi(i)
8150 c       write (iout,*) "betai =",betai
8151         do k=1,constr_homology
8152           dih_diff(k)=pinorm(dih(k,i)-betai)
8153 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8154 cd     &                  ,sigma_dih(k,i)
8155 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8156 c     &                                   -(6.28318-dih_diff(i,k))
8157 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8158 c     &                                   6.28318+dih_diff(i,k)
8159 #ifdef OLD_DIHED
8160           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8161 #else
8162           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8163 #endif
8164 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8165           gdih(k)=dexp(kat3)
8166           kat2=kat2+gdih(k)
8167 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8168 c          write(*,*)""
8169         enddo
8170 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8171 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8172 #ifdef DEBUG
8173         write (iout,*) "i",i," betai",betai," kat2",kat2
8174         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8175 #endif
8176         if (kat2.le.1.0d-14) cycle
8177         kat=kat-dLOG(kat2/constr_homology)
8178 c       write (iout,*) "kat",kat ! sum of -ln-s
8179
8180 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8181 ccc     & dLOG(kat2), "-kat=", -kat
8182
8183 c ----------------------------------------------------------------------
8184 c Gradient
8185 c ----------------------------------------------------------------------
8186
8187         sum_gdih=kat2
8188         sum_sgdih=0.0d0
8189         do k=1,constr_homology
8190 #ifdef OLD_DIHED
8191           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8192 #else
8193           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8194 #endif
8195 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8196           sum_sgdih=sum_sgdih+sgdih
8197         enddo
8198 c       grad_dih3=sum_sgdih/sum_gdih
8199         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8200
8201 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8202 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8203 ccc     & gloc(nphi+i-3,icg)
8204         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8205 c        if (i.eq.25) then
8206 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8207 c        endif
8208 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8209 ccc     & gloc(nphi+i-3,icg)
8210
8211       enddo ! i-loop for dih
8212 #ifdef DEBUG
8213       write(iout,*) "------- dih restrs end -------"
8214 #endif
8215
8216 c Pseudo-energy and gradient for theta angle restraints from
8217 c homology templates
8218 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8219 c adapted
8220
8221 c
8222 c     For constr_homology reference structures (FP)
8223 c
8224 c     Uconst_back_tot=0.0d0
8225       Eval=0.0d0
8226       Erot=0.0d0
8227 c     Econstr_back legacy
8228       do i=1,nres
8229 c     do i=ithet_start,ithet_end
8230        dutheta(i)=0.0d0
8231 c     enddo
8232 c     do i=loc_start,loc_end
8233         do j=1,3
8234           duscdiff(j,i)=0.0d0
8235           duscdiffx(j,i)=0.0d0
8236         enddo
8237       enddo
8238 c
8239 c     do iref=1,nref
8240 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8241 c     write (iout,*) "waga_theta",waga_theta
8242       if (waga_theta.gt.0.0d0) then
8243 #ifdef DEBUG
8244       write (iout,*) "usampl",usampl
8245       write(iout,*) "------- theta restrs start -------"
8246 c     do i=ithet_start,ithet_end
8247 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8248 c     enddo
8249 #endif
8250 c     write (iout,*) "maxres",maxres,"nres",nres
8251
8252       do i=ithet_start,ithet_end
8253 c
8254 c     do i=1,nfrag_back
8255 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8256 c
8257 c Deviation of theta angles wrt constr_homology ref structures
8258 c
8259         utheta_i=0.0d0 ! argument of Gaussian for single k
8260         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8261 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8262 c       over residues in a fragment
8263 c       write (iout,*) "theta(",i,")=",theta(i)
8264         do k=1,constr_homology
8265 c
8266 c         dtheta_i=theta(j)-thetaref(j,iref)
8267 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8268           theta_diff(k)=thetatpl(k,i)-theta(i)
8269 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8270 cd     &                  ,sigma_theta(k,i)
8271
8272 c
8273           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8274 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8275           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8276           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8277 c         Gradient for single Gaussian restraint in subr Econstr_back
8278 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8279 c
8280         enddo
8281 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8282 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8283
8284 c
8285 c         Gradient for multiple Gaussian restraint
8286         sum_gtheta=gutheta_i
8287         sum_sgtheta=0.0d0
8288         do k=1,constr_homology
8289 c        New generalized expr for multiple Gaussian from Econstr_back
8290          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8291 c
8292 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8293           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8294         enddo
8295 c       Final value of gradient using same var as in Econstr_back
8296         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8297      &      +sum_sgtheta/sum_gtheta*waga_theta
8298      &               *waga_homology(iset)
8299 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8300 c     &               *waga_homology(iset)
8301 c       dutheta(i)=sum_sgtheta/sum_gtheta
8302 c
8303 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8304         Eval=Eval-dLOG(gutheta_i/constr_homology)
8305 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8306 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8307 c       Uconst_back=Uconst_back+utheta(i)
8308       enddo ! (i-loop for theta)
8309 #ifdef DEBUG
8310       write(iout,*) "------- theta restrs end -------"
8311 #endif
8312       endif
8313 c
8314 c Deviation of local SC geometry
8315 c
8316 c Separation of two i-loops (instructed by AL - 11/3/2014)
8317 c
8318 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8319 c     write (iout,*) "waga_d",waga_d
8320
8321 #ifdef DEBUG
8322       write(iout,*) "------- SC restrs start -------"
8323       write (iout,*) "Initial duscdiff,duscdiffx"
8324       do i=loc_start,loc_end
8325         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8326      &                 (duscdiffx(jik,i),jik=1,3)
8327       enddo
8328 #endif
8329       do i=loc_start,loc_end
8330         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8331         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8332 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8333 c       write(iout,*) "xxtab, yytab, zztab"
8334 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8335         do k=1,constr_homology
8336 c
8337           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8338 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8339           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8340           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8341 c         write(iout,*) "dxx, dyy, dzz"
8342 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8343 c
8344           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8345 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8346 c         uscdiffk(k)=usc_diff(i)
8347           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8348 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8349 c     &       " guscdiff2",guscdiff2(k)
8350           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8351 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8352 c     &      xxref(j),yyref(j),zzref(j)
8353         enddo
8354 c
8355 c       Gradient
8356 c
8357 c       Generalized expression for multiple Gaussian acc to that for a single
8358 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8359 c
8360 c       Original implementation
8361 c       sum_guscdiff=guscdiff(i)
8362 c
8363 c       sum_sguscdiff=0.0d0
8364 c       do k=1,constr_homology
8365 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8366 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8367 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8368 c       enddo
8369 c
8370 c       Implementation of new expressions for gradient (Jan. 2015)
8371 c
8372 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8373         do k=1,constr_homology
8374 c
8375 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8376 c       before. Now the drivatives should be correct
8377 c
8378           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8379 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8380           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8381           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8382 c
8383 c         New implementation
8384 c
8385           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8386      &                 sigma_d(k,i) ! for the grad wrt r'
8387 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8388 c
8389 c
8390 c        New implementation
8391          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8392          do jik=1,3
8393             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8394      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8395      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8396             duscdiff(jik,i)=duscdiff(jik,i)+
8397      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8398      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8399             duscdiffx(jik,i)=duscdiffx(jik,i)+
8400      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8401      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8402 c
8403 #ifdef DEBUG
8404              write(iout,*) "jik",jik,"i",i
8405              write(iout,*) "dxx, dyy, dzz"
8406              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8407              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8408 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8409 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8410 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8411 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8412 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8413 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8414 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8415 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8416 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8417 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8418 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8419 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8420 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8421 c            endif
8422 #endif
8423          enddo
8424         enddo
8425 c
8426 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8427 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8428 c
8429 c        write (iout,*) i," uscdiff",uscdiff(i)
8430 c
8431 c Put together deviations from local geometry
8432
8433 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8434 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8435         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8436 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8437 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8438 c       Uconst_back=Uconst_back+usc_diff(i)
8439 c
8440 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8441 c
8442 c     New implment: multiplied by sum_sguscdiff
8443 c
8444
8445       enddo ! (i-loop for dscdiff)
8446
8447 c      endif
8448
8449 #ifdef DEBUG
8450       write(iout,*) "------- SC restrs end -------"
8451         write (iout,*) "------ After SC loop in e_modeller ------"
8452         do i=loc_start,loc_end
8453          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8454          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8455         enddo
8456       if (waga_theta.eq.1.0d0) then
8457       write (iout,*) "in e_modeller after SC restr end: dutheta"
8458       do i=ithet_start,ithet_end
8459         write (iout,*) i,dutheta(i)
8460       enddo
8461       endif
8462       if (waga_d.eq.1.0d0) then
8463       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8464       do i=1,nres
8465         write (iout,*) i,(duscdiff(j,i),j=1,3)
8466         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8467       enddo
8468       endif
8469 #endif
8470
8471 c Total energy from homology restraints
8472 #ifdef DEBUG
8473       write (iout,*) "odleg",odleg," kat",kat
8474 #endif
8475 c
8476 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8477 c
8478 c     ehomology_constr=odleg+kat
8479 c
8480 c     For Lorentzian-type Urestr
8481 c
8482
8483       if (waga_dist.ge.0.0d0) then
8484 c
8485 c          For Gaussian-type Urestr
8486 c
8487         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8488      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8489 c     write (iout,*) "ehomology_constr=",ehomology_constr
8490       else
8491 c
8492 c          For Lorentzian-type Urestr
8493 c
8494         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8495      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8496 c     write (iout,*) "ehomology_constr=",ehomology_constr
8497       endif
8498 #ifdef DEBUG
8499       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8500      & "Eval",waga_theta,eval,
8501      &   "Erot",waga_d,Erot
8502       write (iout,*) "ehomology_constr",ehomology_constr
8503 #endif
8504       return
8505 c
8506 c FP 01/15 end
8507 c
8508   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8509   747 format(a12,i4,i4,i4,f8.3,f8.3)
8510   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8511   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8512   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8513      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8514       end
8515 c----------------------------------------------------------------------------
8516 C The rigorous attempt to derive energy function
8517       subroutine ebend_kcc(etheta)
8518
8519       implicit real*8 (a-h,o-z)
8520       include 'DIMENSIONS'
8521       include 'COMMON.VAR'
8522       include 'COMMON.GEO'
8523       include 'COMMON.LOCAL'
8524       include 'COMMON.TORSION'
8525       include 'COMMON.INTERACT'
8526       include 'COMMON.DERIV'
8527       include 'COMMON.CHAIN'
8528       include 'COMMON.NAMES'
8529       include 'COMMON.IOUNITS'
8530       include 'COMMON.FFIELD'
8531       include 'COMMON.TORCNSTR'
8532       include 'COMMON.CONTROL'
8533       logical lprn
8534       double precision thybt1(maxang_kcc)
8535 C Set lprn=.true. for debugging
8536       lprn=energy_dec
8537 c     lprn=.true.
8538 C      print *,"wchodze kcc"
8539       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8540       etheta=0.0D0
8541       do i=ithet_start,ithet_end
8542 c        print *,i,itype(i-1),itype(i),itype(i-2)
8543         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8544      &  .or.itype(i).eq.ntyp1) cycle
8545         iti=iabs(itortyp(itype(i-1)))
8546         sinthet=dsin(theta(i))
8547         costhet=dcos(theta(i))
8548         do j=1,nbend_kcc_Tb(iti)
8549           thybt1(j)=v1bend_chyb(j,iti)
8550         enddo
8551         sumth1thyb=v1bend_chyb(0,iti)+
8552      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8553         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8554      &    sumth1thyb
8555         ihelp=nbend_kcc_Tb(iti)-1
8556         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8557         etheta=etheta+sumth1thyb
8558 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8559         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8560       enddo
8561       return
8562       end
8563 c-------------------------------------------------------------------------------------
8564       subroutine etheta_constr(ethetacnstr)
8565
8566       implicit real*8 (a-h,o-z)
8567       include 'DIMENSIONS'
8568       include 'COMMON.VAR'
8569       include 'COMMON.GEO'
8570       include 'COMMON.LOCAL'
8571       include 'COMMON.TORSION'
8572       include 'COMMON.INTERACT'
8573       include 'COMMON.DERIV'
8574       include 'COMMON.CHAIN'
8575       include 'COMMON.NAMES'
8576       include 'COMMON.IOUNITS'
8577       include 'COMMON.FFIELD'
8578       include 'COMMON.TORCNSTR'
8579       include 'COMMON.CONTROL'
8580       ethetacnstr=0.0d0
8581 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8582       do i=ithetaconstr_start,ithetaconstr_end
8583         itheta=itheta_constr(i)
8584         thetiii=theta(itheta)
8585         difi=pinorm(thetiii-theta_constr0(i))
8586         if (difi.gt.theta_drange(i)) then
8587           difi=difi-theta_drange(i)
8588           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8589           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8590      &    +for_thet_constr(i)*difi**3
8591         else if (difi.lt.-drange(i)) then
8592           difi=difi+drange(i)
8593           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8594           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8595      &    +for_thet_constr(i)*difi**3
8596         else
8597           difi=0.0
8598         endif
8599        if (energy_dec) then
8600         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8601      &    i,itheta,rad2deg*thetiii,
8602      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8603      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8604      &    gloc(itheta+nphi-2,icg)
8605         endif
8606       enddo
8607       return
8608       end
8609 c------------------------------------------------------------------------------
8610       subroutine eback_sc_corr(esccor)
8611 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8612 c        conformational states; temporarily implemented as differences
8613 c        between UNRES torsional potentials (dependent on three types of
8614 c        residues) and the torsional potentials dependent on all 20 types
8615 c        of residues computed from AM1  energy surfaces of terminally-blocked
8616 c        amino-acid residues.
8617       implicit real*8 (a-h,o-z)
8618       include 'DIMENSIONS'
8619       include 'COMMON.VAR'
8620       include 'COMMON.GEO'
8621       include 'COMMON.LOCAL'
8622       include 'COMMON.TORSION'
8623       include 'COMMON.SCCOR'
8624       include 'COMMON.INTERACT'
8625       include 'COMMON.DERIV'
8626       include 'COMMON.CHAIN'
8627       include 'COMMON.NAMES'
8628       include 'COMMON.IOUNITS'
8629       include 'COMMON.FFIELD'
8630       include 'COMMON.CONTROL'
8631       logical lprn
8632 C Set lprn=.true. for debugging
8633       lprn=.false.
8634 c      lprn=.true.
8635 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8636       esccor=0.0D0
8637       do i=itau_start,itau_end
8638         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8639         esccor_ii=0.0D0
8640         isccori=isccortyp(itype(i-2))
8641         isccori1=isccortyp(itype(i-1))
8642 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8643         phii=phi(i)
8644         do intertyp=1,3 !intertyp
8645 cc Added 09 May 2012 (Adasko)
8646 cc  Intertyp means interaction type of backbone mainchain correlation:
8647 c   1 = SC...Ca...Ca...Ca
8648 c   2 = Ca...Ca...Ca...SC
8649 c   3 = SC...Ca...Ca...SCi
8650         gloci=0.0D0
8651         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8652      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8653      &      (itype(i-1).eq.ntyp1)))
8654      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8655      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8656      &     .or.(itype(i).eq.ntyp1)))
8657      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8658      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8659      &      (itype(i-3).eq.ntyp1)))) cycle
8660         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8661         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8662      & cycle
8663        do j=1,nterm_sccor(isccori,isccori1)
8664           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8665           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8666           cosphi=dcos(j*tauangle(intertyp,i))
8667           sinphi=dsin(j*tauangle(intertyp,i))
8668           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8669           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8670         enddo
8671 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8672         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8673         if (lprn)
8674      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8675      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8676      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8677      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8678         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8679        enddo !intertyp
8680       enddo
8681
8682       return
8683       end
8684 #ifdef FOURBODY
8685 c----------------------------------------------------------------------------
8686       subroutine multibody(ecorr)
8687 C This subroutine calculates multi-body contributions to energy following
8688 C the idea of Skolnick et al. If side chains I and J make a contact and
8689 C at the same time side chains I+1 and J+1 make a contact, an extra
8690 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8691       implicit real*8 (a-h,o-z)
8692       include 'DIMENSIONS'
8693       include 'COMMON.IOUNITS'
8694       include 'COMMON.DERIV'
8695       include 'COMMON.INTERACT'
8696       include 'COMMON.CONTACTS'
8697       include 'COMMON.CONTMAT'
8698       include 'COMMON.CORRMAT'
8699       double precision gx(3),gx1(3)
8700       logical lprn
8701
8702 C Set lprn=.true. for debugging
8703       lprn=.false.
8704
8705       if (lprn) then
8706         write (iout,'(a)') 'Contact function values:'
8707         do i=nnt,nct-2
8708           write (iout,'(i2,20(1x,i2,f10.5))')
8709      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8710         enddo
8711       endif
8712       ecorr=0.0D0
8713       do i=nnt,nct
8714         do j=1,3
8715           gradcorr(j,i)=0.0D0
8716           gradxorr(j,i)=0.0D0
8717         enddo
8718       enddo
8719       do i=nnt,nct-2
8720
8721         DO ISHIFT = 3,4
8722
8723         i1=i+ishift
8724         num_conti=num_cont(i)
8725         num_conti1=num_cont(i1)
8726         do jj=1,num_conti
8727           j=jcont(jj,i)
8728           do kk=1,num_conti1
8729             j1=jcont(kk,i1)
8730             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8731 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8732 cd   &                   ' ishift=',ishift
8733 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8734 C The system gains extra energy.
8735               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8736             endif   ! j1==j+-ishift
8737           enddo     ! kk
8738         enddo       ! jj
8739
8740         ENDDO ! ISHIFT
8741
8742       enddo         ! i
8743       return
8744       end
8745 c------------------------------------------------------------------------------
8746       double precision function esccorr(i,j,k,l,jj,kk)
8747       implicit real*8 (a-h,o-z)
8748       include 'DIMENSIONS'
8749       include 'COMMON.IOUNITS'
8750       include 'COMMON.DERIV'
8751       include 'COMMON.INTERACT'
8752       include 'COMMON.CONTACTS'
8753       include 'COMMON.CONTMAT'
8754       include 'COMMON.CORRMAT'
8755       include 'COMMON.SHIELD'
8756       double precision gx(3),gx1(3)
8757       logical lprn
8758       lprn=.false.
8759       eij=facont(jj,i)
8760       ekl=facont(kk,k)
8761 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8762 C Calculate the multi-body contribution to energy.
8763 C Calculate multi-body contributions to the gradient.
8764 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8765 cd   & k,l,(gacont(m,kk,k),m=1,3)
8766       do m=1,3
8767         gx(m) =ekl*gacont(m,jj,i)
8768         gx1(m)=eij*gacont(m,kk,k)
8769         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8770         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8771         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8772         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8773       enddo
8774       do m=i,j-1
8775         do ll=1,3
8776           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8777         enddo
8778       enddo
8779       do m=k,l-1
8780         do ll=1,3
8781           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8782         enddo
8783       enddo
8784       esccorr=-eij*ekl
8785       return
8786       end
8787 c------------------------------------------------------------------------------
8788       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8789 C This subroutine calculates multi-body contributions to hydrogen-bonding
8790       implicit real*8 (a-h,o-z)
8791       include 'DIMENSIONS'
8792       include 'COMMON.IOUNITS'
8793 #ifdef MPI
8794       include "mpif.h"
8795       parameter (max_cont=maxconts)
8796       parameter (max_dim=26)
8797       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8798       double precision zapas(max_dim,maxconts,max_fg_procs),
8799      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8800       common /przechowalnia/ zapas
8801       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8802      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8803 #endif
8804       include 'COMMON.SETUP'
8805       include 'COMMON.FFIELD'
8806       include 'COMMON.DERIV'
8807       include 'COMMON.INTERACT'
8808       include 'COMMON.CONTACTS'
8809       include 'COMMON.CONTMAT'
8810       include 'COMMON.CORRMAT'
8811       include 'COMMON.CONTROL'
8812       include 'COMMON.LOCAL'
8813       double precision gx(3),gx1(3),time00
8814       logical lprn,ldone
8815
8816 C Set lprn=.true. for debugging
8817       lprn=.false.
8818 #ifdef MPI
8819       n_corr=0
8820       n_corr1=0
8821       if (nfgtasks.le.1) goto 30
8822       if (lprn) then
8823         write (iout,'(a)') 'Contact function values before RECEIVE:'
8824         do i=nnt,nct-2
8825           write (iout,'(2i3,50(1x,i2,f5.2))')
8826      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8827      &    j=1,num_cont_hb(i))
8828         enddo
8829         call flush(iout)
8830       endif
8831       do i=1,ntask_cont_from
8832         ncont_recv(i)=0
8833       enddo
8834       do i=1,ntask_cont_to
8835         ncont_sent(i)=0
8836       enddo
8837 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8838 c     & ntask_cont_to
8839 C Make the list of contacts to send to send to other procesors
8840 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8841 c      call flush(iout)
8842       do i=iturn3_start,iturn3_end
8843 c        write (iout,*) "make contact list turn3",i," num_cont",
8844 c     &    num_cont_hb(i)
8845         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8846       enddo
8847       do i=iturn4_start,iturn4_end
8848 c        write (iout,*) "make contact list turn4",i," num_cont",
8849 c     &   num_cont_hb(i)
8850         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8851       enddo
8852       do ii=1,nat_sent
8853         i=iat_sent(ii)
8854 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8855 c     &    num_cont_hb(i)
8856         do j=1,num_cont_hb(i)
8857         do k=1,4
8858           jjc=jcont_hb(j,i)
8859           iproc=iint_sent_local(k,jjc,ii)
8860 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8861           if (iproc.gt.0) then
8862             ncont_sent(iproc)=ncont_sent(iproc)+1
8863             nn=ncont_sent(iproc)
8864             zapas(1,nn,iproc)=i
8865             zapas(2,nn,iproc)=jjc
8866             zapas(3,nn,iproc)=facont_hb(j,i)
8867             zapas(4,nn,iproc)=ees0p(j,i)
8868             zapas(5,nn,iproc)=ees0m(j,i)
8869             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8870             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8871             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8872             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8873             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8874             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8875             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8876             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8877             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8878             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8879             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8880             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8881             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8882             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8883             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8884             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8885             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8886             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8887             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8888             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8889             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8890           endif
8891         enddo
8892         enddo
8893       enddo
8894       if (lprn) then
8895       write (iout,*)
8896      &  "Numbers of contacts to be sent to other processors",
8897      &  (ncont_sent(i),i=1,ntask_cont_to)
8898       write (iout,*) "Contacts sent"
8899       do ii=1,ntask_cont_to
8900         nn=ncont_sent(ii)
8901         iproc=itask_cont_to(ii)
8902         write (iout,*) nn," contacts to processor",iproc,
8903      &   " of CONT_TO_COMM group"
8904         do i=1,nn
8905           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8906         enddo
8907       enddo
8908       call flush(iout)
8909       endif
8910       CorrelType=477
8911       CorrelID=fg_rank+1
8912       CorrelType1=478
8913       CorrelID1=nfgtasks+fg_rank+1
8914       ireq=0
8915 C Receive the numbers of needed contacts from other processors
8916       do ii=1,ntask_cont_from
8917         iproc=itask_cont_from(ii)
8918         ireq=ireq+1
8919         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8920      &    FG_COMM,req(ireq),IERR)
8921       enddo
8922 c      write (iout,*) "IRECV ended"
8923 c      call flush(iout)
8924 C Send the number of contacts needed by other processors
8925       do ii=1,ntask_cont_to
8926         iproc=itask_cont_to(ii)
8927         ireq=ireq+1
8928         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8929      &    FG_COMM,req(ireq),IERR)
8930       enddo
8931 c      write (iout,*) "ISEND ended"
8932 c      write (iout,*) "number of requests (nn)",ireq
8933 c      call flush(iout)
8934       if (ireq.gt.0)
8935      &  call MPI_Waitall(ireq,req,status_array,ierr)
8936 c      write (iout,*)
8937 c     &  "Numbers of contacts to be received from other processors",
8938 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8939 c      call flush(iout)
8940 C Receive contacts
8941       ireq=0
8942       do ii=1,ntask_cont_from
8943         iproc=itask_cont_from(ii)
8944         nn=ncont_recv(ii)
8945 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8946 c     &   " of CONT_TO_COMM group"
8947 c        call flush(iout)
8948         if (nn.gt.0) then
8949           ireq=ireq+1
8950           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8951      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8952 c          write (iout,*) "ireq,req",ireq,req(ireq)
8953         endif
8954       enddo
8955 C Send the contacts to processors that need them
8956       do ii=1,ntask_cont_to
8957         iproc=itask_cont_to(ii)
8958         nn=ncont_sent(ii)
8959 c        write (iout,*) nn," contacts to processor",iproc,
8960 c     &   " of CONT_TO_COMM group"
8961         if (nn.gt.0) then
8962           ireq=ireq+1
8963           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8964      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8965 c          write (iout,*) "ireq,req",ireq,req(ireq)
8966 c          do i=1,nn
8967 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8968 c          enddo
8969         endif
8970       enddo
8971 c      write (iout,*) "number of requests (contacts)",ireq
8972 c      write (iout,*) "req",(req(i),i=1,4)
8973 c      call flush(iout)
8974       if (ireq.gt.0)
8975      & call MPI_Waitall(ireq,req,status_array,ierr)
8976       do iii=1,ntask_cont_from
8977         iproc=itask_cont_from(iii)
8978         nn=ncont_recv(iii)
8979         if (lprn) then
8980         write (iout,*) "Received",nn," contacts from processor",iproc,
8981      &   " of CONT_FROM_COMM group"
8982         call flush(iout)
8983         do i=1,nn
8984           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8985         enddo
8986         call flush(iout)
8987         endif
8988         do i=1,nn
8989           ii=zapas_recv(1,i,iii)
8990 c Flag the received contacts to prevent double-counting
8991           jj=-zapas_recv(2,i,iii)
8992 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8993 c          call flush(iout)
8994           nnn=num_cont_hb(ii)+1
8995           num_cont_hb(ii)=nnn
8996           jcont_hb(nnn,ii)=jj
8997           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8998           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8999           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9000           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9001           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9002           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9003           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9004           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9005           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9006           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9007           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9008           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9009           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9010           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9011           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9012           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9013           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9014           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9015           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9016           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9017           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9018           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9019           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9020           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9021         enddo
9022       enddo
9023       if (lprn) then
9024         write (iout,'(a)') 'Contact function values after receive:'
9025         do i=nnt,nct-2
9026           write (iout,'(2i3,50(1x,i3,f5.2))')
9027      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9028      &    j=1,num_cont_hb(i))
9029         enddo
9030         call flush(iout)
9031       endif
9032    30 continue
9033 #endif
9034       if (lprn) then
9035         write (iout,'(a)') 'Contact function values:'
9036         do i=nnt,nct-2
9037           write (iout,'(2i3,50(1x,i3,f5.2))')
9038      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9039      &    j=1,num_cont_hb(i))
9040         enddo
9041         call flush(iout)
9042       endif
9043       ecorr=0.0D0
9044 C Remove the loop below after debugging !!!
9045       do i=nnt,nct
9046         do j=1,3
9047           gradcorr(j,i)=0.0D0
9048           gradxorr(j,i)=0.0D0
9049         enddo
9050       enddo
9051 C Calculate the local-electrostatic correlation terms
9052       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9053         i1=i+1
9054         num_conti=num_cont_hb(i)
9055         num_conti1=num_cont_hb(i+1)
9056         do jj=1,num_conti
9057           j=jcont_hb(jj,i)
9058           jp=iabs(j)
9059           do kk=1,num_conti1
9060             j1=jcont_hb(kk,i1)
9061             jp1=iabs(j1)
9062 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9063 c     &         ' jj=',jj,' kk=',kk
9064 c            call flush(iout)
9065             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9066      &          .or. j.lt.0 .and. j1.gt.0) .and.
9067      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9068 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9069 C The system gains extra energy.
9070               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9071               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9072      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9073               n_corr=n_corr+1
9074             else if (j1.eq.j) then
9075 C Contacts I-J and I-(J+1) occur simultaneously.
9076 C The system loses extra energy.
9077 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9078             endif
9079           enddo ! kk
9080           do kk=1,num_conti
9081             j1=jcont_hb(kk,i)
9082 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9083 c    &         ' jj=',jj,' kk=',kk
9084             if (j1.eq.j+1) then
9085 C Contacts I-J and (I+1)-J occur simultaneously.
9086 C The system loses extra energy.
9087 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9088             endif ! j1==j+1
9089           enddo ! kk
9090         enddo ! jj
9091       enddo ! i
9092       return
9093       end
9094 c------------------------------------------------------------------------------
9095       subroutine add_hb_contact(ii,jj,itask)
9096       implicit real*8 (a-h,o-z)
9097       include "DIMENSIONS"
9098       include "COMMON.IOUNITS"
9099       integer max_cont
9100       integer max_dim
9101       parameter (max_cont=maxconts)
9102       parameter (max_dim=26)
9103       include "COMMON.CONTACTS"
9104       include 'COMMON.CONTMAT'
9105       include 'COMMON.CORRMAT'
9106       double precision zapas(max_dim,maxconts,max_fg_procs),
9107      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9108       common /przechowalnia/ zapas
9109       integer i,j,ii,jj,iproc,itask(4),nn
9110 c      write (iout,*) "itask",itask
9111       do i=1,2
9112         iproc=itask(i)
9113         if (iproc.gt.0) then
9114           do j=1,num_cont_hb(ii)
9115             jjc=jcont_hb(j,ii)
9116 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9117             if (jjc.eq.jj) then
9118               ncont_sent(iproc)=ncont_sent(iproc)+1
9119               nn=ncont_sent(iproc)
9120               zapas(1,nn,iproc)=ii
9121               zapas(2,nn,iproc)=jjc
9122               zapas(3,nn,iproc)=facont_hb(j,ii)
9123               zapas(4,nn,iproc)=ees0p(j,ii)
9124               zapas(5,nn,iproc)=ees0m(j,ii)
9125               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9126               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9127               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9128               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9129               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9130               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9131               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9132               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9133               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9134               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9135               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9136               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9137               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9138               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9139               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9140               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9141               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9142               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9143               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9144               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9145               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9146               exit
9147             endif
9148           enddo
9149         endif
9150       enddo
9151       return
9152       end
9153 c------------------------------------------------------------------------------
9154       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9155      &  n_corr1)
9156 C This subroutine calculates multi-body contributions to hydrogen-bonding
9157       implicit real*8 (a-h,o-z)
9158       include 'DIMENSIONS'
9159       include 'COMMON.IOUNITS'
9160 #ifdef MPI
9161       include "mpif.h"
9162       parameter (max_cont=maxconts)
9163       parameter (max_dim=70)
9164       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9165       double precision zapas(max_dim,maxconts,max_fg_procs),
9166      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9167       common /przechowalnia/ zapas
9168       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9169      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9170 #endif
9171       include 'COMMON.SETUP'
9172       include 'COMMON.FFIELD'
9173       include 'COMMON.DERIV'
9174       include 'COMMON.LOCAL'
9175       include 'COMMON.INTERACT'
9176       include 'COMMON.CONTACTS'
9177       include 'COMMON.CONTMAT'
9178       include 'COMMON.CORRMAT'
9179       include 'COMMON.CHAIN'
9180       include 'COMMON.CONTROL'
9181       include 'COMMON.SHIELD'
9182       double precision gx(3),gx1(3)
9183       integer num_cont_hb_old(maxres)
9184       logical lprn,ldone
9185       double precision eello4,eello5,eelo6,eello_turn6
9186       external eello4,eello5,eello6,eello_turn6
9187 C Set lprn=.true. for debugging
9188       lprn=.false.
9189       eturn6=0.0d0
9190 #ifdef MPI
9191       do i=1,nres
9192         num_cont_hb_old(i)=num_cont_hb(i)
9193       enddo
9194       n_corr=0
9195       n_corr1=0
9196       if (nfgtasks.le.1) goto 30
9197       if (lprn) then
9198         write (iout,'(a)') 'Contact function values before RECEIVE:'
9199         do i=nnt,nct-2
9200           write (iout,'(2i3,50(1x,i2,f5.2))')
9201      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9202      &    j=1,num_cont_hb(i))
9203         enddo
9204       endif
9205       do i=1,ntask_cont_from
9206         ncont_recv(i)=0
9207       enddo
9208       do i=1,ntask_cont_to
9209         ncont_sent(i)=0
9210       enddo
9211 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9212 c     & ntask_cont_to
9213 C Make the list of contacts to send to send to other procesors
9214       do i=iturn3_start,iturn3_end
9215 c        write (iout,*) "make contact list turn3",i," num_cont",
9216 c     &    num_cont_hb(i)
9217         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9218       enddo
9219       do i=iturn4_start,iturn4_end
9220 c        write (iout,*) "make contact list turn4",i," num_cont",
9221 c     &   num_cont_hb(i)
9222         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9223       enddo
9224       do ii=1,nat_sent
9225         i=iat_sent(ii)
9226 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9227 c     &    num_cont_hb(i)
9228         do j=1,num_cont_hb(i)
9229         do k=1,4
9230           jjc=jcont_hb(j,i)
9231           iproc=iint_sent_local(k,jjc,ii)
9232 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9233           if (iproc.ne.0) then
9234             ncont_sent(iproc)=ncont_sent(iproc)+1
9235             nn=ncont_sent(iproc)
9236             zapas(1,nn,iproc)=i
9237             zapas(2,nn,iproc)=jjc
9238             zapas(3,nn,iproc)=d_cont(j,i)
9239             ind=3
9240             do kk=1,3
9241               ind=ind+1
9242               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9243             enddo
9244             do kk=1,2
9245               do ll=1,2
9246                 ind=ind+1
9247                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9248               enddo
9249             enddo
9250             do jj=1,5
9251               do kk=1,3
9252                 do ll=1,2
9253                   do mm=1,2
9254                     ind=ind+1
9255                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9256                   enddo
9257                 enddo
9258               enddo
9259             enddo
9260           endif
9261         enddo
9262         enddo
9263       enddo
9264       if (lprn) then
9265       write (iout,*)
9266      &  "Numbers of contacts to be sent to other processors",
9267      &  (ncont_sent(i),i=1,ntask_cont_to)
9268       write (iout,*) "Contacts sent"
9269       do ii=1,ntask_cont_to
9270         nn=ncont_sent(ii)
9271         iproc=itask_cont_to(ii)
9272         write (iout,*) nn," contacts to processor",iproc,
9273      &   " of CONT_TO_COMM group"
9274         do i=1,nn
9275           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9276         enddo
9277       enddo
9278       call flush(iout)
9279       endif
9280       CorrelType=477
9281       CorrelID=fg_rank+1
9282       CorrelType1=478
9283       CorrelID1=nfgtasks+fg_rank+1
9284       ireq=0
9285 C Receive the numbers of needed contacts from other processors
9286       do ii=1,ntask_cont_from
9287         iproc=itask_cont_from(ii)
9288         ireq=ireq+1
9289         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9290      &    FG_COMM,req(ireq),IERR)
9291       enddo
9292 c      write (iout,*) "IRECV ended"
9293 c      call flush(iout)
9294 C Send the number of contacts needed by other processors
9295       do ii=1,ntask_cont_to
9296         iproc=itask_cont_to(ii)
9297         ireq=ireq+1
9298         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9299      &    FG_COMM,req(ireq),IERR)
9300       enddo
9301 c      write (iout,*) "ISEND ended"
9302 c      write (iout,*) "number of requests (nn)",ireq
9303 c      call flush(iout)
9304       if (ireq.gt.0)
9305      &  call MPI_Waitall(ireq,req,status_array,ierr)
9306 c      write (iout,*)
9307 c     &  "Numbers of contacts to be received from other processors",
9308 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9309 c      call flush(iout)
9310 C Receive contacts
9311       ireq=0
9312       do ii=1,ntask_cont_from
9313         iproc=itask_cont_from(ii)
9314         nn=ncont_recv(ii)
9315 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9316 c     &   " of CONT_TO_COMM group"
9317 c        call flush(iout)
9318         if (nn.gt.0) then
9319           ireq=ireq+1
9320           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9321      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9322 c          write (iout,*) "ireq,req",ireq,req(ireq)
9323         endif
9324       enddo
9325 C Send the contacts to processors that need them
9326       do ii=1,ntask_cont_to
9327         iproc=itask_cont_to(ii)
9328         nn=ncont_sent(ii)
9329 c        write (iout,*) nn," contacts to processor",iproc,
9330 c     &   " of CONT_TO_COMM group"
9331         if (nn.gt.0) then
9332           ireq=ireq+1
9333           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9334      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9335 c          write (iout,*) "ireq,req",ireq,req(ireq)
9336 c          do i=1,nn
9337 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9338 c          enddo
9339         endif
9340       enddo
9341 c      write (iout,*) "number of requests (contacts)",ireq
9342 c      write (iout,*) "req",(req(i),i=1,4)
9343 c      call flush(iout)
9344       if (ireq.gt.0)
9345      & call MPI_Waitall(ireq,req,status_array,ierr)
9346       do iii=1,ntask_cont_from
9347         iproc=itask_cont_from(iii)
9348         nn=ncont_recv(iii)
9349         if (lprn) then
9350         write (iout,*) "Received",nn," contacts from processor",iproc,
9351      &   " of CONT_FROM_COMM group"
9352         call flush(iout)
9353         do i=1,nn
9354           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9355         enddo
9356         call flush(iout)
9357         endif
9358         do i=1,nn
9359           ii=zapas_recv(1,i,iii)
9360 c Flag the received contacts to prevent double-counting
9361           jj=-zapas_recv(2,i,iii)
9362 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9363 c          call flush(iout)
9364           nnn=num_cont_hb(ii)+1
9365           num_cont_hb(ii)=nnn
9366           jcont_hb(nnn,ii)=jj
9367           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9368           ind=3
9369           do kk=1,3
9370             ind=ind+1
9371             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9372           enddo
9373           do kk=1,2
9374             do ll=1,2
9375               ind=ind+1
9376               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9377             enddo
9378           enddo
9379           do jj=1,5
9380             do kk=1,3
9381               do ll=1,2
9382                 do mm=1,2
9383                   ind=ind+1
9384                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9385                 enddo
9386               enddo
9387             enddo
9388           enddo
9389         enddo
9390       enddo
9391       if (lprn) then
9392         write (iout,'(a)') 'Contact function values after receive:'
9393         do i=nnt,nct-2
9394           write (iout,'(2i3,50(1x,i3,5f6.3))')
9395      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9396      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9397         enddo
9398         call flush(iout)
9399       endif
9400    30 continue
9401 #endif
9402       if (lprn) then
9403         write (iout,'(a)') 'Contact function values:'
9404         do i=nnt,nct-2
9405           write (iout,'(2i3,50(1x,i2,5f6.3))')
9406      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9407      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9408         enddo
9409       endif
9410       ecorr=0.0D0
9411       ecorr5=0.0d0
9412       ecorr6=0.0d0
9413 C Remove the loop below after debugging !!!
9414       do i=nnt,nct
9415         do j=1,3
9416           gradcorr(j,i)=0.0D0
9417           gradxorr(j,i)=0.0D0
9418         enddo
9419       enddo
9420 C Calculate the dipole-dipole interaction energies
9421       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9422       do i=iatel_s,iatel_e+1
9423         num_conti=num_cont_hb(i)
9424         do jj=1,num_conti
9425           j=jcont_hb(jj,i)
9426 #ifdef MOMENT
9427           call dipole(i,j,jj)
9428 #endif
9429         enddo
9430       enddo
9431       endif
9432 C Calculate the local-electrostatic correlation terms
9433 c                write (iout,*) "gradcorr5 in eello5 before loop"
9434 c                do iii=1,nres
9435 c                  write (iout,'(i5,3f10.5)')
9436 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9437 c                enddo
9438       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9439 c        write (iout,*) "corr loop i",i
9440         i1=i+1
9441         num_conti=num_cont_hb(i)
9442         num_conti1=num_cont_hb(i+1)
9443         do jj=1,num_conti
9444           j=jcont_hb(jj,i)
9445           jp=iabs(j)
9446           do kk=1,num_conti1
9447             j1=jcont_hb(kk,i1)
9448             jp1=iabs(j1)
9449 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9450 c     &         ' jj=',jj,' kk=',kk
9451 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9452             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9453      &          .or. j.lt.0 .and. j1.gt.0) .and.
9454      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9455 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9456 C The system gains extra energy.
9457               n_corr=n_corr+1
9458               sqd1=dsqrt(d_cont(jj,i))
9459               sqd2=dsqrt(d_cont(kk,i1))
9460               sred_geom = sqd1*sqd2
9461               IF (sred_geom.lt.cutoff_corr) THEN
9462                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9463      &            ekont,fprimcont)
9464 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9465 cd     &         ' jj=',jj,' kk=',kk
9466                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9467                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9468                 do l=1,3
9469                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9470                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9471                 enddo
9472                 n_corr1=n_corr1+1
9473 cd               write (iout,*) 'sred_geom=',sred_geom,
9474 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9475 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9476 cd               write (iout,*) "g_contij",g_contij
9477 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9478 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9479                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9480                 if (wcorr4.gt.0.0d0)
9481      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9482 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9483                   if (energy_dec.and.wcorr4.gt.0.0d0)
9484      1                 write (iout,'(a6,4i5,0pf7.3)')
9485      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9486 c                write (iout,*) "gradcorr5 before eello5"
9487 c                do iii=1,nres
9488 c                  write (iout,'(i5,3f10.5)')
9489 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9490 c                enddo
9491                 if (wcorr5.gt.0.0d0)
9492      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9493 c                write (iout,*) "gradcorr5 after eello5"
9494 c                do iii=1,nres
9495 c                  write (iout,'(i5,3f10.5)')
9496 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9497 c                enddo
9498                   if (energy_dec.and.wcorr5.gt.0.0d0)
9499      1                 write (iout,'(a6,4i5,0pf7.3)')
9500      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9501 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9502 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9503                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9504      &               .or. wturn6.eq.0.0d0))then
9505 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9506                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9507                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9508      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9509 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9510 cd     &            'ecorr6=',ecorr6
9511 cd                write (iout,'(4e15.5)') sred_geom,
9512 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9513 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9514 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9515                 else if (wturn6.gt.0.0d0
9516      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9517 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9518                   eturn6=eturn6+eello_turn6(i,jj,kk)
9519                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9520      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9521 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9522                 endif
9523               ENDIF
9524 1111          continue
9525             endif
9526           enddo ! kk
9527         enddo ! jj
9528       enddo ! i
9529       do i=1,nres
9530         num_cont_hb(i)=num_cont_hb_old(i)
9531       enddo
9532 c                write (iout,*) "gradcorr5 in eello5"
9533 c                do iii=1,nres
9534 c                  write (iout,'(i5,3f10.5)')
9535 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9536 c                enddo
9537       return
9538       end
9539 c------------------------------------------------------------------------------
9540       subroutine add_hb_contact_eello(ii,jj,itask)
9541       implicit real*8 (a-h,o-z)
9542       include "DIMENSIONS"
9543       include "COMMON.IOUNITS"
9544       integer max_cont
9545       integer max_dim
9546       parameter (max_cont=maxconts)
9547       parameter (max_dim=70)
9548       include "COMMON.CONTACTS"
9549       include 'COMMON.CONTMAT'
9550       include 'COMMON.CORRMAT'
9551       double precision zapas(max_dim,maxconts,max_fg_procs),
9552      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9553       common /przechowalnia/ zapas
9554       integer i,j,ii,jj,iproc,itask(4),nn
9555 c      write (iout,*) "itask",itask
9556       do i=1,2
9557         iproc=itask(i)
9558         if (iproc.gt.0) then
9559           do j=1,num_cont_hb(ii)
9560             jjc=jcont_hb(j,ii)
9561 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9562             if (jjc.eq.jj) then
9563               ncont_sent(iproc)=ncont_sent(iproc)+1
9564               nn=ncont_sent(iproc)
9565               zapas(1,nn,iproc)=ii
9566               zapas(2,nn,iproc)=jjc
9567               zapas(3,nn,iproc)=d_cont(j,ii)
9568               ind=3
9569               do kk=1,3
9570                 ind=ind+1
9571                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9572               enddo
9573               do kk=1,2
9574                 do ll=1,2
9575                   ind=ind+1
9576                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9577                 enddo
9578               enddo
9579               do jj=1,5
9580                 do kk=1,3
9581                   do ll=1,2
9582                     do mm=1,2
9583                       ind=ind+1
9584                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9585                     enddo
9586                   enddo
9587                 enddo
9588               enddo
9589               exit
9590             endif
9591           enddo
9592         endif
9593       enddo
9594       return
9595       end
9596 c------------------------------------------------------------------------------
9597       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9598       implicit real*8 (a-h,o-z)
9599       include 'DIMENSIONS'
9600       include 'COMMON.IOUNITS'
9601       include 'COMMON.DERIV'
9602       include 'COMMON.INTERACT'
9603       include 'COMMON.CONTACTS'
9604       include 'COMMON.CONTMAT'
9605       include 'COMMON.CORRMAT'
9606       include 'COMMON.SHIELD'
9607       include 'COMMON.CONTROL'
9608       double precision gx(3),gx1(3)
9609       logical lprn
9610       lprn=.false.
9611 C      print *,"wchodze",fac_shield(i),shield_mode
9612       eij=facont_hb(jj,i)
9613       ekl=facont_hb(kk,k)
9614       ees0pij=ees0p(jj,i)
9615       ees0pkl=ees0p(kk,k)
9616       ees0mij=ees0m(jj,i)
9617       ees0mkl=ees0m(kk,k)
9618       ekont=eij*ekl
9619       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9620 C*
9621 C     & fac_shield(i)**2*fac_shield(j)**2
9622 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9623 C Following 4 lines for diagnostics.
9624 cd    ees0pkl=0.0D0
9625 cd    ees0pij=1.0D0
9626 cd    ees0mkl=0.0D0
9627 cd    ees0mij=1.0D0
9628 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9629 c     & 'Contacts ',i,j,
9630 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9631 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9632 c     & 'gradcorr_long'
9633 C Calculate the multi-body contribution to energy.
9634 C      ecorr=ecorr+ekont*ees
9635 C Calculate multi-body contributions to the gradient.
9636       coeffpees0pij=coeffp*ees0pij
9637       coeffmees0mij=coeffm*ees0mij
9638       coeffpees0pkl=coeffp*ees0pkl
9639       coeffmees0mkl=coeffm*ees0mkl
9640       do ll=1,3
9641 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9642         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9643      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9644      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9645         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9646      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9647      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9648 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9649         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9650      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9651      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9652         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9653      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9654      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9655         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9656      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9657      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9658         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9659         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9660         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9661      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9662      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9663         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9664         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9665 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9666       enddo
9667 c      write (iout,*)
9668 cgrad      do m=i+1,j-1
9669 cgrad        do ll=1,3
9670 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9671 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9672 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9673 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9674 cgrad        enddo
9675 cgrad      enddo
9676 cgrad      do m=k+1,l-1
9677 cgrad        do ll=1,3
9678 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9679 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9680 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9681 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9682 cgrad        enddo
9683 cgrad      enddo
9684 c      write (iout,*) "ehbcorr",ekont*ees
9685 C      print *,ekont,ees,i,k
9686       ehbcorr=ekont*ees
9687 C now gradient over shielding
9688 C      return
9689       if (shield_mode.gt.0) then
9690        j=ees0plist(jj,i)
9691        l=ees0plist(kk,k)
9692 C        print *,i,j,fac_shield(i),fac_shield(j),
9693 C     &fac_shield(k),fac_shield(l)
9694         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9695      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9696           do ilist=1,ishield_list(i)
9697            iresshield=shield_list(ilist,i)
9698            do m=1,3
9699            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9700 C     &      *2.0
9701            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9702      &              rlocshield
9703      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9704             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9705      &+rlocshield
9706            enddo
9707           enddo
9708           do ilist=1,ishield_list(j)
9709            iresshield=shield_list(ilist,j)
9710            do m=1,3
9711            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9712 C     &     *2.0
9713            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9714      &              rlocshield
9715      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9716            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9717      &     +rlocshield
9718            enddo
9719           enddo
9720
9721           do ilist=1,ishield_list(k)
9722            iresshield=shield_list(ilist,k)
9723            do m=1,3
9724            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9725 C     &     *2.0
9726            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9727      &              rlocshield
9728      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9729            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9730      &     +rlocshield
9731            enddo
9732           enddo
9733           do ilist=1,ishield_list(l)
9734            iresshield=shield_list(ilist,l)
9735            do m=1,3
9736            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9737 C     &     *2.0
9738            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9739      &              rlocshield
9740      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9741            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9742      &     +rlocshield
9743            enddo
9744           enddo
9745 C          print *,gshieldx(m,iresshield)
9746           do m=1,3
9747             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9748      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9749             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9750      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9751             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9752      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9753             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9754      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9755
9756             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9757      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9758             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9759      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9760             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9761      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9762             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9763      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9764
9765            enddo
9766       endif
9767       endif
9768       return
9769       end
9770 #ifdef MOMENT
9771 C---------------------------------------------------------------------------
9772       subroutine dipole(i,j,jj)
9773       implicit real*8 (a-h,o-z)
9774       include 'DIMENSIONS'
9775       include 'COMMON.IOUNITS'
9776       include 'COMMON.CHAIN'
9777       include 'COMMON.FFIELD'
9778       include 'COMMON.DERIV'
9779       include 'COMMON.INTERACT'
9780       include 'COMMON.CONTACTS'
9781       include 'COMMON.CONTMAT'
9782       include 'COMMON.CORRMAT'
9783       include 'COMMON.TORSION'
9784       include 'COMMON.VAR'
9785       include 'COMMON.GEO'
9786       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9787      &  auxmat(2,2)
9788       iti1 = itortyp(itype(i+1))
9789       if (j.lt.nres-1) then
9790         itj1 = itype2loc(itype(j+1))
9791       else
9792         itj1=nloctyp
9793       endif
9794       do iii=1,2
9795         dipi(iii,1)=Ub2(iii,i)
9796         dipderi(iii)=Ub2der(iii,i)
9797         dipi(iii,2)=b1(iii,i+1)
9798         dipj(iii,1)=Ub2(iii,j)
9799         dipderj(iii)=Ub2der(iii,j)
9800         dipj(iii,2)=b1(iii,j+1)
9801       enddo
9802       kkk=0
9803       do iii=1,2
9804         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9805         do jjj=1,2
9806           kkk=kkk+1
9807           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9808         enddo
9809       enddo
9810       do kkk=1,5
9811         do lll=1,3
9812           mmm=0
9813           do iii=1,2
9814             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9815      &        auxvec(1))
9816             do jjj=1,2
9817               mmm=mmm+1
9818               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9819             enddo
9820           enddo
9821         enddo
9822       enddo
9823       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9824       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9825       do iii=1,2
9826         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9827       enddo
9828       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9829       do iii=1,2
9830         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9831       enddo
9832       return
9833       end
9834 #endif
9835 C---------------------------------------------------------------------------
9836       subroutine calc_eello(i,j,k,l,jj,kk)
9837 C
9838 C This subroutine computes matrices and vectors needed to calculate
9839 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9840 C
9841       implicit real*8 (a-h,o-z)
9842       include 'DIMENSIONS'
9843       include 'COMMON.IOUNITS'
9844       include 'COMMON.CHAIN'
9845       include 'COMMON.DERIV'
9846       include 'COMMON.INTERACT'
9847       include 'COMMON.CONTACTS'
9848       include 'COMMON.CONTMAT'
9849       include 'COMMON.CORRMAT'
9850       include 'COMMON.TORSION'
9851       include 'COMMON.VAR'
9852       include 'COMMON.GEO'
9853       include 'COMMON.FFIELD'
9854       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9855      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9856       logical lprn
9857       common /kutas/ lprn
9858 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9859 cd     & ' jj=',jj,' kk=',kk
9860 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9861 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9862 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9863       do iii=1,2
9864         do jjj=1,2
9865           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9866           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9867         enddo
9868       enddo
9869       call transpose2(aa1(1,1),aa1t(1,1))
9870       call transpose2(aa2(1,1),aa2t(1,1))
9871       do kkk=1,5
9872         do lll=1,3
9873           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9874      &      aa1tder(1,1,lll,kkk))
9875           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9876      &      aa2tder(1,1,lll,kkk))
9877         enddo
9878       enddo
9879       if (l.eq.j+1) then
9880 C parallel orientation of the two CA-CA-CA frames.
9881         if (i.gt.1) then
9882           iti=itype2loc(itype(i))
9883         else
9884           iti=nloctyp
9885         endif
9886         itk1=itype2loc(itype(k+1))
9887         itj=itype2loc(itype(j))
9888         if (l.lt.nres-1) then
9889           itl1=itype2loc(itype(l+1))
9890         else
9891           itl1=nloctyp
9892         endif
9893 C A1 kernel(j+1) A2T
9894 cd        do iii=1,2
9895 cd          write (iout,'(3f10.5,5x,3f10.5)')
9896 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9897 cd        enddo
9898         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9899      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9900      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9901 C Following matrices are needed only for 6-th order cumulants
9902         IF (wcorr6.gt.0.0d0) THEN
9903         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9904      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9905      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9906         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9907      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9908      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9909      &   ADtEAderx(1,1,1,1,1,1))
9910         lprn=.false.
9911         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9912      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9913      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9914      &   ADtEA1derx(1,1,1,1,1,1))
9915         ENDIF
9916 C End 6-th order cumulants
9917 cd        lprn=.false.
9918 cd        if (lprn) then
9919 cd        write (2,*) 'In calc_eello6'
9920 cd        do iii=1,2
9921 cd          write (2,*) 'iii=',iii
9922 cd          do kkk=1,5
9923 cd            write (2,*) 'kkk=',kkk
9924 cd            do jjj=1,2
9925 cd              write (2,'(3(2f10.5),5x)')
9926 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9927 cd            enddo
9928 cd          enddo
9929 cd        enddo
9930 cd        endif
9931         call transpose2(EUgder(1,1,k),auxmat(1,1))
9932         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9933         call transpose2(EUg(1,1,k),auxmat(1,1))
9934         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9935         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9936 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9937 c    in theta; to be sriten later.
9938 c#ifdef NEWCORR
9939 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9940 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9941 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9942 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9943 c#endif
9944         do iii=1,2
9945           do kkk=1,5
9946             do lll=1,3
9947               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9948      &          EAEAderx(1,1,lll,kkk,iii,1))
9949             enddo
9950           enddo
9951         enddo
9952 C A1T kernel(i+1) A2
9953         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9954      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9955      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9956 C Following matrices are needed only for 6-th order cumulants
9957         IF (wcorr6.gt.0.0d0) THEN
9958         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9959      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9960      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9961         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9962      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9963      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9964      &   ADtEAderx(1,1,1,1,1,2))
9965         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9966      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9967      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9968      &   ADtEA1derx(1,1,1,1,1,2))
9969         ENDIF
9970 C End 6-th order cumulants
9971         call transpose2(EUgder(1,1,l),auxmat(1,1))
9972         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9973         call transpose2(EUg(1,1,l),auxmat(1,1))
9974         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9975         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9976         do iii=1,2
9977           do kkk=1,5
9978             do lll=1,3
9979               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9980      &          EAEAderx(1,1,lll,kkk,iii,2))
9981             enddo
9982           enddo
9983         enddo
9984 C AEAb1 and AEAb2
9985 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9986 C They are needed only when the fifth- or the sixth-order cumulants are
9987 C indluded.
9988         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9989         call transpose2(AEA(1,1,1),auxmat(1,1))
9990         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9991         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9992         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9993         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9994         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9995         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9996         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9997         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9998         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9999         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10000         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10001         call transpose2(AEA(1,1,2),auxmat(1,1))
10002         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10003         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10004         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10005         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10006         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10007         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10008         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10009         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10010         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10011         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10012         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10013 C Calculate the Cartesian derivatives of the vectors.
10014         do iii=1,2
10015           do kkk=1,5
10016             do lll=1,3
10017               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10018               call matvec2(auxmat(1,1),b1(1,i),
10019      &          AEAb1derx(1,lll,kkk,iii,1,1))
10020               call matvec2(auxmat(1,1),Ub2(1,i),
10021      &          AEAb2derx(1,lll,kkk,iii,1,1))
10022               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10023      &          AEAb1derx(1,lll,kkk,iii,2,1))
10024               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10025      &          AEAb2derx(1,lll,kkk,iii,2,1))
10026               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10027               call matvec2(auxmat(1,1),b1(1,j),
10028      &          AEAb1derx(1,lll,kkk,iii,1,2))
10029               call matvec2(auxmat(1,1),Ub2(1,j),
10030      &          AEAb2derx(1,lll,kkk,iii,1,2))
10031               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10032      &          AEAb1derx(1,lll,kkk,iii,2,2))
10033               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10034      &          AEAb2derx(1,lll,kkk,iii,2,2))
10035             enddo
10036           enddo
10037         enddo
10038         ENDIF
10039 C End vectors
10040       else
10041 C Antiparallel orientation of the two CA-CA-CA frames.
10042         if (i.gt.1) then
10043           iti=itype2loc(itype(i))
10044         else
10045           iti=nloctyp
10046         endif
10047         itk1=itype2loc(itype(k+1))
10048         itl=itype2loc(itype(l))
10049         itj=itype2loc(itype(j))
10050         if (j.lt.nres-1) then
10051           itj1=itype2loc(itype(j+1))
10052         else
10053           itj1=nloctyp
10054         endif
10055 C A2 kernel(j-1)T A1T
10056         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10057      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10058      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10059 C Following matrices are needed only for 6-th order cumulants
10060         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10061      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10062         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10063      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10064      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10065         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10066      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10067      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10068      &   ADtEAderx(1,1,1,1,1,1))
10069         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10070      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10071      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10072      &   ADtEA1derx(1,1,1,1,1,1))
10073         ENDIF
10074 C End 6-th order cumulants
10075         call transpose2(EUgder(1,1,k),auxmat(1,1))
10076         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10077         call transpose2(EUg(1,1,k),auxmat(1,1))
10078         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10079         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10080         do iii=1,2
10081           do kkk=1,5
10082             do lll=1,3
10083               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10084      &          EAEAderx(1,1,lll,kkk,iii,1))
10085             enddo
10086           enddo
10087         enddo
10088 C A2T kernel(i+1)T A1
10089         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10090      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10091      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10092 C Following matrices are needed only for 6-th order cumulants
10093         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10094      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10095         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10096      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10097      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10098         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10099      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10100      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10101      &   ADtEAderx(1,1,1,1,1,2))
10102         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10103      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10104      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10105      &   ADtEA1derx(1,1,1,1,1,2))
10106         ENDIF
10107 C End 6-th order cumulants
10108         call transpose2(EUgder(1,1,j),auxmat(1,1))
10109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10110         call transpose2(EUg(1,1,j),auxmat(1,1))
10111         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10112         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10113         do iii=1,2
10114           do kkk=1,5
10115             do lll=1,3
10116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10117      &          EAEAderx(1,1,lll,kkk,iii,2))
10118             enddo
10119           enddo
10120         enddo
10121 C AEAb1 and AEAb2
10122 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10123 C They are needed only when the fifth- or the sixth-order cumulants are
10124 C indluded.
10125         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10126      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10127         call transpose2(AEA(1,1,1),auxmat(1,1))
10128         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10129         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10130         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10131         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10132         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10133         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10134         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10135         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10136         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10137         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10138         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10139         call transpose2(AEA(1,1,2),auxmat(1,1))
10140         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10141         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10142         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10143         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10144         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10145         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10146         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10147         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10148         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10149         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10150         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10151 C Calculate the Cartesian derivatives of the vectors.
10152         do iii=1,2
10153           do kkk=1,5
10154             do lll=1,3
10155               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10156               call matvec2(auxmat(1,1),b1(1,i),
10157      &          AEAb1derx(1,lll,kkk,iii,1,1))
10158               call matvec2(auxmat(1,1),Ub2(1,i),
10159      &          AEAb2derx(1,lll,kkk,iii,1,1))
10160               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10161      &          AEAb1derx(1,lll,kkk,iii,2,1))
10162               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10163      &          AEAb2derx(1,lll,kkk,iii,2,1))
10164               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10165               call matvec2(auxmat(1,1),b1(1,l),
10166      &          AEAb1derx(1,lll,kkk,iii,1,2))
10167               call matvec2(auxmat(1,1),Ub2(1,l),
10168      &          AEAb2derx(1,lll,kkk,iii,1,2))
10169               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10170      &          AEAb1derx(1,lll,kkk,iii,2,2))
10171               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10172      &          AEAb2derx(1,lll,kkk,iii,2,2))
10173             enddo
10174           enddo
10175         enddo
10176         ENDIF
10177 C End vectors
10178       endif
10179       return
10180       end
10181 C---------------------------------------------------------------------------
10182       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10183      &  KK,KKderg,AKA,AKAderg,AKAderx)
10184       implicit none
10185       integer nderg
10186       logical transp
10187       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10188      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10189      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10190       integer iii,kkk,lll
10191       integer jjj,mmm
10192       logical lprn
10193       common /kutas/ lprn
10194       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10195       do iii=1,nderg
10196         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10197      &    AKAderg(1,1,iii))
10198       enddo
10199 cd      if (lprn) write (2,*) 'In kernel'
10200       do kkk=1,5
10201 cd        if (lprn) write (2,*) 'kkk=',kkk
10202         do lll=1,3
10203           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10204      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10205 cd          if (lprn) then
10206 cd            write (2,*) 'lll=',lll
10207 cd            write (2,*) 'iii=1'
10208 cd            do jjj=1,2
10209 cd              write (2,'(3(2f10.5),5x)')
10210 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10211 cd            enddo
10212 cd          endif
10213           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10214      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10215 cd          if (lprn) then
10216 cd            write (2,*) 'lll=',lll
10217 cd            write (2,*) 'iii=2'
10218 cd            do jjj=1,2
10219 cd              write (2,'(3(2f10.5),5x)')
10220 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10221 cd            enddo
10222 cd          endif
10223         enddo
10224       enddo
10225       return
10226       end
10227 C---------------------------------------------------------------------------
10228       double precision function eello4(i,j,k,l,jj,kk)
10229       implicit real*8 (a-h,o-z)
10230       include 'DIMENSIONS'
10231       include 'COMMON.IOUNITS'
10232       include 'COMMON.CHAIN'
10233       include 'COMMON.DERIV'
10234       include 'COMMON.INTERACT'
10235       include 'COMMON.CONTACTS'
10236       include 'COMMON.CONTMAT'
10237       include 'COMMON.CORRMAT'
10238       include 'COMMON.TORSION'
10239       include 'COMMON.VAR'
10240       include 'COMMON.GEO'
10241       double precision pizda(2,2),ggg1(3),ggg2(3)
10242 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10243 cd        eello4=0.0d0
10244 cd        return
10245 cd      endif
10246 cd      print *,'eello4:',i,j,k,l,jj,kk
10247 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10248 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10249 cold      eij=facont_hb(jj,i)
10250 cold      ekl=facont_hb(kk,k)
10251 cold      ekont=eij*ekl
10252       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10253 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10254       gcorr_loc(k-1)=gcorr_loc(k-1)
10255      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10256       if (l.eq.j+1) then
10257         gcorr_loc(l-1)=gcorr_loc(l-1)
10258      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10259 C Al 4/16/16: Derivatives in theta, to be added later.
10260 c#ifdef NEWCORR
10261 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10262 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10263 c#endif
10264       else
10265         gcorr_loc(j-1)=gcorr_loc(j-1)
10266      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10267 c#ifdef NEWCORR
10268 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10269 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10270 c#endif
10271       endif
10272       do iii=1,2
10273         do kkk=1,5
10274           do lll=1,3
10275             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10276      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10277 cd            derx(lll,kkk,iii)=0.0d0
10278           enddo
10279         enddo
10280       enddo
10281 cd      gcorr_loc(l-1)=0.0d0
10282 cd      gcorr_loc(j-1)=0.0d0
10283 cd      gcorr_loc(k-1)=0.0d0
10284 cd      eel4=1.0d0
10285 cd      write (iout,*)'Contacts have occurred for peptide groups',
10286 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10287 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10288       if (j.lt.nres-1) then
10289         j1=j+1
10290         j2=j-1
10291       else
10292         j1=j-1
10293         j2=j-2
10294       endif
10295       if (l.lt.nres-1) then
10296         l1=l+1
10297         l2=l-1
10298       else
10299         l1=l-1
10300         l2=l-2
10301       endif
10302       do ll=1,3
10303 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10304 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10305         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10306         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10307 cgrad        ghalf=0.5d0*ggg1(ll)
10308         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10309         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10310         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10311         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10312         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10313         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10314 cgrad        ghalf=0.5d0*ggg2(ll)
10315         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10316         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10317         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10318         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10319         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10320         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10321       enddo
10322 cgrad      do m=i+1,j-1
10323 cgrad        do ll=1,3
10324 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10325 cgrad        enddo
10326 cgrad      enddo
10327 cgrad      do m=k+1,l-1
10328 cgrad        do ll=1,3
10329 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10330 cgrad        enddo
10331 cgrad      enddo
10332 cgrad      do m=i+2,j2
10333 cgrad        do ll=1,3
10334 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10335 cgrad        enddo
10336 cgrad      enddo
10337 cgrad      do m=k+2,l2
10338 cgrad        do ll=1,3
10339 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10340 cgrad        enddo
10341 cgrad      enddo
10342 cd      do iii=1,nres-3
10343 cd        write (2,*) iii,gcorr_loc(iii)
10344 cd      enddo
10345       eello4=ekont*eel4
10346 cd      write (2,*) 'ekont',ekont
10347 cd      write (iout,*) 'eello4',ekont*eel4
10348       return
10349       end
10350 C---------------------------------------------------------------------------
10351       double precision function eello5(i,j,k,l,jj,kk)
10352       implicit real*8 (a-h,o-z)
10353       include 'DIMENSIONS'
10354       include 'COMMON.IOUNITS'
10355       include 'COMMON.CHAIN'
10356       include 'COMMON.DERIV'
10357       include 'COMMON.INTERACT'
10358       include 'COMMON.CONTACTS'
10359       include 'COMMON.CONTMAT'
10360       include 'COMMON.CORRMAT'
10361       include 'COMMON.TORSION'
10362       include 'COMMON.VAR'
10363       include 'COMMON.GEO'
10364       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10365       double precision ggg1(3),ggg2(3)
10366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10367 C                                                                              C
10368 C                            Parallel chains                                   C
10369 C                                                                              C
10370 C          o             o                   o             o                   C
10371 C         /l\           / \             \   / \           / \   /              C
10372 C        /   \         /   \             \ /   \         /   \ /               C
10373 C       j| o |l1       | o |              o| o |         | o |o                C
10374 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10375 C      \i/   \         /   \ /             /   \         /   \                 C
10376 C       o    k1             o                                                  C
10377 C         (I)          (II)                (III)          (IV)                 C
10378 C                                                                              C
10379 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10380 C                                                                              C
10381 C                            Antiparallel chains                               C
10382 C                                                                              C
10383 C          o             o                   o             o                   C
10384 C         /j\           / \             \   / \           / \   /              C
10385 C        /   \         /   \             \ /   \         /   \ /               C
10386 C      j1| o |l        | o |              o| o |         | o |o                C
10387 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10388 C      \i/   \         /   \ /             /   \         /   \                 C
10389 C       o     k1            o                                                  C
10390 C         (I)          (II)                (III)          (IV)                 C
10391 C                                                                              C
10392 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10393 C                                                                              C
10394 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10395 C                                                                              C
10396 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10397 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10398 cd        eello5=0.0d0
10399 cd        return
10400 cd      endif
10401 cd      write (iout,*)
10402 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10403 cd     &   ' and',k,l
10404       itk=itype2loc(itype(k))
10405       itl=itype2loc(itype(l))
10406       itj=itype2loc(itype(j))
10407       eello5_1=0.0d0
10408       eello5_2=0.0d0
10409       eello5_3=0.0d0
10410       eello5_4=0.0d0
10411 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10412 cd     &   eel5_3_num,eel5_4_num)
10413       do iii=1,2
10414         do kkk=1,5
10415           do lll=1,3
10416             derx(lll,kkk,iii)=0.0d0
10417           enddo
10418         enddo
10419       enddo
10420 cd      eij=facont_hb(jj,i)
10421 cd      ekl=facont_hb(kk,k)
10422 cd      ekont=eij*ekl
10423 cd      write (iout,*)'Contacts have occurred for peptide groups',
10424 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10425 cd      goto 1111
10426 C Contribution from the graph I.
10427 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10428 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10429       call transpose2(EUg(1,1,k),auxmat(1,1))
10430       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10431       vv(1)=pizda(1,1)-pizda(2,2)
10432       vv(2)=pizda(1,2)+pizda(2,1)
10433       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10434      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10435 C Explicit gradient in virtual-dihedral angles.
10436       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10437      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10438      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10439       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10440       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10441       vv(1)=pizda(1,1)-pizda(2,2)
10442       vv(2)=pizda(1,2)+pizda(2,1)
10443       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10444      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10445      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10446       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10447       vv(1)=pizda(1,1)-pizda(2,2)
10448       vv(2)=pizda(1,2)+pizda(2,1)
10449       if (l.eq.j+1) then
10450         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10451      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10452      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10453       else
10454         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10455      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10456      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10457       endif
10458 C Cartesian gradient
10459       do iii=1,2
10460         do kkk=1,5
10461           do lll=1,3
10462             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10463      &        pizda(1,1))
10464             vv(1)=pizda(1,1)-pizda(2,2)
10465             vv(2)=pizda(1,2)+pizda(2,1)
10466             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10467      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10468      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10469           enddo
10470         enddo
10471       enddo
10472 c      goto 1112
10473 c1111  continue
10474 C Contribution from graph II
10475       call transpose2(EE(1,1,k),auxmat(1,1))
10476       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10477       vv(1)=pizda(1,1)+pizda(2,2)
10478       vv(2)=pizda(2,1)-pizda(1,2)
10479       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10480      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10481 C Explicit gradient in virtual-dihedral angles.
10482       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10483      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10484       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10485       vv(1)=pizda(1,1)+pizda(2,2)
10486       vv(2)=pizda(2,1)-pizda(1,2)
10487       if (l.eq.j+1) then
10488         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10489      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10490      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10491       else
10492         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10493      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10494      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10495       endif
10496 C Cartesian gradient
10497       do iii=1,2
10498         do kkk=1,5
10499           do lll=1,3
10500             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10501      &        pizda(1,1))
10502             vv(1)=pizda(1,1)+pizda(2,2)
10503             vv(2)=pizda(2,1)-pizda(1,2)
10504             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10505      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10506      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10507           enddo
10508         enddo
10509       enddo
10510 cd      goto 1112
10511 cd1111  continue
10512       if (l.eq.j+1) then
10513 cd        goto 1110
10514 C Parallel orientation
10515 C Contribution from graph III
10516         call transpose2(EUg(1,1,l),auxmat(1,1))
10517         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10518         vv(1)=pizda(1,1)-pizda(2,2)
10519         vv(2)=pizda(1,2)+pizda(2,1)
10520         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10521      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10522 C Explicit gradient in virtual-dihedral angles.
10523         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10524      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10525      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10526         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10527         vv(1)=pizda(1,1)-pizda(2,2)
10528         vv(2)=pizda(1,2)+pizda(2,1)
10529         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10530      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10531      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10532         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10533         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10534         vv(1)=pizda(1,1)-pizda(2,2)
10535         vv(2)=pizda(1,2)+pizda(2,1)
10536         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10537      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10538      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10539 C Cartesian gradient
10540         do iii=1,2
10541           do kkk=1,5
10542             do lll=1,3
10543               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10544      &          pizda(1,1))
10545               vv(1)=pizda(1,1)-pizda(2,2)
10546               vv(2)=pizda(1,2)+pizda(2,1)
10547               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10548      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10549      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10550             enddo
10551           enddo
10552         enddo
10553 cd        goto 1112
10554 C Contribution from graph IV
10555 cd1110    continue
10556         call transpose2(EE(1,1,l),auxmat(1,1))
10557         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10558         vv(1)=pizda(1,1)+pizda(2,2)
10559         vv(2)=pizda(2,1)-pizda(1,2)
10560         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10561      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10562 C Explicit gradient in virtual-dihedral angles.
10563         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10564      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10565         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10566         vv(1)=pizda(1,1)+pizda(2,2)
10567         vv(2)=pizda(2,1)-pizda(1,2)
10568         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10569      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10570      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10571 C Cartesian gradient
10572         do iii=1,2
10573           do kkk=1,5
10574             do lll=1,3
10575               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10576      &          pizda(1,1))
10577               vv(1)=pizda(1,1)+pizda(2,2)
10578               vv(2)=pizda(2,1)-pizda(1,2)
10579               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10580      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10581      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10582             enddo
10583           enddo
10584         enddo
10585       else
10586 C Antiparallel orientation
10587 C Contribution from graph III
10588 c        goto 1110
10589         call transpose2(EUg(1,1,j),auxmat(1,1))
10590         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10591         vv(1)=pizda(1,1)-pizda(2,2)
10592         vv(2)=pizda(1,2)+pizda(2,1)
10593         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10594      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10595 C Explicit gradient in virtual-dihedral angles.
10596         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10597      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10598      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10599         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10600         vv(1)=pizda(1,1)-pizda(2,2)
10601         vv(2)=pizda(1,2)+pizda(2,1)
10602         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10603      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10604      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10605         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10606         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10607         vv(1)=pizda(1,1)-pizda(2,2)
10608         vv(2)=pizda(1,2)+pizda(2,1)
10609         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10610      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10611      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10612 C Cartesian gradient
10613         do iii=1,2
10614           do kkk=1,5
10615             do lll=1,3
10616               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10617      &          pizda(1,1))
10618               vv(1)=pizda(1,1)-pizda(2,2)
10619               vv(2)=pizda(1,2)+pizda(2,1)
10620               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10621      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10622      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10623             enddo
10624           enddo
10625         enddo
10626 cd        goto 1112
10627 C Contribution from graph IV
10628 1110    continue
10629         call transpose2(EE(1,1,j),auxmat(1,1))
10630         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10631         vv(1)=pizda(1,1)+pizda(2,2)
10632         vv(2)=pizda(2,1)-pizda(1,2)
10633         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10634      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10635 C Explicit gradient in virtual-dihedral angles.
10636         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10637      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10638         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10639         vv(1)=pizda(1,1)+pizda(2,2)
10640         vv(2)=pizda(2,1)-pizda(1,2)
10641         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10642      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10643      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10644 C Cartesian gradient
10645         do iii=1,2
10646           do kkk=1,5
10647             do lll=1,3
10648               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10649      &          pizda(1,1))
10650               vv(1)=pizda(1,1)+pizda(2,2)
10651               vv(2)=pizda(2,1)-pizda(1,2)
10652               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10653      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10654      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10655             enddo
10656           enddo
10657         enddo
10658       endif
10659 1112  continue
10660       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10661 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10662 cd        write (2,*) 'ijkl',i,j,k,l
10663 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10664 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10665 cd      endif
10666 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10667 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10668 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10669 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10670       if (j.lt.nres-1) then
10671         j1=j+1
10672         j2=j-1
10673       else
10674         j1=j-1
10675         j2=j-2
10676       endif
10677       if (l.lt.nres-1) then
10678         l1=l+1
10679         l2=l-1
10680       else
10681         l1=l-1
10682         l2=l-2
10683       endif
10684 cd      eij=1.0d0
10685 cd      ekl=1.0d0
10686 cd      ekont=1.0d0
10687 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10688 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10689 C        summed up outside the subrouine as for the other subroutines
10690 C        handling long-range interactions. The old code is commented out
10691 C        with "cgrad" to keep track of changes.
10692       do ll=1,3
10693 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10694 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10695         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10696         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10697 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10698 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10699 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10700 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10701 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10702 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10703 c     &   gradcorr5ij,
10704 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10705 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10706 cgrad        ghalf=0.5d0*ggg1(ll)
10707 cd        ghalf=0.0d0
10708         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10709         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10710         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10711         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10712         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10713         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10714 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10715 cgrad        ghalf=0.5d0*ggg2(ll)
10716 cd        ghalf=0.0d0
10717         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10718         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10719         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10720         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10721         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10722         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10723       enddo
10724 cd      goto 1112
10725 cgrad      do m=i+1,j-1
10726 cgrad        do ll=1,3
10727 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10728 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10729 cgrad        enddo
10730 cgrad      enddo
10731 cgrad      do m=k+1,l-1
10732 cgrad        do ll=1,3
10733 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10734 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10735 cgrad        enddo
10736 cgrad      enddo
10737 c1112  continue
10738 cgrad      do m=i+2,j2
10739 cgrad        do ll=1,3
10740 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10741 cgrad        enddo
10742 cgrad      enddo
10743 cgrad      do m=k+2,l2
10744 cgrad        do ll=1,3
10745 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10746 cgrad        enddo
10747 cgrad      enddo
10748 cd      do iii=1,nres-3
10749 cd        write (2,*) iii,g_corr5_loc(iii)
10750 cd      enddo
10751       eello5=ekont*eel5
10752 cd      write (2,*) 'ekont',ekont
10753 cd      write (iout,*) 'eello5',ekont*eel5
10754       return
10755       end
10756 c--------------------------------------------------------------------------
10757       double precision function eello6(i,j,k,l,jj,kk)
10758       implicit real*8 (a-h,o-z)
10759       include 'DIMENSIONS'
10760       include 'COMMON.IOUNITS'
10761       include 'COMMON.CHAIN'
10762       include 'COMMON.DERIV'
10763       include 'COMMON.INTERACT'
10764       include 'COMMON.CONTACTS'
10765       include 'COMMON.CONTMAT'
10766       include 'COMMON.CORRMAT'
10767       include 'COMMON.TORSION'
10768       include 'COMMON.VAR'
10769       include 'COMMON.GEO'
10770       include 'COMMON.FFIELD'
10771       double precision ggg1(3),ggg2(3)
10772 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10773 cd        eello6=0.0d0
10774 cd        return
10775 cd      endif
10776 cd      write (iout,*)
10777 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10778 cd     &   ' and',k,l
10779       eello6_1=0.0d0
10780       eello6_2=0.0d0
10781       eello6_3=0.0d0
10782       eello6_4=0.0d0
10783       eello6_5=0.0d0
10784       eello6_6=0.0d0
10785 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10786 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10787       do iii=1,2
10788         do kkk=1,5
10789           do lll=1,3
10790             derx(lll,kkk,iii)=0.0d0
10791           enddo
10792         enddo
10793       enddo
10794 cd      eij=facont_hb(jj,i)
10795 cd      ekl=facont_hb(kk,k)
10796 cd      ekont=eij*ekl
10797 cd      eij=1.0d0
10798 cd      ekl=1.0d0
10799 cd      ekont=1.0d0
10800       if (l.eq.j+1) then
10801         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10802         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10803         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10804         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10805         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10806         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10807       else
10808         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10809         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10810         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10811         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10812         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10813           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10814         else
10815           eello6_5=0.0d0
10816         endif
10817         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10818       endif
10819 C If turn contributions are considered, they will be handled separately.
10820       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10821 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10822 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10823 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10824 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10825 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10826 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10827 cd      goto 1112
10828       if (j.lt.nres-1) then
10829         j1=j+1
10830         j2=j-1
10831       else
10832         j1=j-1
10833         j2=j-2
10834       endif
10835       if (l.lt.nres-1) then
10836         l1=l+1
10837         l2=l-1
10838       else
10839         l1=l-1
10840         l2=l-2
10841       endif
10842       do ll=1,3
10843 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10844 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10845 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10846 cgrad        ghalf=0.5d0*ggg1(ll)
10847 cd        ghalf=0.0d0
10848         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10849         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10850         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10851         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10852         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10853         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10854         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10855         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10856 cgrad        ghalf=0.5d0*ggg2(ll)
10857 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10858 cd        ghalf=0.0d0
10859         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10860         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10861         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10862         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10863         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10864         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10865       enddo
10866 cd      goto 1112
10867 cgrad      do m=i+1,j-1
10868 cgrad        do ll=1,3
10869 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10870 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10871 cgrad        enddo
10872 cgrad      enddo
10873 cgrad      do m=k+1,l-1
10874 cgrad        do ll=1,3
10875 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10876 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10877 cgrad        enddo
10878 cgrad      enddo
10879 cgrad1112  continue
10880 cgrad      do m=i+2,j2
10881 cgrad        do ll=1,3
10882 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10883 cgrad        enddo
10884 cgrad      enddo
10885 cgrad      do m=k+2,l2
10886 cgrad        do ll=1,3
10887 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10888 cgrad        enddo
10889 cgrad      enddo
10890 cd      do iii=1,nres-3
10891 cd        write (2,*) iii,g_corr6_loc(iii)
10892 cd      enddo
10893       eello6=ekont*eel6
10894 cd      write (2,*) 'ekont',ekont
10895 cd      write (iout,*) 'eello6',ekont*eel6
10896       return
10897       end
10898 c--------------------------------------------------------------------------
10899       double precision function eello6_graph1(i,j,k,l,imat,swap)
10900       implicit real*8 (a-h,o-z)
10901       include 'DIMENSIONS'
10902       include 'COMMON.IOUNITS'
10903       include 'COMMON.CHAIN'
10904       include 'COMMON.DERIV'
10905       include 'COMMON.INTERACT'
10906       include 'COMMON.CONTACTS'
10907       include 'COMMON.CONTMAT'
10908       include 'COMMON.CORRMAT'
10909       include 'COMMON.TORSION'
10910       include 'COMMON.VAR'
10911       include 'COMMON.GEO'
10912       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10913       logical swap
10914       logical lprn
10915       common /kutas/ lprn
10916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10917 C                                                                              C
10918 C      Parallel       Antiparallel                                             C
10919 C                                                                              C
10920 C          o             o                                                     C
10921 C         /l\           /j\                                                    C
10922 C        /   \         /   \                                                   C
10923 C       /| o |         | o |\                                                  C
10924 C     \ j|/k\|  /   \  |/k\|l /                                                C
10925 C      \ /   \ /     \ /   \ /                                                 C
10926 C       o     o       o     o                                                  C
10927 C       i             i                                                        C
10928 C                                                                              C
10929 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10930       itk=itype2loc(itype(k))
10931       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10932       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10933       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10934       call transpose2(EUgC(1,1,k),auxmat(1,1))
10935       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10936       vv1(1)=pizda1(1,1)-pizda1(2,2)
10937       vv1(2)=pizda1(1,2)+pizda1(2,1)
10938       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10939       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10940       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10941       s5=scalar2(vv(1),Dtobr2(1,i))
10942 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10943       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10944       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10945      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10946      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10947      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10948      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10949      & +scalar2(vv(1),Dtobr2der(1,i)))
10950       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10951       vv1(1)=pizda1(1,1)-pizda1(2,2)
10952       vv1(2)=pizda1(1,2)+pizda1(2,1)
10953       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10954       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10955       if (l.eq.j+1) then
10956         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10957      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10958      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10959      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10960      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10961       else
10962         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10963      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10964      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10965      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10966      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10967       endif
10968       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10969       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10970       vv1(1)=pizda1(1,1)-pizda1(2,2)
10971       vv1(2)=pizda1(1,2)+pizda1(2,1)
10972       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10973      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10974      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10975      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10976       do iii=1,2
10977         if (swap) then
10978           ind=3-iii
10979         else
10980           ind=iii
10981         endif
10982         do kkk=1,5
10983           do lll=1,3
10984             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10985             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10986             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10987             call transpose2(EUgC(1,1,k),auxmat(1,1))
10988             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10989      &        pizda1(1,1))
10990             vv1(1)=pizda1(1,1)-pizda1(2,2)
10991             vv1(2)=pizda1(1,2)+pizda1(2,1)
10992             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10993             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10994      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10995             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10996      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10997             s5=scalar2(vv(1),Dtobr2(1,i))
10998             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10999           enddo
11000         enddo
11001       enddo
11002       return
11003       end
11004 c----------------------------------------------------------------------------
11005       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11006       implicit real*8 (a-h,o-z)
11007       include 'DIMENSIONS'
11008       include 'COMMON.IOUNITS'
11009       include 'COMMON.CHAIN'
11010       include 'COMMON.DERIV'
11011       include 'COMMON.INTERACT'
11012       include 'COMMON.CONTACTS'
11013       include 'COMMON.CONTMAT'
11014       include 'COMMON.CORRMAT'
11015       include 'COMMON.TORSION'
11016       include 'COMMON.VAR'
11017       include 'COMMON.GEO'
11018       logical swap
11019       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11020      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11021       logical lprn
11022       common /kutas/ lprn
11023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11024 C                                                                              C
11025 C      Parallel       Antiparallel                                             C
11026 C                                                                              C
11027 C          o             o                                                     C
11028 C     \   /l\           /j\   /                                                C
11029 C      \ /   \         /   \ /                                                 C
11030 C       o| o |         | o |o                                                  C
11031 C     \ j|/k\|      \  |/k\|l                                                  C
11032 C      \ /   \       \ /   \                                                   C
11033 C       o             o                                                        C
11034 C       i             i                                                        C
11035 C                                                                              C
11036 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11037 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11038 C AL 7/4/01 s1 would occur in the sixth-order moment,
11039 C           but not in a cluster cumulant
11040 #ifdef MOMENT
11041       s1=dip(1,jj,i)*dip(1,kk,k)
11042 #endif
11043       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11044       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11045       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11046       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11047       call transpose2(EUg(1,1,k),auxmat(1,1))
11048       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11049       vv(1)=pizda(1,1)-pizda(2,2)
11050       vv(2)=pizda(1,2)+pizda(2,1)
11051       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11052 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11053 #ifdef MOMENT
11054       eello6_graph2=-(s1+s2+s3+s4)
11055 #else
11056       eello6_graph2=-(s2+s3+s4)
11057 #endif
11058 c      eello6_graph2=-s3
11059 C Derivatives in gamma(i-1)
11060       if (i.gt.1) then
11061 #ifdef MOMENT
11062         s1=dipderg(1,jj,i)*dip(1,kk,k)
11063 #endif
11064         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11065         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11066         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11067         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11068 #ifdef MOMENT
11069         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11070 #else
11071         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11072 #endif
11073 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11074       endif
11075 C Derivatives in gamma(k-1)
11076 #ifdef MOMENT
11077       s1=dip(1,jj,i)*dipderg(1,kk,k)
11078 #endif
11079       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11080       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11081       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11082       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11083       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11084       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11085       vv(1)=pizda(1,1)-pizda(2,2)
11086       vv(2)=pizda(1,2)+pizda(2,1)
11087       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11088 #ifdef MOMENT
11089       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11090 #else
11091       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11092 #endif
11093 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11094 C Derivatives in gamma(j-1) or gamma(l-1)
11095       if (j.gt.1) then
11096 #ifdef MOMENT
11097         s1=dipderg(3,jj,i)*dip(1,kk,k)
11098 #endif
11099         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11100         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11101         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11102         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11103         vv(1)=pizda(1,1)-pizda(2,2)
11104         vv(2)=pizda(1,2)+pizda(2,1)
11105         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11106 #ifdef MOMENT
11107         if (swap) then
11108           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11109         else
11110           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11111         endif
11112 #endif
11113         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11114 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11115       endif
11116 C Derivatives in gamma(l-1) or gamma(j-1)
11117       if (l.gt.1) then
11118 #ifdef MOMENT
11119         s1=dip(1,jj,i)*dipderg(3,kk,k)
11120 #endif
11121         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11122         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11123         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11124         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11125         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11126         vv(1)=pizda(1,1)-pizda(2,2)
11127         vv(2)=pizda(1,2)+pizda(2,1)
11128         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11129 #ifdef MOMENT
11130         if (swap) then
11131           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11132         else
11133           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11134         endif
11135 #endif
11136         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11137 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11138       endif
11139 C Cartesian derivatives.
11140       if (lprn) then
11141         write (2,*) 'In eello6_graph2'
11142         do iii=1,2
11143           write (2,*) 'iii=',iii
11144           do kkk=1,5
11145             write (2,*) 'kkk=',kkk
11146             do jjj=1,2
11147               write (2,'(3(2f10.5),5x)')
11148      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11149             enddo
11150           enddo
11151         enddo
11152       endif
11153       do iii=1,2
11154         do kkk=1,5
11155           do lll=1,3
11156 #ifdef MOMENT
11157             if (iii.eq.1) then
11158               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11159             else
11160               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11161             endif
11162 #endif
11163             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11164      &        auxvec(1))
11165             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11166             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11167      &        auxvec(1))
11168             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11169             call transpose2(EUg(1,1,k),auxmat(1,1))
11170             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11171      &        pizda(1,1))
11172             vv(1)=pizda(1,1)-pizda(2,2)
11173             vv(2)=pizda(1,2)+pizda(2,1)
11174             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11175 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11176 #ifdef MOMENT
11177             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11178 #else
11179             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11180 #endif
11181             if (swap) then
11182               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11183             else
11184               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11185             endif
11186           enddo
11187         enddo
11188       enddo
11189       return
11190       end
11191 c----------------------------------------------------------------------------
11192       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11193       implicit real*8 (a-h,o-z)
11194       include 'DIMENSIONS'
11195       include 'COMMON.IOUNITS'
11196       include 'COMMON.CHAIN'
11197       include 'COMMON.DERIV'
11198       include 'COMMON.INTERACT'
11199       include 'COMMON.CONTACTS'
11200       include 'COMMON.CONTMAT'
11201       include 'COMMON.CORRMAT'
11202       include 'COMMON.TORSION'
11203       include 'COMMON.VAR'
11204       include 'COMMON.GEO'
11205       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11206       logical swap
11207 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11208 C                                                                              C
11209 C      Parallel       Antiparallel                                             C
11210 C                                                                              C
11211 C          o             o                                                     C
11212 C         /l\   /   \   /j\                                                    C
11213 C        /   \ /     \ /   \                                                   C
11214 C       /| o |o       o| o |\                                                  C
11215 C       j|/k\|  /      |/k\|l /                                                C
11216 C        /   \ /       /   \ /                                                 C
11217 C       /     o       /     o                                                  C
11218 C       i             i                                                        C
11219 C                                                                              C
11220 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11221 C
11222 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11223 C           energy moment and not to the cluster cumulant.
11224       iti=itortyp(itype(i))
11225       if (j.lt.nres-1) then
11226         itj1=itype2loc(itype(j+1))
11227       else
11228         itj1=nloctyp
11229       endif
11230       itk=itype2loc(itype(k))
11231       itk1=itype2loc(itype(k+1))
11232       if (l.lt.nres-1) then
11233         itl1=itype2loc(itype(l+1))
11234       else
11235         itl1=nloctyp
11236       endif
11237 #ifdef MOMENT
11238       s1=dip(4,jj,i)*dip(4,kk,k)
11239 #endif
11240       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11241       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11242       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11243       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11244       call transpose2(EE(1,1,k),auxmat(1,1))
11245       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11246       vv(1)=pizda(1,1)+pizda(2,2)
11247       vv(2)=pizda(2,1)-pizda(1,2)
11248       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11249 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11250 cd     & "sum",-(s2+s3+s4)
11251 #ifdef MOMENT
11252       eello6_graph3=-(s1+s2+s3+s4)
11253 #else
11254       eello6_graph3=-(s2+s3+s4)
11255 #endif
11256 c      eello6_graph3=-s4
11257 C Derivatives in gamma(k-1)
11258       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11259       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11260       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11261       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11262 C Derivatives in gamma(l-1)
11263       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11264       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11265       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11266       vv(1)=pizda(1,1)+pizda(2,2)
11267       vv(2)=pizda(2,1)-pizda(1,2)
11268       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11269       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11270 C Cartesian derivatives.
11271       do iii=1,2
11272         do kkk=1,5
11273           do lll=1,3
11274 #ifdef MOMENT
11275             if (iii.eq.1) then
11276               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11277             else
11278               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11279             endif
11280 #endif
11281             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11282      &        auxvec(1))
11283             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11284             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11285      &        auxvec(1))
11286             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11287             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11288      &        pizda(1,1))
11289             vv(1)=pizda(1,1)+pizda(2,2)
11290             vv(2)=pizda(2,1)-pizda(1,2)
11291             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11292 #ifdef MOMENT
11293             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11294 #else
11295             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11296 #endif
11297             if (swap) then
11298               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11299             else
11300               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11301             endif
11302 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11303           enddo
11304         enddo
11305       enddo
11306       return
11307       end
11308 c----------------------------------------------------------------------------
11309       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11310       implicit real*8 (a-h,o-z)
11311       include 'DIMENSIONS'
11312       include 'COMMON.IOUNITS'
11313       include 'COMMON.CHAIN'
11314       include 'COMMON.DERIV'
11315       include 'COMMON.INTERACT'
11316       include 'COMMON.CONTACTS'
11317       include 'COMMON.CONTMAT'
11318       include 'COMMON.CORRMAT'
11319       include 'COMMON.TORSION'
11320       include 'COMMON.VAR'
11321       include 'COMMON.GEO'
11322       include 'COMMON.FFIELD'
11323       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11324      & auxvec1(2),auxmat1(2,2)
11325       logical swap
11326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11327 C                                                                              C
11328 C      Parallel       Antiparallel                                             C
11329 C                                                                              C
11330 C          o             o                                                     C
11331 C         /l\   /   \   /j\                                                    C
11332 C        /   \ /     \ /   \                                                   C
11333 C       /| o |o       o| o |\                                                  C
11334 C     \ j|/k\|      \  |/k\|l                                                  C
11335 C      \ /   \       \ /   \                                                   C
11336 C       o     \       o     \                                                  C
11337 C       i             i                                                        C
11338 C                                                                              C
11339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11340 C
11341 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11342 C           energy moment and not to the cluster cumulant.
11343 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11344       iti=itype2loc(itype(i))
11345       itj=itype2loc(itype(j))
11346       if (j.lt.nres-1) then
11347         itj1=itype2loc(itype(j+1))
11348       else
11349         itj1=nloctyp
11350       endif
11351       itk=itype2loc(itype(k))
11352       if (k.lt.nres-1) then
11353         itk1=itype2loc(itype(k+1))
11354       else
11355         itk1=nloctyp
11356       endif
11357       itl=itype2loc(itype(l))
11358       if (l.lt.nres-1) then
11359         itl1=itype2loc(itype(l+1))
11360       else
11361         itl1=nloctyp
11362       endif
11363 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11364 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11365 cd     & ' itl',itl,' itl1',itl1
11366 #ifdef MOMENT
11367       if (imat.eq.1) then
11368         s1=dip(3,jj,i)*dip(3,kk,k)
11369       else
11370         s1=dip(2,jj,j)*dip(2,kk,l)
11371       endif
11372 #endif
11373       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11374       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11375       if (j.eq.l+1) then
11376         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11377         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11378       else
11379         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11380         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11381       endif
11382       call transpose2(EUg(1,1,k),auxmat(1,1))
11383       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11384       vv(1)=pizda(1,1)-pizda(2,2)
11385       vv(2)=pizda(2,1)+pizda(1,2)
11386       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11387 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11388 #ifdef MOMENT
11389       eello6_graph4=-(s1+s2+s3+s4)
11390 #else
11391       eello6_graph4=-(s2+s3+s4)
11392 #endif
11393 C Derivatives in gamma(i-1)
11394       if (i.gt.1) then
11395 #ifdef MOMENT
11396         if (imat.eq.1) then
11397           s1=dipderg(2,jj,i)*dip(3,kk,k)
11398         else
11399           s1=dipderg(4,jj,j)*dip(2,kk,l)
11400         endif
11401 #endif
11402         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11403         if (j.eq.l+1) then
11404           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11405           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11406         else
11407           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11408           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11409         endif
11410         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11411         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11412 cd          write (2,*) 'turn6 derivatives'
11413 #ifdef MOMENT
11414           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11415 #else
11416           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11417 #endif
11418         else
11419 #ifdef MOMENT
11420           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11421 #else
11422           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11423 #endif
11424         endif
11425       endif
11426 C Derivatives in gamma(k-1)
11427 #ifdef MOMENT
11428       if (imat.eq.1) then
11429         s1=dip(3,jj,i)*dipderg(2,kk,k)
11430       else
11431         s1=dip(2,jj,j)*dipderg(4,kk,l)
11432       endif
11433 #endif
11434       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11435       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11436       if (j.eq.l+1) then
11437         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11438         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11439       else
11440         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11441         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11442       endif
11443       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11444       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11445       vv(1)=pizda(1,1)-pizda(2,2)
11446       vv(2)=pizda(2,1)+pizda(1,2)
11447       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11448       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11449 #ifdef MOMENT
11450         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11451 #else
11452         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11453 #endif
11454       else
11455 #ifdef MOMENT
11456         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11457 #else
11458         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11459 #endif
11460       endif
11461 C Derivatives in gamma(j-1) or gamma(l-1)
11462       if (l.eq.j+1 .and. l.gt.1) then
11463         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11464         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11465         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11466         vv(1)=pizda(1,1)-pizda(2,2)
11467         vv(2)=pizda(2,1)+pizda(1,2)
11468         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11469         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11470       else if (j.gt.1) then
11471         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11472         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11473         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11474         vv(1)=pizda(1,1)-pizda(2,2)
11475         vv(2)=pizda(2,1)+pizda(1,2)
11476         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11477         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11478           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11479         else
11480           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11481         endif
11482       endif
11483 C Cartesian derivatives.
11484       do iii=1,2
11485         do kkk=1,5
11486           do lll=1,3
11487 #ifdef MOMENT
11488             if (iii.eq.1) then
11489               if (imat.eq.1) then
11490                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11491               else
11492                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11493               endif
11494             else
11495               if (imat.eq.1) then
11496                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11497               else
11498                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11499               endif
11500             endif
11501 #endif
11502             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11503      &        auxvec(1))
11504             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11505             if (j.eq.l+1) then
11506               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11507      &          b1(1,j+1),auxvec(1))
11508               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11509             else
11510               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11511      &          b1(1,l+1),auxvec(1))
11512               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11513             endif
11514             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11515      &        pizda(1,1))
11516             vv(1)=pizda(1,1)-pizda(2,2)
11517             vv(2)=pizda(2,1)+pizda(1,2)
11518             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11519             if (swap) then
11520               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11521 #ifdef MOMENT
11522                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11523      &             -(s1+s2+s4)
11524 #else
11525                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11526      &             -(s2+s4)
11527 #endif
11528                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11529               else
11530 #ifdef MOMENT
11531                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11532 #else
11533                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11534 #endif
11535                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11536               endif
11537             else
11538 #ifdef MOMENT
11539               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11540 #else
11541               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11542 #endif
11543               if (l.eq.j+1) then
11544                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11545               else
11546                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11547               endif
11548             endif
11549           enddo
11550         enddo
11551       enddo
11552       return
11553       end
11554 c----------------------------------------------------------------------------
11555       double precision function eello_turn6(i,jj,kk)
11556       implicit real*8 (a-h,o-z)
11557       include 'DIMENSIONS'
11558       include 'COMMON.IOUNITS'
11559       include 'COMMON.CHAIN'
11560       include 'COMMON.DERIV'
11561       include 'COMMON.INTERACT'
11562       include 'COMMON.CONTACTS'
11563       include 'COMMON.CONTMAT'
11564       include 'COMMON.CORRMAT'
11565       include 'COMMON.TORSION'
11566       include 'COMMON.VAR'
11567       include 'COMMON.GEO'
11568       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11569      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11570      &  ggg1(3),ggg2(3)
11571       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11572      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11573 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11574 C           the respective energy moment and not to the cluster cumulant.
11575       s1=0.0d0
11576       s8=0.0d0
11577       s13=0.0d0
11578 c
11579       eello_turn6=0.0d0
11580       j=i+4
11581       k=i+1
11582       l=i+3
11583       iti=itype2loc(itype(i))
11584       itk=itype2loc(itype(k))
11585       itk1=itype2loc(itype(k+1))
11586       itl=itype2loc(itype(l))
11587       itj=itype2loc(itype(j))
11588 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11589 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11590 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11591 cd        eello6=0.0d0
11592 cd        return
11593 cd      endif
11594 cd      write (iout,*)
11595 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11596 cd     &   ' and',k,l
11597 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11598       do iii=1,2
11599         do kkk=1,5
11600           do lll=1,3
11601             derx_turn(lll,kkk,iii)=0.0d0
11602           enddo
11603         enddo
11604       enddo
11605 cd      eij=1.0d0
11606 cd      ekl=1.0d0
11607 cd      ekont=1.0d0
11608       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11609 cd      eello6_5=0.0d0
11610 cd      write (2,*) 'eello6_5',eello6_5
11611 #ifdef MOMENT
11612       call transpose2(AEA(1,1,1),auxmat(1,1))
11613       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11614       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11615       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11616 #endif
11617       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11618       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11619       s2 = scalar2(b1(1,k),vtemp1(1))
11620 #ifdef MOMENT
11621       call transpose2(AEA(1,1,2),atemp(1,1))
11622       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11623       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11624       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11625 #endif
11626       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11627       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11628       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11629 #ifdef MOMENT
11630       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11631       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11632       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11633       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11634       ss13 = scalar2(b1(1,k),vtemp4(1))
11635       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11636 #endif
11637 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11638 c      s1=0.0d0
11639 c      s2=0.0d0
11640 c      s8=0.0d0
11641 c      s12=0.0d0
11642 c      s13=0.0d0
11643       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11644 C Derivatives in gamma(i+2)
11645       s1d =0.0d0
11646       s8d =0.0d0
11647 #ifdef MOMENT
11648       call transpose2(AEA(1,1,1),auxmatd(1,1))
11649       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11650       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11651       call transpose2(AEAderg(1,1,2),atempd(1,1))
11652       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11653       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11654 #endif
11655       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11656       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11657       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11658 c      s1d=0.0d0
11659 c      s2d=0.0d0
11660 c      s8d=0.0d0
11661 c      s12d=0.0d0
11662 c      s13d=0.0d0
11663       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11664 C Derivatives in gamma(i+3)
11665 #ifdef MOMENT
11666       call transpose2(AEA(1,1,1),auxmatd(1,1))
11667       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11668       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11669       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11670 #endif
11671       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11672       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11673       s2d = scalar2(b1(1,k),vtemp1d(1))
11674 #ifdef MOMENT
11675       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11676       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11677 #endif
11678       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11679 #ifdef MOMENT
11680       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11681       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11682       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11683 #endif
11684 c      s1d=0.0d0
11685 c      s2d=0.0d0
11686 c      s8d=0.0d0
11687 c      s12d=0.0d0
11688 c      s13d=0.0d0
11689 #ifdef MOMENT
11690       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11691      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11692 #else
11693       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11694      &               -0.5d0*ekont*(s2d+s12d)
11695 #endif
11696 C Derivatives in gamma(i+4)
11697       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11698       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11699       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11700 #ifdef MOMENT
11701       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11702       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11703       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11704 #endif
11705 c      s1d=0.0d0
11706 c      s2d=0.0d0
11707 c      s8d=0.0d0
11708 C      s12d=0.0d0
11709 c      s13d=0.0d0
11710 #ifdef MOMENT
11711       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11712 #else
11713       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11714 #endif
11715 C Derivatives in gamma(i+5)
11716 #ifdef MOMENT
11717       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11718       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11719       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11720 #endif
11721       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11722       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11723       s2d = scalar2(b1(1,k),vtemp1d(1))
11724 #ifdef MOMENT
11725       call transpose2(AEA(1,1,2),atempd(1,1))
11726       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11727       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11728 #endif
11729       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11730       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11731 #ifdef MOMENT
11732       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11733       ss13d = scalar2(b1(1,k),vtemp4d(1))
11734       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11735 #endif
11736 c      s1d=0.0d0
11737 c      s2d=0.0d0
11738 c      s8d=0.0d0
11739 c      s12d=0.0d0
11740 c      s13d=0.0d0
11741 #ifdef MOMENT
11742       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11743      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11744 #else
11745       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11746      &               -0.5d0*ekont*(s2d+s12d)
11747 #endif
11748 C Cartesian derivatives
11749       do iii=1,2
11750         do kkk=1,5
11751           do lll=1,3
11752 #ifdef MOMENT
11753             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11754             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11755             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11756 #endif
11757             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11758             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11759      &          vtemp1d(1))
11760             s2d = scalar2(b1(1,k),vtemp1d(1))
11761 #ifdef MOMENT
11762             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11763             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11764             s8d = -(atempd(1,1)+atempd(2,2))*
11765      &           scalar2(cc(1,1,l),vtemp2(1))
11766 #endif
11767             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11768      &           auxmatd(1,1))
11769             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11770             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11771 c      s1d=0.0d0
11772 c      s2d=0.0d0
11773 c      s8d=0.0d0
11774 c      s12d=0.0d0
11775 c      s13d=0.0d0
11776 #ifdef MOMENT
11777             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11778      &        - 0.5d0*(s1d+s2d)
11779 #else
11780             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11781      &        - 0.5d0*s2d
11782 #endif
11783 #ifdef MOMENT
11784             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11785      &        - 0.5d0*(s8d+s12d)
11786 #else
11787             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11788      &        - 0.5d0*s12d
11789 #endif
11790           enddo
11791         enddo
11792       enddo
11793 #ifdef MOMENT
11794       do kkk=1,5
11795         do lll=1,3
11796           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11797      &      achuj_tempd(1,1))
11798           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11799           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11800           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11801           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11802           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11803      &      vtemp4d(1))
11804           ss13d = scalar2(b1(1,k),vtemp4d(1))
11805           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11806           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11807         enddo
11808       enddo
11809 #endif
11810 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11811 cd     &  16*eel_turn6_num
11812 cd      goto 1112
11813       if (j.lt.nres-1) then
11814         j1=j+1
11815         j2=j-1
11816       else
11817         j1=j-1
11818         j2=j-2
11819       endif
11820       if (l.lt.nres-1) then
11821         l1=l+1
11822         l2=l-1
11823       else
11824         l1=l-1
11825         l2=l-2
11826       endif
11827       do ll=1,3
11828 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11829 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11830 cgrad        ghalf=0.5d0*ggg1(ll)
11831 cd        ghalf=0.0d0
11832         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11833         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11834         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11835      &    +ekont*derx_turn(ll,2,1)
11836         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11837         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11838      &    +ekont*derx_turn(ll,4,1)
11839         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11840         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11841         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11842 cgrad        ghalf=0.5d0*ggg2(ll)
11843 cd        ghalf=0.0d0
11844         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11845      &    +ekont*derx_turn(ll,2,2)
11846         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11847         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11848      &    +ekont*derx_turn(ll,4,2)
11849         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11850         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11851         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11852       enddo
11853 cd      goto 1112
11854 cgrad      do m=i+1,j-1
11855 cgrad        do ll=1,3
11856 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11857 cgrad        enddo
11858 cgrad      enddo
11859 cgrad      do m=k+1,l-1
11860 cgrad        do ll=1,3
11861 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11862 cgrad        enddo
11863 cgrad      enddo
11864 cgrad1112  continue
11865 cgrad      do m=i+2,j2
11866 cgrad        do ll=1,3
11867 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11868 cgrad        enddo
11869 cgrad      enddo
11870 cgrad      do m=k+2,l2
11871 cgrad        do ll=1,3
11872 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11873 cgrad        enddo
11874 cgrad      enddo
11875 cd      do iii=1,nres-3
11876 cd        write (2,*) iii,g_corr6_loc(iii)
11877 cd      enddo
11878       eello_turn6=ekont*eel_turn6
11879 cd      write (2,*) 'ekont',ekont
11880 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11881       return
11882       end
11883 C-----------------------------------------------------------------------------
11884 #endif
11885       double precision function scalar(u,v)
11886 !DIR$ INLINEALWAYS scalar
11887 #ifndef OSF
11888 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11889 #endif
11890       implicit none
11891       double precision u(3),v(3)
11892 cd      double precision sc
11893 cd      integer i
11894 cd      sc=0.0d0
11895 cd      do i=1,3
11896 cd        sc=sc+u(i)*v(i)
11897 cd      enddo
11898 cd      scalar=sc
11899
11900       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11901       return
11902       end
11903 crc-------------------------------------------------
11904       SUBROUTINE MATVEC2(A1,V1,V2)
11905 !DIR$ INLINEALWAYS MATVEC2
11906 #ifndef OSF
11907 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11908 #endif
11909       implicit real*8 (a-h,o-z)
11910       include 'DIMENSIONS'
11911       DIMENSION A1(2,2),V1(2),V2(2)
11912 c      DO 1 I=1,2
11913 c        VI=0.0
11914 c        DO 3 K=1,2
11915 c    3     VI=VI+A1(I,K)*V1(K)
11916 c        Vaux(I)=VI
11917 c    1 CONTINUE
11918
11919       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11920       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11921
11922       v2(1)=vaux1
11923       v2(2)=vaux2
11924       END
11925 C---------------------------------------
11926       SUBROUTINE MATMAT2(A1,A2,A3)
11927 #ifndef OSF
11928 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11929 #endif
11930       implicit real*8 (a-h,o-z)
11931       include 'DIMENSIONS'
11932       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11933 c      DIMENSION AI3(2,2)
11934 c        DO  J=1,2
11935 c          A3IJ=0.0
11936 c          DO K=1,2
11937 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11938 c          enddo
11939 c          A3(I,J)=A3IJ
11940 c       enddo
11941 c      enddo
11942
11943       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11944       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11945       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11946       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11947
11948       A3(1,1)=AI3_11
11949       A3(2,1)=AI3_21
11950       A3(1,2)=AI3_12
11951       A3(2,2)=AI3_22
11952       END
11953
11954 c-------------------------------------------------------------------------
11955       double precision function scalar2(u,v)
11956 !DIR$ INLINEALWAYS scalar2
11957       implicit none
11958       double precision u(2),v(2)
11959       double precision sc
11960       integer i
11961       scalar2=u(1)*v(1)+u(2)*v(2)
11962       return
11963       end
11964
11965 C-----------------------------------------------------------------------------
11966
11967       subroutine transpose2(a,at)
11968 !DIR$ INLINEALWAYS transpose2
11969 #ifndef OSF
11970 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11971 #endif
11972       implicit none
11973       double precision a(2,2),at(2,2)
11974       at(1,1)=a(1,1)
11975       at(1,2)=a(2,1)
11976       at(2,1)=a(1,2)
11977       at(2,2)=a(2,2)
11978       return
11979       end
11980 c--------------------------------------------------------------------------
11981       subroutine transpose(n,a,at)
11982       implicit none
11983       integer n,i,j
11984       double precision a(n,n),at(n,n)
11985       do i=1,n
11986         do j=1,n
11987           at(j,i)=a(i,j)
11988         enddo
11989       enddo
11990       return
11991       end
11992 C---------------------------------------------------------------------------
11993       subroutine prodmat3(a1,a2,kk,transp,prod)
11994 !DIR$ INLINEALWAYS prodmat3
11995 #ifndef OSF
11996 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11997 #endif
11998       implicit none
11999       integer i,j
12000       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12001       logical transp
12002 crc      double precision auxmat(2,2),prod_(2,2)
12003
12004       if (transp) then
12005 crc        call transpose2(kk(1,1),auxmat(1,1))
12006 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12007 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12008
12009            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12010      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12011            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12012      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12013            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12014      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12015            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12016      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12017
12018       else
12019 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12020 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12021
12022            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12023      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12024            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12025      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12026            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12027      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12028            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12029      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12030
12031       endif
12032 c      call transpose2(a2(1,1),a2t(1,1))
12033
12034 crc      print *,transp
12035 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12036 crc      print *,((prod(i,j),i=1,2),j=1,2)
12037
12038       return
12039       end
12040 CCC----------------------------------------------
12041       subroutine Eliptransfer(eliptran)
12042       implicit real*8 (a-h,o-z)
12043       include 'DIMENSIONS'
12044       include 'COMMON.GEO'
12045       include 'COMMON.VAR'
12046       include 'COMMON.LOCAL'
12047       include 'COMMON.CHAIN'
12048       include 'COMMON.DERIV'
12049       include 'COMMON.NAMES'
12050       include 'COMMON.INTERACT'
12051       include 'COMMON.IOUNITS'
12052       include 'COMMON.CALC'
12053       include 'COMMON.CONTROL'
12054       include 'COMMON.SPLITELE'
12055       include 'COMMON.SBRIDGE'
12056 C this is done by Adasko
12057 C      print *,"wchodze"
12058 C structure of box:
12059 C      water
12060 C--bordliptop-- buffore starts
12061 C--bufliptop--- here true lipid starts
12062 C      lipid
12063 C--buflipbot--- lipid ends buffore starts
12064 C--bordlipbot--buffore ends
12065 c      call cartprint
12066       eliptran=0.0
12067       do i=ilip_start,ilip_end
12068 C       do i=1,1
12069         if (itype(i).eq.ntyp1) cycle
12070
12071         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12072         if (positi.le.0.0) positi=positi+boxzsize
12073 C        print *,i
12074 C first for peptide groups
12075 c for each residue check if it is in lipid or lipid water border area
12076        if ((positi.gt.bordlipbot)
12077      &.and.(positi.lt.bordliptop)) then
12078 C the energy transfer exist
12079         if (positi.lt.buflipbot) then
12080 C what fraction I am in
12081          fracinbuf=1.0d0-
12082      &        ((positi-bordlipbot)/lipbufthick)
12083 C lipbufthick is thickenes of lipid buffore
12084          sslip=sscalelip(fracinbuf)
12085          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12086          eliptran=eliptran+sslip*pepliptran
12087          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12088          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12089 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12090
12091 C        print *,"doing sccale for lower part"
12092 C         print *,i,sslip,fracinbuf,ssgradlip
12093         elseif (positi.gt.bufliptop) then
12094          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12095          sslip=sscalelip(fracinbuf)
12096          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12097          eliptran=eliptran+sslip*pepliptran
12098          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12099          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12100 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12101 C          print *, "doing sscalefor top part"
12102 C         print *,i,sslip,fracinbuf,ssgradlip
12103         else
12104          eliptran=eliptran+pepliptran
12105 C         print *,"I am in true lipid"
12106         endif
12107 C       else
12108 C       eliptran=elpitran+0.0 ! I am in water
12109        endif
12110        enddo
12111 C       print *, "nic nie bylo w lipidzie?"
12112 C now multiply all by the peptide group transfer factor
12113 C       eliptran=eliptran*pepliptran
12114 C now the same for side chains
12115 CV       do i=1,1
12116        do i=ilip_start,ilip_end
12117         if (itype(i).eq.ntyp1) cycle
12118         positi=(mod(c(3,i+nres),boxzsize))
12119         if (positi.le.0) positi=positi+boxzsize
12120 c        write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
12121 c     &   bordliptop
12122 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12123 c for each residue check if it is in lipid or lipid water border area
12124 C       respos=mod(c(3,i+nres),boxzsize)
12125 C       print *,positi,bordlipbot,buflipbot
12126        if ((positi.gt.bordlipbot)
12127      & .and.(positi.lt.bordliptop)) then
12128 C the energy transfer exist
12129         if (positi.lt.buflipbot) then
12130          fracinbuf=1.0d0-
12131      &     ((positi-bordlipbot)/lipbufthick)
12132 c         write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
12133 c         write (iout,*) "i",i," liptranene",liptranene(itype(i))
12134 C lipbufthick is thickenes of lipid buffore
12135          sslip=sscalelip(fracinbuf)
12136          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12137          eliptran=eliptran+sslip*liptranene(itype(i))
12138          gliptranx(3,i)=gliptranx(3,i)
12139      &+ssgradlip*liptranene(itype(i))
12140          gliptranc(3,i-1)= gliptranc(3,i-1)
12141      &+ssgradlip*liptranene(itype(i))
12142 C         print *,"doing sccale for lower part"
12143         elseif (positi.gt.bufliptop) then
12144          fracinbuf=1.0d0-
12145      &((bordliptop-positi)/lipbufthick)
12146          sslip=sscalelip(fracinbuf)
12147          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12148          eliptran=eliptran+sslip*liptranene(itype(i))
12149          gliptranx(3,i)=gliptranx(3,i)
12150      &+ssgradlip*liptranene(itype(i))
12151          gliptranc(3,i-1)= gliptranc(3,i-1)
12152      &+ssgradlip*liptranene(itype(i))
12153 C          print *, "doing sscalefor top part",sslip,fracinbuf
12154         else
12155          eliptran=eliptran+liptranene(itype(i))
12156 C         print *,"I am in true lipid"
12157         endif
12158         endif ! if in lipid or buffor
12159 C       else
12160 C       eliptran=elpitran+0.0 ! I am in water
12161        enddo
12162        return
12163        end
12164 C---------------------------------------------------------
12165 C AFM soubroutine for constant force
12166        subroutine AFMforce(Eafmforce)
12167        implicit real*8 (a-h,o-z)
12168       include 'DIMENSIONS'
12169       include 'COMMON.GEO'
12170       include 'COMMON.VAR'
12171       include 'COMMON.LOCAL'
12172       include 'COMMON.CHAIN'
12173       include 'COMMON.DERIV'
12174       include 'COMMON.NAMES'
12175       include 'COMMON.INTERACT'
12176       include 'COMMON.IOUNITS'
12177       include 'COMMON.CALC'
12178       include 'COMMON.CONTROL'
12179       include 'COMMON.SPLITELE'
12180       include 'COMMON.SBRIDGE'
12181       real*8 diffafm(3)
12182       dist=0.0d0
12183       Eafmforce=0.0d0
12184       do i=1,3
12185       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12186       dist=dist+diffafm(i)**2
12187       enddo
12188       dist=dsqrt(dist)
12189       Eafmforce=-forceAFMconst*(dist-distafminit)
12190       do i=1,3
12191       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12192       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12193       enddo
12194 C      print *,'AFM',Eafmforce
12195       return
12196       end
12197 C---------------------------------------------------------
12198 C AFM subroutine with pseudoconstant velocity
12199        subroutine AFMvel(Eafmforce)
12200        implicit real*8 (a-h,o-z)
12201       include 'DIMENSIONS'
12202       include 'COMMON.GEO'
12203       include 'COMMON.VAR'
12204       include 'COMMON.LOCAL'
12205       include 'COMMON.CHAIN'
12206       include 'COMMON.DERIV'
12207       include 'COMMON.NAMES'
12208       include 'COMMON.INTERACT'
12209       include 'COMMON.IOUNITS'
12210       include 'COMMON.CALC'
12211       include 'COMMON.CONTROL'
12212       include 'COMMON.SPLITELE'
12213       include 'COMMON.SBRIDGE'
12214       real*8 diffafm(3)
12215 C Only for check grad COMMENT if not used for checkgrad
12216 C      totT=3.0d0
12217 C--------------------------------------------------------
12218 C      print *,"wchodze"
12219       dist=0.0d0
12220       Eafmforce=0.0d0
12221       do i=1,3
12222       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12223       dist=dist+diffafm(i)**2
12224       enddo
12225       dist=dsqrt(dist)
12226       Eafmforce=0.5d0*forceAFMconst
12227      & *(distafminit+totTafm*velAFMconst-dist)**2
12228 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12229       do i=1,3
12230       gradafm(i,afmend-1)=-forceAFMconst*
12231      &(distafminit+totTafm*velAFMconst-dist)
12232      &*diffafm(i)/dist
12233       gradafm(i,afmbeg-1)=forceAFMconst*
12234      &(distafminit+totTafm*velAFMconst-dist)
12235      &*diffafm(i)/dist
12236       enddo
12237 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12238       return
12239       end
12240 C-----------------------------------------------------------
12241 C first for shielding is setting of function of side-chains
12242        subroutine set_shield_fac
12243       implicit real*8 (a-h,o-z)
12244       include 'DIMENSIONS'
12245       include 'COMMON.CHAIN'
12246       include 'COMMON.DERIV'
12247       include 'COMMON.IOUNITS'
12248       include 'COMMON.SHIELD'
12249       include 'COMMON.INTERACT'
12250 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12251       double precision div77_81/0.974996043d0/,
12252      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12253
12254 C the vector between center of side_chain and peptide group
12255        double precision pep_side(3),long,side_calf(3),
12256      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12257      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12258 C the line belowe needs to be changed for FGPROC>1
12259       do i=1,nres-1
12260       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12261       ishield_list(i)=0
12262 Cif there two consequtive dummy atoms there is no peptide group between them
12263 C the line below has to be changed for FGPROC>1
12264       VolumeTotal=0.0
12265       do k=1,nres
12266        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12267        dist_pep_side=0.0
12268        dist_side_calf=0.0
12269        do j=1,3
12270 C first lets set vector conecting the ithe side-chain with kth side-chain
12271       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12272 C      pep_side(j)=2.0d0
12273 C and vector conecting the side-chain with its proper calfa
12274       side_calf(j)=c(j,k+nres)-c(j,k)
12275 C      side_calf(j)=2.0d0
12276       pept_group(j)=c(j,i)-c(j,i+1)
12277 C lets have their lenght
12278       dist_pep_side=pep_side(j)**2+dist_pep_side
12279       dist_side_calf=dist_side_calf+side_calf(j)**2
12280       dist_pept_group=dist_pept_group+pept_group(j)**2
12281       enddo
12282        dist_pep_side=dsqrt(dist_pep_side)
12283        dist_pept_group=dsqrt(dist_pept_group)
12284        dist_side_calf=dsqrt(dist_side_calf)
12285       do j=1,3
12286         pep_side_norm(j)=pep_side(j)/dist_pep_side
12287         side_calf_norm(j)=dist_side_calf
12288       enddo
12289 C now sscale fraction
12290        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12291 C       print *,buff_shield,"buff"
12292 C now sscale
12293         if (sh_frac_dist.le.0.0) cycle
12294 C If we reach here it means that this side chain reaches the shielding sphere
12295 C Lets add him to the list for gradient
12296         ishield_list(i)=ishield_list(i)+1
12297 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12298 C this list is essential otherwise problem would be O3
12299         shield_list(ishield_list(i),i)=k
12300 C Lets have the sscale value
12301         if (sh_frac_dist.gt.1.0) then
12302          scale_fac_dist=1.0d0
12303          do j=1,3
12304          sh_frac_dist_grad(j)=0.0d0
12305          enddo
12306         else
12307          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12308      &                   *(2.0*sh_frac_dist-3.0d0)
12309          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12310      &                  /dist_pep_side/buff_shield*0.5
12311 C remember for the final gradient multiply sh_frac_dist_grad(j)
12312 C for side_chain by factor -2 !
12313          do j=1,3
12314          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12315 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12316 C     &                    sh_frac_dist_grad(j)
12317          enddo
12318         endif
12319 C        if ((i.eq.3).and.(k.eq.2)) then
12320 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12321 C     & ,"TU"
12322 C        endif
12323
12324 C this is what is now we have the distance scaling now volume...
12325       short=short_r_sidechain(itype(k))
12326       long=long_r_sidechain(itype(k))
12327       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12328 C now costhet_grad
12329 C       costhet=0.0d0
12330        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12331 C       costhet_fac=0.0d0
12332        do j=1,3
12333          costhet_grad(j)=costhet_fac*pep_side(j)
12334        enddo
12335 C remember for the final gradient multiply costhet_grad(j)
12336 C for side_chain by factor -2 !
12337 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12338 C pep_side0pept_group is vector multiplication
12339       pep_side0pept_group=0.0
12340       do j=1,3
12341       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12342       enddo
12343       cosalfa=(pep_side0pept_group/
12344      & (dist_pep_side*dist_side_calf))
12345       fac_alfa_sin=1.0-cosalfa**2
12346       fac_alfa_sin=dsqrt(fac_alfa_sin)
12347       rkprim=fac_alfa_sin*(long-short)+short
12348 C now costhet_grad
12349        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12350        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12351
12352        do j=1,3
12353          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12354      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12355      &*(long-short)/fac_alfa_sin*cosalfa/
12356      &((dist_pep_side*dist_side_calf))*
12357      &((side_calf(j))-cosalfa*
12358      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12359
12360         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12361      &*(long-short)/fac_alfa_sin*cosalfa
12362      &/((dist_pep_side*dist_side_calf))*
12363      &(pep_side(j)-
12364      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12365        enddo
12366
12367       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12368      &                    /VSolvSphere_div
12369      &                    *wshield
12370 C now the gradient...
12371 C grad_shield is gradient of Calfa for peptide groups
12372 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12373 C     &               costhet,cosphi
12374 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12375 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12376       do j=1,3
12377       grad_shield(j,i)=grad_shield(j,i)
12378 C gradient po skalowaniu
12379      &                +(sh_frac_dist_grad(j)
12380 C  gradient po costhet
12381      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12382      &-scale_fac_dist*(cosphi_grad_long(j))
12383      &/(1.0-cosphi) )*div77_81
12384      &*VofOverlap
12385 C grad_shield_side is Cbeta sidechain gradient
12386       grad_shield_side(j,ishield_list(i),i)=
12387      &        (sh_frac_dist_grad(j)*(-2.0d0)
12388      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12389      &       +scale_fac_dist*(cosphi_grad_long(j))
12390      &        *2.0d0/(1.0-cosphi))
12391      &        *div77_81*VofOverlap
12392
12393        grad_shield_loc(j,ishield_list(i),i)=
12394      &   scale_fac_dist*cosphi_grad_loc(j)
12395      &        *2.0d0/(1.0-cosphi)
12396      &        *div77_81*VofOverlap
12397       enddo
12398       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12399       enddo
12400       fac_shield(i)=VolumeTotal*div77_81+div4_81
12401 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12402       enddo
12403       return
12404       end
12405 C--------------------------------------------------------------------------
12406       double precision function tschebyshev(m,n,x,y)
12407       implicit none
12408       include "DIMENSIONS"
12409       integer i,m,n
12410       double precision x(n),y,yy(0:maxvar),aux
12411 c Tschebyshev polynomial. Note that the first term is omitted
12412 c m=0: the constant term is included
12413 c m=1: the constant term is not included
12414       yy(0)=1.0d0
12415       yy(1)=y
12416       do i=2,n
12417         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12418       enddo
12419       aux=0.0d0
12420       do i=m,n
12421         aux=aux+x(i)*yy(i)
12422       enddo
12423       tschebyshev=aux
12424       return
12425       end
12426 C--------------------------------------------------------------------------
12427       double precision function gradtschebyshev(m,n,x,y)
12428       implicit none
12429       include "DIMENSIONS"
12430       integer i,m,n
12431       double precision x(n+1),y,yy(0:maxvar),aux
12432 c Tschebyshev polynomial. Note that the first term is omitted
12433 c m=0: the constant term is included
12434 c m=1: the constant term is not included
12435       yy(0)=1.0d0
12436       yy(1)=2.0d0*y
12437       do i=2,n
12438         yy(i)=2*y*yy(i-1)-yy(i-2)
12439       enddo
12440       aux=0.0d0
12441       do i=m,n
12442         aux=aux+x(i+1)*yy(i)*(i+1)
12443 C        print *, x(i+1),yy(i),i
12444       enddo
12445       gradtschebyshev=aux
12446       return
12447       end
12448 C------------------------------------------------------------------------
12449 C first for shielding is setting of function of side-chains
12450        subroutine set_shield_fac2
12451       implicit real*8 (a-h,o-z)
12452       include 'DIMENSIONS'
12453       include 'COMMON.CHAIN'
12454       include 'COMMON.DERIV'
12455       include 'COMMON.IOUNITS'
12456       include 'COMMON.SHIELD'
12457       include 'COMMON.INTERACT'
12458 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12459       double precision div77_81/0.974996043d0/,
12460      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12461
12462 C the vector between center of side_chain and peptide group
12463        double precision pep_side(3),long,side_calf(3),
12464      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12465      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12466 C the line belowe needs to be changed for FGPROC>1
12467       do i=1,nres-1
12468       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12469       ishield_list(i)=0
12470 Cif there two consequtive dummy atoms there is no peptide group between them
12471 C the line below has to be changed for FGPROC>1
12472       VolumeTotal=0.0
12473       do k=1,nres
12474        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12475        dist_pep_side=0.0
12476        dist_side_calf=0.0
12477        do j=1,3
12478 C first lets set vector conecting the ithe side-chain with kth side-chain
12479       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12480 C      pep_side(j)=2.0d0
12481 C and vector conecting the side-chain with its proper calfa
12482       side_calf(j)=c(j,k+nres)-c(j,k)
12483 C      side_calf(j)=2.0d0
12484       pept_group(j)=c(j,i)-c(j,i+1)
12485 C lets have their lenght
12486       dist_pep_side=pep_side(j)**2+dist_pep_side
12487       dist_side_calf=dist_side_calf+side_calf(j)**2
12488       dist_pept_group=dist_pept_group+pept_group(j)**2
12489       enddo
12490        dist_pep_side=dsqrt(dist_pep_side)
12491        dist_pept_group=dsqrt(dist_pept_group)
12492        dist_side_calf=dsqrt(dist_side_calf)
12493       do j=1,3
12494         pep_side_norm(j)=pep_side(j)/dist_pep_side
12495         side_calf_norm(j)=dist_side_calf
12496       enddo
12497 C now sscale fraction
12498        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12499 C       print *,buff_shield,"buff"
12500 C now sscale
12501         if (sh_frac_dist.le.0.0) cycle
12502 C If we reach here it means that this side chain reaches the shielding sphere
12503 C Lets add him to the list for gradient
12504         ishield_list(i)=ishield_list(i)+1
12505 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12506 C this list is essential otherwise problem would be O3
12507         shield_list(ishield_list(i),i)=k
12508 C Lets have the sscale value
12509         if (sh_frac_dist.gt.1.0) then
12510          scale_fac_dist=1.0d0
12511          do j=1,3
12512          sh_frac_dist_grad(j)=0.0d0
12513          enddo
12514         else
12515          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12516      &                   *(2.0d0*sh_frac_dist-3.0d0)
12517          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12518      &                  /dist_pep_side/buff_shield*0.5d0
12519 C remember for the final gradient multiply sh_frac_dist_grad(j)
12520 C for side_chain by factor -2 !
12521          do j=1,3
12522          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12523 C         sh_frac_dist_grad(j)=0.0d0
12524 C         scale_fac_dist=1.0d0
12525 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12526 C     &                    sh_frac_dist_grad(j)
12527          enddo
12528         endif
12529 C this is what is now we have the distance scaling now volume...
12530       short=short_r_sidechain(itype(k))
12531       long=long_r_sidechain(itype(k))
12532       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12533       sinthet=short/dist_pep_side*costhet
12534 C now costhet_grad
12535 C       costhet=0.6d0
12536 C       sinthet=0.8
12537        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12538 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12539 C     &             -short/dist_pep_side**2/costhet)
12540 C       costhet_fac=0.0d0
12541        do j=1,3
12542          costhet_grad(j)=costhet_fac*pep_side(j)
12543        enddo
12544 C remember for the final gradient multiply costhet_grad(j)
12545 C for side_chain by factor -2 !
12546 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12547 C pep_side0pept_group is vector multiplication
12548       pep_side0pept_group=0.0d0
12549       do j=1,3
12550       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12551       enddo
12552       cosalfa=(pep_side0pept_group/
12553      & (dist_pep_side*dist_side_calf))
12554       fac_alfa_sin=1.0d0-cosalfa**2
12555       fac_alfa_sin=dsqrt(fac_alfa_sin)
12556       rkprim=fac_alfa_sin*(long-short)+short
12557 C      rkprim=short
12558
12559 C now costhet_grad
12560        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12561 C       cosphi=0.6
12562        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12563        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12564      &      dist_pep_side**2)
12565 C       sinphi=0.8
12566        do j=1,3
12567          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12568      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12569      &*(long-short)/fac_alfa_sin*cosalfa/
12570      &((dist_pep_side*dist_side_calf))*
12571      &((side_calf(j))-cosalfa*
12572      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12573 C       cosphi_grad_long(j)=0.0d0
12574         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12575      &*(long-short)/fac_alfa_sin*cosalfa
12576      &/((dist_pep_side*dist_side_calf))*
12577      &(pep_side(j)-
12578      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12579 C       cosphi_grad_loc(j)=0.0d0
12580        enddo
12581 C      print *,sinphi,sinthet
12582 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12583 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12584       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12585      &                    /VSolvSphere_div
12586 C     &                    *wshield
12587 C now the gradient...
12588       do j=1,3
12589       grad_shield(j,i)=grad_shield(j,i)
12590 C gradient po skalowaniu
12591      &                +(sh_frac_dist_grad(j)*VofOverlap
12592 C  gradient po costhet
12593      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12594      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12595      &       sinphi/sinthet*costhet*costhet_grad(j)
12596      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12597      & )*wshield
12598 C grad_shield_side is Cbeta sidechain gradient
12599       grad_shield_side(j,ishield_list(i),i)=
12600      &        (sh_frac_dist_grad(j)*(-2.0d0)
12601      &        *VofOverlap
12602      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12603      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12604      &       sinphi/sinthet*costhet*costhet_grad(j)
12605      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12606      &       )*wshield
12607
12608        grad_shield_loc(j,ishield_list(i),i)=
12609      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12610      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12611      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12612      &        ))
12613      &        *wshield
12614       enddo
12615 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12616 c     & scale_fac_dist
12617       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12618       enddo
12619       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12620 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12621 c     &  " wshield",wshield
12622 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12623       enddo
12624       return
12625       end
12626 C-----------------------------------------------------------------------
12627 C-----------------------------------------------------------
12628 C This subroutine is to mimic the histone like structure but as well can be
12629 C utilizet to nanostructures (infinit) small modification has to be used to
12630 C make it finite (z gradient at the ends has to be changes as well as the x,y
12631 C gradient has to be modified at the ends
12632 C The energy function is Kihara potential
12633 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12634 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12635 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12636 C simple Kihara potential
12637       subroutine calctube(Etube)
12638        implicit real*8 (a-h,o-z)
12639       include 'DIMENSIONS'
12640       include 'COMMON.GEO'
12641       include 'COMMON.VAR'
12642       include 'COMMON.LOCAL'
12643       include 'COMMON.CHAIN'
12644       include 'COMMON.DERIV'
12645       include 'COMMON.NAMES'
12646       include 'COMMON.INTERACT'
12647       include 'COMMON.IOUNITS'
12648       include 'COMMON.CALC'
12649       include 'COMMON.CONTROL'
12650       include 'COMMON.SPLITELE'
12651       include 'COMMON.SBRIDGE'
12652       double precision tub_r,vectube(3),enetube(maxres*2)
12653       Etube=0.0d0
12654       do i=1,2*nres
12655         enetube(i)=0.0d0
12656       enddo
12657 C first we calculate the distance from tube center
12658 C first sugare-phosphate group for NARES this would be peptide group
12659 C for UNRES
12660       do i=1,nres
12661 C lets ommit dummy atoms for now
12662        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12663 C now calculate distance from center of tube and direction vectors
12664       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12665           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12666       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12667           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12668       vectube(1)=vectube(1)-tubecenter(1)
12669       vectube(2)=vectube(2)-tubecenter(2)
12670
12671 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12672 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12673
12674 C as the tube is infinity we do not calculate the Z-vector use of Z
12675 C as chosen axis
12676       vectube(3)=0.0d0
12677 C now calculte the distance
12678        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12679 C now normalize vector
12680       vectube(1)=vectube(1)/tub_r
12681       vectube(2)=vectube(2)/tub_r
12682 C calculte rdiffrence between r and r0
12683       rdiff=tub_r-tubeR0
12684 C and its 6 power
12685       rdiff6=rdiff**6.0d0
12686 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12687        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12688 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12689 C       print *,rdiff,rdiff6,pep_aa_tube
12690 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12691 C now we calculate gradient
12692        fac=(-12.0d0*pep_aa_tube/rdiff6+
12693      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12694 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12695 C     &rdiff,fac
12696
12697 C now direction of gg_tube vector
12698         do j=1,3
12699         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12700         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12701         enddo
12702         enddo
12703 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12704         do i=1,nres
12705 C Lets not jump over memory as we use many times iti
12706          iti=itype(i)
12707 C lets ommit dummy atoms for now
12708          if ((iti.eq.ntyp1)
12709 C in UNRES uncomment the line below as GLY has no side-chain...
12710 C      .or.(iti.eq.10)
12711      &   ) cycle
12712           vectube(1)=c(1,i+nres)
12713           vectube(1)=mod(vectube(1),boxxsize)
12714           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12715           vectube(2)=c(2,i+nres)
12716           vectube(2)=mod(vectube(2),boxxsize)
12717           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12718
12719       vectube(1)=vectube(1)-tubecenter(1)
12720       vectube(2)=vectube(2)-tubecenter(2)
12721
12722 C as the tube is infinity we do not calculate the Z-vector use of Z
12723 C as chosen axis
12724       vectube(3)=0.0d0
12725 C now calculte the distance
12726        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12727 C now normalize vector
12728       vectube(1)=vectube(1)/tub_r
12729       vectube(2)=vectube(2)/tub_r
12730 C calculte rdiffrence between r and r0
12731       rdiff=tub_r-tubeR0
12732 C and its 6 power
12733       rdiff6=rdiff**6.0d0
12734 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12735        sc_aa_tube=sc_aa_tube_par(iti)
12736        sc_bb_tube=sc_bb_tube_par(iti)
12737        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12738 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12739 C now we calculate gradient
12740        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12741      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12742 C now direction of gg_tube vector
12743          do j=1,3
12744           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12745           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12746          enddo
12747         enddo
12748         do i=1,2*nres
12749           Etube=Etube+enetube(i)
12750         enddo
12751 C        print *,"ETUBE", etube
12752         return
12753         end
12754 C TO DO 1) add to total energy
12755 C       2) add to gradient summation
12756 C       3) add reading parameters (AND of course oppening of PARAM file)
12757 C       4) add reading the center of tube
12758 C       5) add COMMONs
12759 C       6) add to zerograd
12760
12761 C-----------------------------------------------------------------------
12762 C-----------------------------------------------------------
12763 C This subroutine is to mimic the histone like structure but as well can be
12764 C utilizet to nanostructures (infinit) small modification has to be used to
12765 C make it finite (z gradient at the ends has to be changes as well as the x,y
12766 C gradient has to be modified at the ends
12767 C The energy function is Kihara potential
12768 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12769 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12770 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12771 C simple Kihara potential
12772       subroutine calctube2(Etube)
12773        implicit real*8 (a-h,o-z)
12774       include 'DIMENSIONS'
12775       include 'COMMON.GEO'
12776       include 'COMMON.VAR'
12777       include 'COMMON.LOCAL'
12778       include 'COMMON.CHAIN'
12779       include 'COMMON.DERIV'
12780       include 'COMMON.NAMES'
12781       include 'COMMON.INTERACT'
12782       include 'COMMON.IOUNITS'
12783       include 'COMMON.CALC'
12784       include 'COMMON.CONTROL'
12785       include 'COMMON.SPLITELE'
12786       include 'COMMON.SBRIDGE'
12787       double precision tub_r,vectube(3),enetube(maxres*2)
12788       Etube=0.0d0
12789       do i=1,2*nres
12790         enetube(i)=0.0d0
12791       enddo
12792 C first we calculate the distance from tube center
12793 C first sugare-phosphate group for NARES this would be peptide group
12794 C for UNRES
12795       do i=1,nres
12796 C lets ommit dummy atoms for now
12797        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12798 C now calculate distance from center of tube and direction vectors
12799       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12800           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12801       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12802           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12803       vectube(1)=vectube(1)-tubecenter(1)
12804       vectube(2)=vectube(2)-tubecenter(2)
12805
12806 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12807 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12808
12809 C as the tube is infinity we do not calculate the Z-vector use of Z
12810 C as chosen axis
12811       vectube(3)=0.0d0
12812 C now calculte the distance
12813        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12814 C now normalize vector
12815       vectube(1)=vectube(1)/tub_r
12816       vectube(2)=vectube(2)/tub_r
12817 C calculte rdiffrence between r and r0
12818       rdiff=tub_r-tubeR0
12819 C and its 6 power
12820       rdiff6=rdiff**6.0d0
12821 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12822        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12823 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12824 C       print *,rdiff,rdiff6,pep_aa_tube
12825 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12826 C now we calculate gradient
12827        fac=(-12.0d0*pep_aa_tube/rdiff6+
12828      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12829 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12830 C     &rdiff,fac
12831
12832 C now direction of gg_tube vector
12833         do j=1,3
12834         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12835         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12836         enddo
12837         enddo
12838 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12839         do i=1,nres
12840 C Lets not jump over memory as we use many times iti
12841          iti=itype(i)
12842 C lets ommit dummy atoms for now
12843          if ((iti.eq.ntyp1)
12844 C in UNRES uncomment the line below as GLY has no side-chain...
12845      &      .or.(iti.eq.10)
12846      &   ) cycle
12847           vectube(1)=c(1,i+nres)
12848           vectube(1)=mod(vectube(1),boxxsize)
12849           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12850           vectube(2)=c(2,i+nres)
12851           vectube(2)=mod(vectube(2),boxxsize)
12852           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12853
12854       vectube(1)=vectube(1)-tubecenter(1)
12855       vectube(2)=vectube(2)-tubecenter(2)
12856 C THIS FRAGMENT MAKES TUBE FINITE
12857         positi=(mod(c(3,i+nres),boxzsize))
12858         if (positi.le.0) positi=positi+boxzsize
12859 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12860 c for each residue check if it is in lipid or lipid water border area
12861 C       respos=mod(c(3,i+nres),boxzsize)
12862        print *,positi,bordtubebot,buftubebot,bordtubetop
12863        if ((positi.gt.bordtubebot)
12864      & .and.(positi.lt.bordtubetop)) then
12865 C the energy transfer exist
12866         if (positi.lt.buftubebot) then
12867          fracinbuf=1.0d0-
12868      &     ((positi-bordtubebot)/tubebufthick)
12869 C lipbufthick is thickenes of lipid buffore
12870          sstube=sscalelip(fracinbuf)
12871          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12872          print *,ssgradtube, sstube,tubetranene(itype(i))
12873          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12874          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12875      &+ssgradtube*tubetranene(itype(i))
12876          gg_tube(3,i-1)= gg_tube(3,i-1)
12877      &+ssgradtube*tubetranene(itype(i))
12878 C         print *,"doing sccale for lower part"
12879         elseif (positi.gt.buftubetop) then
12880          fracinbuf=1.0d0-
12881      &((bordtubetop-positi)/tubebufthick)
12882          sstube=sscalelip(fracinbuf)
12883          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12884          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12885 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12886 C     &+ssgradtube*tubetranene(itype(i))
12887 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12888 C     &+ssgradtube*tubetranene(itype(i))
12889 C          print *, "doing sscalefor top part",sslip,fracinbuf
12890         else
12891          sstube=1.0d0
12892          ssgradtube=0.0d0
12893          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12894 C         print *,"I am in true lipid"
12895         endif
12896         else
12897 C          sstube=0.0d0
12898 C          ssgradtube=0.0d0
12899         cycle
12900         endif ! if in lipid or buffor
12901 CEND OF FINITE FRAGMENT
12902 C as the tube is infinity we do not calculate the Z-vector use of Z
12903 C as chosen axis
12904       vectube(3)=0.0d0
12905 C now calculte the distance
12906        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12907 C now normalize vector
12908       vectube(1)=vectube(1)/tub_r
12909       vectube(2)=vectube(2)/tub_r
12910 C calculte rdiffrence between r and r0
12911       rdiff=tub_r-tubeR0
12912 C and its 6 power
12913       rdiff6=rdiff**6.0d0
12914 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12915        sc_aa_tube=sc_aa_tube_par(iti)
12916        sc_bb_tube=sc_bb_tube_par(iti)
12917        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12918      &                 *sstube+enetube(i+nres)
12919 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12920 C now we calculate gradient
12921        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12922      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12923 C now direction of gg_tube vector
12924          do j=1,3
12925           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12926           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12927          enddo
12928          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12929      &+ssgradtube*enetube(i+nres)/sstube
12930          gg_tube(3,i-1)= gg_tube(3,i-1)
12931      &+ssgradtube*enetube(i+nres)/sstube
12932
12933         enddo
12934         do i=1,2*nres
12935           Etube=Etube+enetube(i)
12936         enddo
12937 C        print *,"ETUBE", etube
12938         return
12939         end
12940 C TO DO 1) add to total energy
12941 C       2) add to gradient summation
12942 C       3) add reading parameters (AND of course oppening of PARAM file)
12943 C       4) add reading the center of tube
12944 C       5) add COMMONs
12945 C       6) add to zerograd
12946 c----------------------------------------------------------------------------
12947       subroutine e_saxs(Esaxs_constr)
12948       implicit none
12949       include 'DIMENSIONS'
12950 #ifdef MPI
12951       include "mpif.h"
12952       include "COMMON.SETUP"
12953       integer IERR
12954 #endif
12955       include 'COMMON.SBRIDGE'
12956       include 'COMMON.CHAIN'
12957       include 'COMMON.GEO'
12958       include 'COMMON.DERIV'
12959       include 'COMMON.LOCAL'
12960       include 'COMMON.INTERACT'
12961       include 'COMMON.VAR'
12962       include 'COMMON.IOUNITS'
12963 c      include 'COMMON.MD'
12964 #ifdef LANG0
12965 #ifdef FIVEDIAG
12966       include 'COMMON.LANGEVIN.lang0.5diag'
12967 #else
12968       include 'COMMON.LANGEVIN.lang0'
12969 #endif
12970 #else
12971       include 'COMMON.LANGEVIN'
12972 #endif
12973       include 'COMMON.CONTROL'
12974       include 'COMMON.SAXS'
12975       include 'COMMON.NAMES'
12976       include 'COMMON.TIME1'
12977       include 'COMMON.FFIELD'
12978 c
12979       double precision Esaxs_constr
12980       integer i,iint,j,k,l
12981       double precision PgradC(maxSAXS,3,maxres),
12982      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12983 #ifdef MPI
12984       double precision PgradC_(maxSAXS,3,maxres),
12985      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12986 #endif
12987       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12988      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12989      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12990      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12991       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12992       double precision dist,mygauss,mygaussder
12993       external dist
12994       integer llicz,lllicz
12995       double precision time01
12996 c  SAXS restraint penalty function
12997 #ifdef DEBUG
12998       write(iout,*) "------- SAXS penalty function start -------"
12999       write (iout,*) "nsaxs",nsaxs
13000       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13001       write (iout,*) "Psaxs"
13002       do i=1,nsaxs
13003         write (iout,'(i5,e15.5)') i, Psaxs(i)
13004       enddo
13005 #endif
13006 #ifdef TIMING
13007       time01=MPI_Wtime()
13008 #endif
13009       Esaxs_constr = 0.0d0
13010       do k=1,nsaxs
13011         Pcalc(k)=0.0d0
13012         do j=1,nres
13013           do l=1,3
13014             PgradC(k,l,j)=0.0d0
13015             PgradX(k,l,j)=0.0d0
13016           enddo
13017         enddo
13018       enddo
13019 c      lllicz=0
13020       do i=iatsc_s,iatsc_e
13021        if (itype(i).eq.ntyp1) cycle
13022        do iint=1,nint_gr(i)
13023          do j=istart(i,iint),iend(i,iint)
13024            if (itype(j).eq.ntyp1) cycle
13025 #ifdef ALLSAXS
13026            dijCACA=dist(i,j)
13027            dijCASC=dist(i,j+nres)
13028            dijSCCA=dist(i+nres,j)
13029            dijSCSC=dist(i+nres,j+nres)
13030            sigma2CACA=2.0d0/(pstok**2)
13031            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13032            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13033            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13034            do k=1,nsaxs
13035              dk = distsaxs(k)
13036              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13037              if (itype(j).ne.10) then
13038              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13039              else
13040              endif
13041              expCASC = 0.0d0
13042              if (itype(i).ne.10) then
13043              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13044              else
13045              expSCCA = 0.0d0
13046              endif
13047              if (itype(i).ne.10 .and. itype(j).ne.10) then
13048              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13049              else
13050              expSCSC = 0.0d0
13051              endif
13052              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13053 #ifdef DEBUG
13054              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13055 #endif
13056              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13057              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13058              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13059              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13060              do l=1,3
13061 c CA CA
13062                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13063                PgradC(k,l,i) = PgradC(k,l,i)-aux
13064                PgradC(k,l,j) = PgradC(k,l,j)+aux
13065 c CA SC
13066                if (itype(j).ne.10) then
13067                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13068                PgradC(k,l,i) = PgradC(k,l,i)-aux
13069                PgradC(k,l,j) = PgradC(k,l,j)+aux
13070                PgradX(k,l,j) = PgradX(k,l,j)+aux
13071                endif
13072 c SC CA
13073                if (itype(i).ne.10) then
13074                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13075                PgradX(k,l,i) = PgradX(k,l,i)-aux
13076                PgradC(k,l,i) = PgradC(k,l,i)-aux
13077                PgradC(k,l,j) = PgradC(k,l,j)+aux
13078                endif
13079 c SC SC
13080                if (itype(i).ne.10 .and. itype(j).ne.10) then
13081                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13082                PgradC(k,l,i) = PgradC(k,l,i)-aux
13083                PgradC(k,l,j) = PgradC(k,l,j)+aux
13084                PgradX(k,l,i) = PgradX(k,l,i)-aux
13085                PgradX(k,l,j) = PgradX(k,l,j)+aux
13086                endif
13087              enddo ! l
13088            enddo ! k
13089 #else
13090            dijCACA=dist(i,j)
13091            sigma2CACA=scal_rad**2*0.25d0/
13092      &        (restok(itype(j))**2+restok(itype(i))**2)
13093 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13094 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13095 #ifdef MYGAUSS
13096            sigmaCACA=dsqrt(sigma2CACA)
13097            threesig=3.0d0/sigmaCACA
13098 c           llicz=0
13099            do k=1,nsaxs
13100              dk = distsaxs(k)
13101              if (dabs(dijCACA-dk).ge.threesig) cycle
13102 c             llicz=llicz+1
13103 c             lllicz=lllicz+1
13104              aux = sigmaCACA*(dijCACA-dk)
13105              expCACA = mygauss(aux)
13106 c             if (expcaca.eq.0.0d0) cycle
13107              Pcalc(k) = Pcalc(k)+expCACA
13108              CACAgrad = -sigmaCACA*mygaussder(aux)
13109 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13110              do l=1,3
13111                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13112                PgradC(k,l,i) = PgradC(k,l,i)-aux
13113                PgradC(k,l,j) = PgradC(k,l,j)+aux
13114              enddo ! l
13115            enddo ! k
13116 c           write (iout,*) "i",i," j",j," llicz",llicz
13117 #else
13118            IF (saxs_cutoff.eq.0) THEN
13119            do k=1,nsaxs
13120              dk = distsaxs(k)
13121              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13122              Pcalc(k) = Pcalc(k)+expCACA
13123              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13124              do l=1,3
13125                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13126                PgradC(k,l,i) = PgradC(k,l,i)-aux
13127                PgradC(k,l,j) = PgradC(k,l,j)+aux
13128              enddo ! l
13129            enddo ! k
13130            ELSE
13131            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13132            do k=1,nsaxs
13133              dk = distsaxs(k)
13134 c             write (2,*) "ijk",i,j,k
13135              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13136              if (sss2.eq.0.0d0) cycle
13137              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13138              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13139      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13140      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13141      &           sss2,ssgrad2
13142              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13143              Pcalc(k) = Pcalc(k)+expCACA
13144 #ifdef DEBUG
13145              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13146 #endif
13147              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13148      &             ssgrad2*expCACA/sss2
13149              do l=1,3
13150 c CA CA
13151                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13152                PgradC(k,l,i) = PgradC(k,l,i)+aux
13153                PgradC(k,l,j) = PgradC(k,l,j)-aux
13154              enddo ! l
13155            enddo ! k
13156            ENDIF
13157 #endif
13158 #endif
13159          enddo ! j
13160        enddo ! iint
13161       enddo ! i
13162 c#ifdef TIMING
13163 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13164 c#endif
13165 c      write (iout,*) "lllicz",lllicz
13166 c#ifdef TIMING
13167 c      time01=MPI_Wtime()
13168 c#endif
13169 #ifdef MPI
13170       if (nfgtasks.gt.1) then
13171        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13172      &    MPI_SUM,FG_COMM,IERR)
13173 c        if (fg_rank.eq.king) then
13174           do k=1,nsaxs
13175             Pcalc(k) = Pcalc_(k)
13176           enddo
13177 c        endif
13178 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13179 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13180 c        if (fg_rank.eq.king) then
13181 c          do i=1,nres
13182 c            do l=1,3
13183 c              do k=1,nsaxs
13184 c                PgradC(k,l,i) = PgradC_(k,l,i)
13185 c              enddo
13186 c            enddo
13187 c          enddo
13188 c        endif
13189 #ifdef ALLSAXS
13190 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13191 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13192 c        if (fg_rank.eq.king) then
13193 c          do i=1,nres
13194 c            do l=1,3
13195 c              do k=1,nsaxs
13196 c                PgradX(k,l,i) = PgradX_(k,l,i)
13197 c              enddo
13198 c            enddo
13199 c          enddo
13200 c        endif
13201 #endif
13202       endif
13203 #endif
13204       Cnorm = 0.0d0
13205       do k=1,nsaxs
13206         Cnorm = Cnorm + Pcalc(k)
13207       enddo
13208 #ifdef MPI
13209       if (fg_rank.eq.king) then
13210 #endif
13211       Esaxs_constr = dlog(Cnorm)-wsaxs0
13212       do k=1,nsaxs
13213         if (Pcalc(k).gt.0.0d0)
13214      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13215 #ifdef DEBUG
13216         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13217 #endif
13218       enddo
13219 #ifdef DEBUG
13220       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13221 #endif
13222 #ifdef MPI
13223       endif
13224 #endif
13225       gsaxsC=0.0d0
13226       gsaxsX=0.0d0
13227       do i=nnt,nct
13228         do l=1,3
13229           auxC=0.0d0
13230           auxC1=0.0d0
13231           auxX=0.0d0
13232           auxX1=0.d0
13233           do k=1,nsaxs
13234             if (Pcalc(k).gt.0)
13235      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13236             auxC1 = auxC1+PgradC(k,l,i)
13237 #ifdef ALLSAXS
13238             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13239             auxX1 = auxX1+PgradX(k,l,i)
13240 #endif
13241           enddo
13242           gsaxsC(l,i) = auxC - auxC1/Cnorm
13243 #ifdef ALLSAXS
13244           gsaxsX(l,i) = auxX - auxX1/Cnorm
13245 #endif
13246 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13247 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13248 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13249 c     *     " gradX",wsaxs*gsaxsX(l,i)
13250         enddo
13251       enddo
13252 #ifdef TIMING
13253       time_SAXS=time_SAXS+MPI_Wtime()-time01
13254 #endif
13255 #ifdef DEBUG
13256       write (iout,*) "gsaxsc"
13257       do i=nnt,nct
13258         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13259       enddo
13260 #endif
13261 #ifdef MPI
13262 c      endif
13263 #endif
13264       return
13265       end
13266 c----------------------------------------------------------------------------
13267       subroutine e_saxsC(Esaxs_constr)
13268       implicit none
13269       include 'DIMENSIONS'
13270 #ifdef MPI
13271       include "mpif.h"
13272       include "COMMON.SETUP"
13273       integer IERR
13274 #endif
13275       include 'COMMON.SBRIDGE'
13276       include 'COMMON.CHAIN'
13277       include 'COMMON.GEO'
13278       include 'COMMON.DERIV'
13279       include 'COMMON.LOCAL'
13280       include 'COMMON.INTERACT'
13281       include 'COMMON.VAR'
13282       include 'COMMON.IOUNITS'
13283 c      include 'COMMON.MD'
13284 #ifdef LANG0
13285 #ifdef FIVEDIAG
13286       include 'COMMON.LANGEVIN.lang0.5diag'
13287 #else
13288       include 'COMMON.LANGEVIN.lang0'
13289 #endif
13290 #else
13291       include 'COMMON.LANGEVIN'
13292 #endif
13293       include 'COMMON.CONTROL'
13294       include 'COMMON.SAXS'
13295       include 'COMMON.NAMES'
13296       include 'COMMON.TIME1'
13297       include 'COMMON.FFIELD'
13298 c
13299       double precision Esaxs_constr
13300       integer i,iint,j,k,l
13301       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13302 #ifdef MPI
13303       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13304 #endif
13305       double precision dk,dijCASPH,dijSCSPH,
13306      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13307      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13308      & auxX,auxX1,Cnorm
13309 c  SAXS restraint penalty function
13310 #ifdef DEBUG
13311       write(iout,*) "------- SAXS penalty function start -------"
13312       write (iout,*) "nsaxs",nsaxs
13313
13314       do i=nnt,nct
13315         print *,MyRank,"C",i,(C(j,i),j=1,3)
13316       enddo
13317       do i=nnt,nct
13318         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13319       enddo
13320 #endif
13321       Esaxs_constr = 0.0d0
13322       logPtot=0.0d0
13323       do j=isaxs_start,isaxs_end
13324         Pcalc=0.0d0
13325         do i=1,nres
13326           do l=1,3
13327             PgradC(l,i)=0.0d0
13328             PgradX(l,i)=0.0d0
13329           enddo
13330         enddo
13331         do i=nnt,nct
13332           if (itype(i).eq.ntyp1) cycle
13333           dijCASPH=0.0d0
13334           dijSCSPH=0.0d0
13335           do l=1,3
13336             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13337           enddo
13338           if (itype(i).ne.10) then
13339           do l=1,3
13340             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13341           enddo
13342           endif
13343           sigma2CA=2.0d0/pstok**2
13344           sigma2SC=4.0d0/restok(itype(i))**2
13345           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13346           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13347           Pcalc = Pcalc+expCASPH+expSCSPH
13348 #ifdef DEBUG
13349           write(*,*) "processor i j Pcalc",
13350      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13351 #endif
13352           CASPHgrad = sigma2CA*expCASPH
13353           SCSPHgrad = sigma2SC*expSCSPH
13354           do l=1,3
13355             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13356             PgradX(l,i) = PgradX(l,i) + aux
13357             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13358           enddo ! l
13359         enddo ! i
13360         do i=nnt,nct
13361           do l=1,3
13362             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13363             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13364           enddo
13365         enddo
13366         logPtot = logPtot - dlog(Pcalc)
13367 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13368 c     &    " logPtot",logPtot
13369       enddo ! j
13370 #ifdef MPI
13371       if (nfgtasks.gt.1) then
13372 c        write (iout,*) "logPtot before reduction",logPtot
13373         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13374      &    MPI_SUM,king,FG_COMM,IERR)
13375         logPtot = logPtot_
13376 c        write (iout,*) "logPtot after reduction",logPtot
13377         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13378      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13379         if (fg_rank.eq.king) then
13380           do i=1,nres
13381             do l=1,3
13382               gsaxsC(l,i) = gsaxsC_(l,i)
13383             enddo
13384           enddo
13385         endif
13386         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13387      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13388         if (fg_rank.eq.king) then
13389           do i=1,nres
13390             do l=1,3
13391               gsaxsX(l,i) = gsaxsX_(l,i)
13392             enddo
13393           enddo
13394         endif
13395       endif
13396 #endif
13397       Esaxs_constr = logPtot
13398       return
13399       end
13400 c----------------------------------------------------------------------------
13401       double precision function sscale2(r,r_cut,r0,rlamb)
13402       implicit none
13403       double precision r,gamm,r_cut,r0,rlamb,rr
13404       rr = dabs(r-r0)
13405 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13406 c      write (2,*) "rr",rr
13407       if(rr.lt.r_cut-rlamb) then
13408         sscale2=1.0d0
13409       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13410         gamm=(rr-(r_cut-rlamb))/rlamb
13411         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13412       else
13413         sscale2=0d0
13414       endif
13415       return
13416       end
13417 C-----------------------------------------------------------------------
13418       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13419       implicit none
13420       double precision r,gamm,r_cut,r0,rlamb,rr
13421       rr = dabs(r-r0)
13422       if(rr.lt.r_cut-rlamb) then
13423         sscalgrad2=0.0d0
13424       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13425         gamm=(rr-(r_cut-rlamb))/rlamb
13426         if (r.ge.r0) then
13427           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13428         else
13429           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13430         endif
13431       else
13432         sscalgrad2=0.0d0
13433       endif
13434       return
13435       end
13436 c------------------------------------------------------------------------
13437       double precision function boxshift(x,boxsize)
13438       implicit none
13439       double precision x,boxsize
13440       double precision xtemp
13441       xtemp=dmod(x,boxsize)
13442       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13443         boxshift=xtemp-boxsize
13444       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13445         boxshift=xtemp+boxsize
13446       else
13447         boxshift=xtemp
13448       endif
13449       return
13450       end
13451 c--------------------------------------------------------------------------
13452       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13453       include 'DIMENSIONS'
13454       include 'COMMON.CHAIN'
13455       integer xshift,yshift,zshift,subchap
13456       double precision dist_init,xj_safe,yj_safe,zj_safe,
13457      & xj_temp,yj_temp,zj_temp,dist_temp
13458       xj_safe=xj
13459       yj_safe=yj
13460       zj_safe=zj
13461       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13462       subchap=0
13463       do xshift=-1,1
13464         do yshift=-1,1
13465           do zshift=-1,1
13466             xj=xj_safe+xshift*boxxsize
13467             yj=yj_safe+yshift*boxysize
13468             zj=zj_safe+zshift*boxzsize
13469             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13470             if(dist_temp.lt.dist_init) then
13471               dist_init=dist_temp
13472               xj_temp=xj
13473               yj_temp=yj
13474               zj_temp=zj
13475               subchap=1
13476             endif
13477           enddo
13478         enddo
13479       enddo
13480       if (subchap.eq.1) then
13481         xj=xj_temp-xi
13482         yj=yj_temp-yi
13483         zj=zj_temp-zi
13484       else
13485         xj=xj_safe-xi
13486         yj=yj_safe-yi
13487         zj=zj_safe-zi
13488       endif
13489       return
13490       end
13491 c--------------------------------------------------------------------------
13492       subroutine to_box(xi,yi,zi)
13493       implicit none
13494       include 'DIMENSIONS'
13495       include 'COMMON.CHAIN'
13496       double precision xi,yi,zi
13497       xi=dmod(xi,boxxsize)
13498       if (xi.lt.0.0d0) xi=xi+boxxsize
13499       yi=dmod(yi,boxysize)
13500       if (yi.lt.0.0d0) yi=yi+boxysize
13501       zi=dmod(zi,boxzsize)
13502       if (zi.lt.0.0d0) zi=zi+boxzsize
13503       return
13504       end
13505 c--------------------------------------------------------------------------
13506       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13507       implicit none
13508       include 'DIMENSIONS'
13509       include 'COMMON.IOUNITS'
13510       include 'COMMON.CHAIN'
13511       double precision xi,yi,zi,sslipi,ssgradlipi
13512       double precision fracinbuf
13513       double precision sscalelip,sscagradlip
13514 #ifdef DEBUG
13515       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
13516       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
13517       write (iout,*) "xi yi zi",xi,yi,zi
13518 #endif
13519       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13520 C the energy transfer exist
13521         if (zi.lt.buflipbot) then
13522 C what fraction I am in
13523           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13524 C lipbufthick is thickenes of lipid buffore
13525           sslipi=sscalelip(fracinbuf)
13526           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13527         elseif (zi.gt.bufliptop) then
13528           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13529           sslipi=sscalelip(fracinbuf)
13530           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13531         else
13532           sslipi=1.0d0
13533           ssgradlipi=0.0
13534         endif
13535       else
13536         sslipi=0.0d0
13537         ssgradlipi=0.0
13538       endif
13539 #ifdef DEBUG
13540       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
13541 #endif
13542       return
13543       end